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.

compiler/iface/LoadIface.lhs

@@ -558,22 +558,20 @@ findAndReadIface doc_str mod hi_boot_file
                             -- Don't forget to fill in the package name...
           checkBuildDynamicToo (Succeeded (iface, filePath)) = do
               dflags <- getDynFlags
-              when (gopt Opt_BuildDynamicToo dflags) $ do
+              whenGeneratingDynamicToo dflags $ withDoDynamicToo $ do
                   let ref = canGenerateDynamicToo dflags
-                  b <- liftIO $ readIORef ref
-                  when b $ withDoDynamicToo $ do
-                      let dynFilePath = replaceExtension filePath (dynHiSuf dflags)
-                      r <- read_file dynFilePath
-                      case r of
-                          Succeeded (dynIface, _)
-                           | mi_mod_hash iface == mi_mod_hash dynIface ->
-                              return ()
-                           | otherwise ->
-                              do traceIf (text "Dynamic hash doesn't match")
-                                 liftIO $ writeIORef ref False
-                          Failed err ->
-                              do traceIf (text "Failed to load dynamic interface file:" $$ err)
-                                 liftIO $ writeIORef ref False
+                      dynFilePath = replaceExtension filePath (dynHiSuf dflags)
+                  r <- read_file dynFilePath
+                  case r of
+                      Succeeded (dynIface, _)
+                       | mi_mod_hash iface == mi_mod_hash dynIface ->
+                          return ()
+                       | otherwise ->
+                          do traceIf (text "Dynamic hash doesn't match")
+                             liftIO $ writeIORef ref False
+                      Failed err ->
+                          do traceIf (text "Failed to load dynamic interface file:" $$ err)
+                             liftIO $ writeIORef ref False
           checkBuildDynamicToo _ = return ()
 \end{code}
 

compiler/iface/MkIface.lhs

@@ -387,11 +387,10 @@ mkIface_ hsc_env maybe_old_fingerprint
        } 
 
 -----------------------------
-writeIfaceFile :: DynFlags -> ModLocation -> ModIface -> IO ()
-writeIfaceFile dflags location new_iface
+writeIfaceFile :: DynFlags -> FilePath -> ModIface -> IO ()
+writeIfaceFile dflags hi_file_path new_iface
     = do createDirectoryIfMissing True (takeDirectory hi_file_path)
          writeBinIface dflags hi_file_path new_iface
-    where hi_file_path = ml_hi_file location
 
 
 -- -----------------------------------------------------------------------------

compiler/main/CodeOutput.lhs

@@ -144,9 +144,17 @@ outputAsm dflags filenm cmm_stream
  | cGhcWithNativeCodeGen == "YES"
   = do ncg_uniqs <- mkSplitUniqSupply 'n'
 
-       _ <- {-# SCC "OutputAsm" #-} doOutput filenm $
-           \f -> {-# SCC "NativeCodeGen" #-}
-                 nativeCodeGen dflags f ncg_uniqs cmm_stream
+       let filenmDyn = filenm ++ "-dyn"
+           withHandles f = doOutput filenm $ \h ->
+                           ifGeneratingDynamicToo dflags
+                               (doOutput filenmDyn $ \dynH ->
+                                   f [(h, dflags),
+                                      (dynH, doDynamicToo dflags)])
+                               (f [(h, dflags)])
+
+       _ <- {-# SCC "OutputAsm" #-} withHandles $
+           \hs -> {-# SCC "NativeCodeGen" #-}
+                 nativeCodeGen dflags hs ncg_uniqs cmm_stream
        return ()
 
  | otherwise

compiler/main/DriverPipeline.hs

@@ -1203,7 +1203,8 @@ runPhase As input_fn dflags
         -- might be a hierarchical module.
         liftIO $ createDirectoryIfMissing True (takeDirectory output_fn)
 
-        liftIO $ as_prog dflags
+        let runAssembler inputFilename outputFilename
+                = liftIO $ as_prog dflags
                        (map SysTools.Option as_opts
                        ++ [ SysTools.Option ("-I" ++ p) | p <- cmdline_include_paths ]
 
@@ -1218,12 +1219,18 @@ runPhase As input_fn dflags
                            then [SysTools.Option "-mcpu=v9"]
                            else [])
 
-                       ++ [ SysTools.Option "-c"
-                          , SysTools.FileOption "" input_fn
+                       ++ [ SysTools.Option "-x", SysTools.Option "assembler"
+                          , SysTools.Option "-c"
+                          , SysTools.FileOption "" inputFilename
                           , SysTools.Option "-o"
-                          , SysTools.FileOption "" output_fn
+                          , SysTools.FileOption "" outputFilename
                           ])
 
+        runAssembler input_fn output_fn
+        whenGeneratingDynamicToo dflags $
+            runAssembler (input_fn ++ "-dyn")
+                         (replaceExtension output_fn (dynObjectSuf dflags))
+
         return (next_phase, output_fn)
 
 

compiler/main/DynFlags.hs

@@ -27,7 +27,7 @@ module DynFlags (
         wopt, wopt_set, wopt_unset,
         xopt, xopt_set, xopt_unset,
         lang_set,
-        doDynamicToo,
+        whenGeneratingDynamicToo, ifGeneratingDynamicToo, doDynamicToo,
         DynFlags(..),
         HasDynFlags(..), ContainsDynFlags(..),
         RtsOptsEnabled(..),
@@ -1112,6 +1112,17 @@ wayOptP _ WayPar      = ["-D__PARALLEL_HASKELL__"]
 wayOptP _ WayGran     = ["-D__GRANSIM__"]
 wayOptP _ WayNDP      = []
 
+whenGeneratingDynamicToo :: MonadIO m => DynFlags -> m () -> m ()
+whenGeneratingDynamicToo dflags f = ifGeneratingDynamicToo dflags f (return ())
+
+ifGeneratingDynamicToo :: MonadIO m => DynFlags -> m a -> m a -> m a
+ifGeneratingDynamicToo dflags f g
+    = if gopt Opt_BuildDynamicToo dflags
+      then do let ref = canGenerateDynamicToo dflags
+              b <- liftIO $ readIORef ref
+              if b then f else g
+      else g
+
 doDynamicToo :: DynFlags -> DynFlags
 doDynamicToo dflags0 = let dflags1 = unSetGeneralFlag' Opt_Static dflags0
                            dflags2 = addWay' WayDyn dflags1

compiler/main/HscMain.hs

@@ -1242,9 +1242,16 @@ hscNormalIface simpl_result mb_old_iface = do
 hscWriteIface :: ModIface -> Bool -> ModSummary -> Hsc ()
 hscWriteIface iface no_change mod_summary = do
     dflags <- getDynFlags
+    let ifaceFile = ml_hi_file (ms_location mod_summary)
     unless no_change $
         {-# SCC "writeIface" #-}
-        liftIO $ writeIfaceFile dflags (ms_location mod_summary) iface
+        liftIO $ writeIfaceFile dflags ifaceFile iface
+    whenGeneratingDynamicToo dflags $ liftIO $ do
+        -- TODO: We should do a no_change check for the dynamic
+        --       interface file too
+        let dynIfaceFile = replaceExtension ifaceFile (dynHiSuf dflags)
+            dynDflags = doDynamicToo dflags
+        writeIfaceFile dynDflags dynIfaceFile iface
 
 -- | Compile to hard-code.
 hscGenHardCode :: CgGuts -> ModSummary

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'