Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : master
http://hackage.haskell.org/trac/ghc/changeset/d23148a9bbec06bc737b13572e5ee8c353060b29 >--------------------------------------------------------------- commit d23148a9bbec06bc737b13572e5ee8c353060b29 Author: Ian Lynagh <i...@well-typed.com> Date: Tue Dec 11 18:17:57 2012 +0000 Package the NativeGen state up into a named type This will make it a little more pleasant to have the nativegen build for multiple ways at once. >--------------------------------------------------------------- compiler/nativeGen/AsmCodeGen.lhs | 61 ++++++++++++++++--------------------- 1 files changed, 26 insertions(+), 35 deletions(-) diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs index 38cd7b7..ae5cd6f 100644 --- a/compiler/nativeGen/AsmCodeGen.lhs +++ b/compiler/nativeGen/AsmCodeGen.lhs @@ -238,6 +238,13 @@ noAllocMoreStack amount _ ++ " You can still file a bug report if you like.\n" +type NativeGenState statics instr = (BufHandle, NativeGenAcc statics instr) +type NativeGenAcc statics instr + = ([[CLabel]], + [([NatCmmDecl statics instr], + Maybe [Color.RegAllocStats statics instr], + Maybe [Linear.RegAllocStats])]) + nativeCodeGen' :: (Outputable statics, Outputable instr, Instruction instr) => DynFlags -> NcgImpl statics instr jumpDest @@ -250,7 +257,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, us') <- cmmNativeGenStream dflags ncgImpl bufh us split_cmms [] [] 0 + ((imports, prof), us') <- cmmNativeGenStream dflags ncgImpl us split_cmms (bufh, ([], [])) 0 bFlush bufh let (native, colorStats, linearStats) @@ -307,55 +314,39 @@ nativeCodeGen' dflags ncgImpl h us cmms cmmNativeGenStream :: (Outputable statics, Outputable instr, Instruction instr) => DynFlags -> NcgImpl statics instr jumpDest - -> BufHandle -> UniqSupply -> Stream IO RawCmmGroup () - -> [[CLabel]] - -> [ ([NatCmmDecl statics instr], - Maybe [Color.RegAllocStats statics instr], - Maybe [Linear.RegAllocStats]) ] + -> NativeGenState statics instr -> Int - -> IO ( [[CLabel]], - [([NatCmmDecl statics instr], - Maybe [Color.RegAllocStats statics instr], - Maybe [Linear.RegAllocStats])], - UniqSupply ) + -> IO (NativeGenAcc statics instr, UniqSupply) -cmmNativeGenStream dflags ncgImpl h us cmm_stream impAcc profAcc count +cmmNativeGenStream dflags ncgImpl us cmm_stream ngs@(h, nga) count = do r <- Stream.runStream cmm_stream case r of - Left () -> return (reverse impAcc, reverse profAcc, us) + Left () -> + case nga of + (impAcc, profAcc) -> + return ((reverse impAcc, reverse profAcc), us) Right (cmms, cmm_stream') -> do - (impAcc,profAcc,us') <- cmmNativeGens dflags ncgImpl h us cmms - impAcc profAcc count - cmmNativeGenStream dflags ncgImpl h us' cmm_stream' - impAcc profAcc count - + (nga',us') <- cmmNativeGens dflags ncgImpl us cmms ngs count + cmmNativeGenStream dflags ncgImpl us' cmm_stream' (h, nga') count -- | Do native code generation on all these cmms. -- cmmNativeGens :: (Outputable statics, Outputable instr, Instruction instr) => DynFlags -> NcgImpl statics instr jumpDest - -> BufHandle -> UniqSupply -> [RawCmmDecl] - -> [[CLabel]] - -> [ ([NatCmmDecl statics instr], - Maybe [Color.RegAllocStats statics instr], - Maybe [Linear.RegAllocStats]) ] + -> NativeGenState statics instr -> Int - -> IO ( [[CLabel]], - [([NatCmmDecl statics instr], - Maybe [Color.RegAllocStats statics instr], - Maybe [Linear.RegAllocStats])], - UniqSupply ) + -> IO (NativeGenAcc statics instr, UniqSupply) -cmmNativeGens _ _ _ us [] impAcc profAcc _ - = return (impAcc,profAcc,us) +cmmNativeGens _ _ us [] (_, nga) _ + = return (nga, us) -cmmNativeGens dflags ncgImpl h us (cmm : cmms) impAcc profAcc count +cmmNativeGens dflags ncgImpl us (cmm : cmms) (h, (impAcc, profAcc)) count = do (us', native, imports, colorStats, linearStats) <- {-# SCC "cmmNativeGen" #-} cmmNativeGen dflags ncgImpl us cmm count @@ -376,10 +367,10 @@ cmmNativeGens dflags ncgImpl h us (cmm : cmms) impAcc profAcc count {-# SCC "seqString" #-} evaluate $ seqString (showSDoc dflags $ vcat $ map ppr imports) cmmNativeGens dflags ncgImpl - h us' cmms - (imports : impAcc) - ((lsPprNative, colorStats, linearStats) : profAcc) - count' + us' cmms (h, + ((imports : impAcc), + ((lsPprNative, colorStats, linearStats) : profAcc))) + count' where seqString [] = () seqString (x:xs) = x `seq` seqString xs _______________________________________________ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
