[commit: ghc] master: Add more plumbing to the nativeCodeGen (8685535)

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/8685535cfdfc68223162070c50d604072c3213b7

>---------------------------------------------------------------

commit 8685535cfdfc68223162070c50d604072c3213b7
Author: Ian Lynagh <[email protected]>
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)))