Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : master
http://hackage.haskell.org/trac/ghc/changeset/8685535cfdfc68223162070c50d604072c3213b7 >--------------------------------------------------------------- commit 8685535cfdfc68223162070c50d604072c3213b7 Author: Ian Lynagh <i...@well-typed.com> Date: Tue Dec 11 19:09:01 2012 +0000 Add more plumbing to the nativeCodeGen This patch adds more of the plumbing necessary to allow the nativeGen to build multiple ways in a single compilation. >--------------------------------------------------------------- compiler/nativeGen/AsmCodeGen.lhs | 86 ++++++++++++++++++++++++------------- 1 files changed, 56 insertions(+), 30 deletions(-) diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs index e8781f3..ce62a64 100644 --- a/compiler/nativeGen/AsmCodeGen.lhs +++ b/compiler/nativeGen/AsmCodeGen.lhs @@ -251,15 +251,35 @@ nativeCodeGen' :: (Outputable statics, Outputable instr, Instruction instr) -> Handle -> UniqSupply -> Stream IO RawCmmGroup () -> IO UniqSupply nativeCodeGen' dflags ncgImpl h us cmms = do - let platform = targetPlatform dflags - split_cmms = Stream.map add_split cmms + let split_cmms = Stream.map add_split cmms -- BufHandle is a performance hack. We could hide it inside -- 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 us split_cmms (bufh, ([], [])) + let ngss = [(bufh, ([], []))] + (ngss', us') <- cmmNativeGenStream dflags ncgImpl us split_cmms ngss + mapM_ (finishNativeGen dflags ncgImpl) ngss' + + return us' + + where add_split tops + | gopt Opt_SplitObjs dflags = split_marker : tops + | otherwise = tops + + split_marker = CmmProc mapEmpty mkSplitMarkerLabel [] + (ofBlockList (panic "split_marker_entry") []) + + +finishNativeGen :: Instruction instr + => DynFlags + -> NcgImpl statics instr jumpDest + -> NativeGenState statics instr + -> IO () +finishNativeGen dflags ncgImpl (bufh@(BufHandle _ _ h), (imports, prof)) + = do bFlush bufh + let platform = targetPlatform dflags let (native, colorStats, linearStats) = unzip3 prof @@ -302,34 +322,24 @@ nativeCodeGen' dflags ncgImpl h us cmms $ withPprStyleDoc dflags (mkCodeStyle AsmStyle) $ makeImportsDoc dflags (concat imports) - return us' - - where add_split tops - | gopt Opt_SplitObjs dflags = split_marker : tops - | otherwise = tops - - split_marker = CmmProc mapEmpty mkSplitMarkerLabel [] - (ofBlockList (panic "split_marker_entry") []) - cmmNativeGenStream :: (Outputable statics, Outputable instr, Instruction instr) => DynFlags -> NcgImpl statics instr jumpDest -> UniqSupply -> Stream IO RawCmmGroup () - -> NativeGenState statics instr - -> IO (NativeGenAcc statics instr, UniqSupply) + -> [NativeGenState statics instr] + -> IO ([NativeGenState statics instr], UniqSupply) -cmmNativeGenStream dflags ncgImpl us cmm_stream ngs@(h, nga) - = do - r <- Stream.runStream cmm_stream - case r of +cmmNativeGenStream dflags ncgImpl us cmm_stream ngss + = do r <- Stream.runStream cmm_stream + case r of Left () -> - case nga of - (impAcc, profAcc) -> - return ((reverse impAcc, reverse profAcc), us) + return ([ (h, (reverse impAcc, reverse profAcc)) + | (h, (impAcc, profAcc)) <- ngss ] + , us) Right (cmms, cmm_stream') -> do - (nga',us') <- cmmNativeGens dflags ncgImpl us cmms ngs 0 - cmmNativeGenStream dflags ncgImpl us' cmm_stream' (h, nga') + (ngss',us') <- cmmNativeGens dflags ncgImpl us cmms ngss + cmmNativeGenStream dflags ncgImpl us' cmm_stream' ngss' -- | Do native code generation on all these cmms. -- @@ -338,14 +348,30 @@ cmmNativeGens :: (Outputable statics, Outputable instr, Instruction instr) -> NcgImpl statics instr jumpDest -> UniqSupply -> [RawCmmDecl] - -> NativeGenState statics instr - -> Int - -> IO (NativeGenAcc statics instr, UniqSupply) + -> [NativeGenState statics instr] + -> IO ([NativeGenState statics instr], UniqSupply) + +cmmNativeGens _ _ us _ [] = return ([], us) +cmmNativeGens dflags ncgImpl us cmms (ngs : ngss) + = do (ngs', us') <- cmmNativeGens' dflags ncgImpl us cmms ngs 0 + (ngss', us'') <- cmmNativeGens dflags ncgImpl us' cmms ngss + return (ngs' : ngss', us'') + +-- | Do native code generation on all these cmms. +-- +cmmNativeGens' :: (Outputable statics, Outputable instr, Instruction instr) + => DynFlags + -> NcgImpl statics instr jumpDest + -> UniqSupply + -> [RawCmmDecl] + -> NativeGenState statics instr + -> Int + -> IO (NativeGenState statics instr, UniqSupply) -cmmNativeGens _ _ us [] (_, nga) _ - = return (nga, us) +cmmNativeGens' _ _ us [] ngs _ + = return (ngs, us) -cmmNativeGens dflags ncgImpl us (cmm : cmms) (h, (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 @@ -365,7 +391,7 @@ cmmNativeGens dflags ncgImpl us (cmm : cmms) (h, (impAcc, profAcc)) count -- force evaulation all this stuff to avoid space leaks {-# SCC "seqString" #-} evaluate $ seqString (showSDoc dflags $ vcat $ map ppr imports) - cmmNativeGens dflags ncgImpl + cmmNativeGens' dflags ncgImpl us' cmms (h, ((imports : impAcc), ((lsPprNative, colorStats, linearStats) : profAcc))) _______________________________________________ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
