Implement the -dynamic-too optimised path for the NCG

We don't yet have the slow path, for when we have to fall back to
separate compilation.

We also only currently handle the case qhere we're compiling Haskell
code with the NCG.

1 files changed, 32 insertions, 32 deletions

diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs
index ce62a64cec..05f7c3a06b 100644
--- a/compiler/nativeGen/AsmCodeGen.lhs
+++ b/compiler/nativeGen/AsmCodeGen.lhs
@@ -152,12 +152,12 @@ data NcgImpl statics instr jumpDest = NcgImpl {
     }
 
 --------------------
-nativeCodeGen :: DynFlags -> Handle -> UniqSupply -> Stream IO RawCmmGroup ()
+nativeCodeGen :: DynFlags -> [(Handle, DynFlags)] -> UniqSupply -> Stream IO RawCmmGroup ()
               -> IO UniqSupply
-nativeCodeGen dflags h us cmms
+nativeCodeGen dflags hds us cmms
  = let platform = targetPlatform dflags
        nCG' :: (Outputable statics, Outputable instr, Instruction instr) => NcgImpl statics instr jumpDest -> IO UniqSupply
-       nCG' ncgImpl = nativeCodeGen' dflags ncgImpl h us cmms
+       nCG' ncgImpl = nativeCodeGen' dflags ncgImpl hds us cmms
        x86NcgImpl = NcgImpl {
                          cmmTopCodeGen             = X86.CodeGen.cmmTopCodeGen
                         ,generateJumpTableForInstr = X86.CodeGen.generateJumpTableForInstr dflags
@@ -238,7 +238,7 @@ noAllocMoreStack amount _
         ++  "   You can still file a bug report if you like.\n"
 
 
-type NativeGenState statics instr = (BufHandle, NativeGenAcc statics instr)
+type NativeGenState statics instr = (BufHandle, DynFlags, NativeGenAcc statics instr)
 type NativeGenAcc statics instr
         = ([[CLabel]],
            [([NatCmmDecl statics instr],
@@ -248,17 +248,21 @@ type NativeGenAcc statics instr
 nativeCodeGen' :: (Outputable statics, Outputable instr, Instruction instr)
                => DynFlags
                -> NcgImpl statics instr jumpDest
-               -> Handle -> UniqSupply -> Stream IO RawCmmGroup () -> IO UniqSupply
-nativeCodeGen' dflags ncgImpl h us cmms
+               -> [(Handle, DynFlags)]
+               -> UniqSupply
+               -> Stream IO RawCmmGroup ()
+               -> IO UniqSupply
+nativeCodeGen' dflags ncgImpl hds us cmms
  = do
         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
-        let ngss = [(bufh, ([], []))]
-        (ngss', us') <- cmmNativeGenStream dflags ncgImpl us split_cmms ngss
-        mapM_ (finishNativeGen dflags ncgImpl) ngss'
+        let mkNgs (h, dflags) = do bufh <- newBufHandle h
+                                   return (bufh, dflags, ([], []))
+        ngss <- mapM mkNgs hds
+        (ngss', us') <- cmmNativeGenStream ncgImpl us split_cmms ngss
+        mapM_ (finishNativeGen ncgImpl) ngss'
 
         return us'
 
@@ -271,11 +275,10 @@ nativeCodeGen' dflags ncgImpl h us cmms
 
 
 finishNativeGen :: Instruction instr
-                => DynFlags
-                -> NcgImpl statics instr jumpDest
+                => NcgImpl statics instr jumpDest
                 -> NativeGenState statics instr
                 -> IO ()
-finishNativeGen dflags ncgImpl (bufh@(BufHandle _ _ h), (imports, prof))
+finishNativeGen ncgImpl (bufh@(BufHandle _ _ h), dflags, (imports, prof))
  = do
         bFlush bufh
 
@@ -323,55 +326,52 @@ finishNativeGen dflags ncgImpl (bufh@(BufHandle _ _ h), (imports, prof))
                 $ makeImportsDoc dflags (concat imports)
 
 cmmNativeGenStream :: (Outputable statics, Outputable instr, Instruction instr)
-              => DynFlags
-              -> NcgImpl statics instr jumpDest
+              => NcgImpl statics instr jumpDest
               -> UniqSupply
               -> Stream IO RawCmmGroup ()
               -> [NativeGenState statics instr]
               -> IO ([NativeGenState statics instr], UniqSupply)
 
-cmmNativeGenStream dflags ncgImpl us cmm_stream ngss
+cmmNativeGenStream ncgImpl us cmm_stream ngss
  = do r <- Stream.runStream cmm_stream
       case r of
           Left () ->
-              return ([ (h, (reverse impAcc, reverse profAcc))
-                      | (h, (impAcc, profAcc)) <- ngss ]
+              return ([ (h, dflags, (reverse impAcc, reverse profAcc))
+                      | (h, dflags, (impAcc, profAcc)) <- ngss ]
                      , us)
           Right (cmms, cmm_stream') -> do
-              (ngss',us') <- cmmNativeGens dflags ncgImpl us cmms ngss
-              cmmNativeGenStream dflags ncgImpl us' cmm_stream' ngss'
+              (ngss',us') <- cmmNativeGens ncgImpl us cmms ngss
+              cmmNativeGenStream ncgImpl us' cmm_stream' ngss'
 
 -- | Do native code generation on all these cmms.
 --
 cmmNativeGens :: (Outputable statics, Outputable instr, Instruction instr)
-              => DynFlags
-              -> NcgImpl statics instr jumpDest
+              => NcgImpl statics instr jumpDest
               -> UniqSupply
               -> [RawCmmDecl]
               -> [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
+cmmNativeGens _       us _    [] = return ([], us)
+cmmNativeGens ncgImpl us cmms (ngs : ngss)
+ = do (ngs', us') <- cmmNativeGens' ncgImpl us cmms ngs 0
+      (ngss', us'') <- cmmNativeGens 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
+               => NcgImpl statics instr jumpDest
                -> UniqSupply
                -> [RawCmmDecl]
                -> NativeGenState statics instr
                -> Int
                -> IO (NativeGenState statics instr, UniqSupply)
 
-cmmNativeGens' _ _ us [] ngs _
+cmmNativeGens' _ us [] ngs _
         = return (ngs, us)
 
-cmmNativeGens' dflags ncgImpl us (cmm : cmms) (h, (impAcc, profAcc)) count
+cmmNativeGens' ncgImpl us (cmm : cmms) (h, dflags, (impAcc, profAcc)) count
  = do
         (us', native, imports, colorStats, linearStats)
                 <- {-# SCC "cmmNativeGen" #-} cmmNativeGen dflags ncgImpl us cmm count
@@ -391,8 +391,8 @@ 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
-            us' cmms (h,
+        cmmNativeGens' ncgImpl
+            us' cmms (h, dflags,
                       ((imports : impAcc),
                        ((lsPprNative, colorStats, linearStats) : profAcc)))
                      count'