Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : master
http://hackage.haskell.org/trac/ghc/changeset/6bdac1c375dc754ad3a540f704437650b43474c1 >--------------------------------------------------------------- commit 6bdac1c375dc754ad3a540f704437650b43474c1 Author: Ian Lynagh <i...@well-typed.com> Date: Thu Dec 6 19:34:27 2012 +0000 Make nativeCodeGen return the rest of its UniqSupply >--------------------------------------------------------------- compiler/main/CodeOutput.lhs | 5 +++-- compiler/nativeGen/AsmCodeGen.lhs | 16 +++++++++------- 2 files changed, 12 insertions(+), 9 deletions(-) diff --git a/compiler/main/CodeOutput.lhs b/compiler/main/CodeOutput.lhs index 230ba71..f76b0ef 100644 --- a/compiler/main/CodeOutput.lhs +++ b/compiler/main/CodeOutput.lhs @@ -83,7 +83,7 @@ codeOutput dflags this_mod location foreign_stubs pkg_deps cmm_stream ; return stubs_exist } -doOutput :: String -> (Handle -> IO ()) -> IO () +doOutput :: String -> (Handle -> IO a) -> IO a doOutput filenm io_action = bracket (openFile filenm WriteMode) hClose io_action \end{code} @@ -144,9 +144,10 @@ outputAsm dflags filenm cmm_stream | cGhcWithNativeCodeGen == "YES" = do ncg_uniqs <- mkSplitUniqSupply 'n' - {-# SCC "OutputAsm" #-} doOutput filenm $ + _ <- {-# SCC "OutputAsm" #-} doOutput filenm $ \f -> {-# SCC "NativeCodeGen" #-} nativeCodeGen dflags f ncg_uniqs cmm_stream + return () | otherwise = panic "This compiler was built without a native code generator" diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs index 863af12..9917619 100644 --- a/compiler/nativeGen/AsmCodeGen.lhs +++ b/compiler/nativeGen/AsmCodeGen.lhs @@ -151,10 +151,11 @@ data NcgImpl statics instr jumpDest = NcgImpl { } -------------------- -nativeCodeGen :: DynFlags -> Handle -> UniqSupply -> Stream IO RawCmmGroup () -> IO () +nativeCodeGen :: DynFlags -> Handle -> UniqSupply -> Stream IO RawCmmGroup () + -> IO UniqSupply nativeCodeGen dflags h us cmms = let platform = targetPlatform dflags - nCG' :: (Outputable statics, Outputable instr, Instruction instr) => NcgImpl statics instr jumpDest -> IO () + nCG' :: (Outputable statics, Outputable instr, Instruction instr) => NcgImpl statics instr jumpDest -> IO UniqSupply nCG' ncgImpl = nativeCodeGen' dflags ncgImpl h us cmms x86NcgImpl = NcgImpl { cmmTopCodeGen = X86.CodeGen.cmmTopCodeGen @@ -239,7 +240,7 @@ noAllocMoreStack amount _ nativeCodeGen' :: (Outputable statics, Outputable instr, Instruction instr) => DynFlags -> NcgImpl statics instr jumpDest - -> Handle -> UniqSupply -> Stream IO RawCmmGroup () -> IO () + -> Handle -> UniqSupply -> Stream IO RawCmmGroup () -> IO UniqSupply nativeCodeGen' dflags ncgImpl h us cmms = do let platform = targetPlatform dflags @@ -248,7 +249,7 @@ nativeCodeGen' dflags ncgImpl h us cmms -- Pretty if it weren't for the fact that we do lots of little -- printDocs here (in order to do codegen in constant space). bufh <- newBufHandle h - (imports, prof) <- cmmNativeGenStream dflags ncgImpl bufh us split_cmms [] [] 0 + (imports, prof, us') <- cmmNativeGenStream dflags ncgImpl bufh us split_cmms [] [] 0 bFlush bufh let (native, colorStats, linearStats) @@ -293,7 +294,7 @@ nativeCodeGen' dflags ncgImpl h us cmms $ withPprStyleDoc dflags (mkCodeStyle AsmStyle) $ makeImportsDoc dflags (concat imports) - return () + return us' where add_split tops | gopt Opt_SplitObjs dflags = split_marker : tops @@ -316,13 +317,14 @@ cmmNativeGenStream :: (Outputable statics, Outputable instr, Instruction instr) -> IO ( [[CLabel]], [([NatCmmDecl statics instr], Maybe [Color.RegAllocStats statics instr], - Maybe [Linear.RegAllocStats])] ) + Maybe [Linear.RegAllocStats])], + UniqSupply ) cmmNativeGenStream dflags ncgImpl h us cmm_stream impAcc profAcc count = do r <- Stream.runStream cmm_stream case r of - Left () -> return (reverse impAcc, reverse profAcc) + Left () -> return (reverse impAcc, reverse profAcc, us) Right (cmms, cmm_stream') -> do (impAcc,profAcc,us') <- cmmNativeGens dflags ncgImpl h us cmms impAcc profAcc count _______________________________________________ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
