Refactor iface file generation:wip/osa1/backend_refactoring

This commit refactors interface file generation to allow information
from the later passed (NCG, STG) to be stored in interface files.

We achieve this by splitting interface file generation into two parts:
* Partial interfaces, built based on the result of the core pipeline
* A fully instantiated interface, which also contains the final
fingerprints and can optionally contain information produced by the backend.

This change is required by !1304 and !1530.

-dynamic-too handling is refactored too: previously when generating code
we'd branch on -dynamic-too *before* code generation, but now we do it
after.

(Original code written by @AndreasK in !1530)

Performance
~~~~~~~~~~~

Before this patch interface files where created and immediately flushed
to disk which made space leaks impossible.
With this change we instead use NFData to force all iface related data
structures to avoid space leaks.

In the process of refactoring it was discovered that the code in the
ToIface Module allocated a lot of thunks which were immediately forced
when writing/forcing the interface file. So we made this module more
strict to avoid creating many of those thunks.

Bottom line is that allocations go down by about ~0.1% compared to
master.
Residency is not meaningfully different after this patch.
Runtime was not benchmarked.

Co-Authored-By: Andreas Klebinger <klebinger.andreas@gmx.at>
Co-Authored-By: Ömer Sinan Ağacan <omer@well-typed.com>

1 files changed, 69 insertions, 28 deletions

diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs
index 03a55aef02..0dc75e1ecc 100644
--- a/compiler/main/DriverPipeline.hs
+++ b/compiler/main/DriverPipeline.hs
@@ -77,6 +77,7 @@ import Data.List        ( isInfixOf, intercalate )
 import Data.Maybe
 import Data.Version
 import Data.Either      ( partitionEithers )
+import Data.IORef
 
 import Data.Time        ( UTCTime )
 
@@ -156,11 +157,15 @@ compileOne' m_tc_result mHscMessage
 
    debugTraceMsg dflags1 2 (text "compile: input file" <+> text input_fnpp)
 
-   (status, hmi0) <- hscIncrementalCompile
+   -- Run the pipeline up to codeGen (so everything up to, but not including, STG)
+   (status, hmi_details, m_iface) <- hscIncrementalCompile
                         always_do_basic_recompilation_check
                         m_tc_result mHscMessage
                         hsc_env summary source_modified mb_old_iface (mod_index, nmods)
 
+   -- Build HMI from the results of the Core pipeline.
+   let coreHmi m_linkable = HomeModInfo (expectIface m_iface) hmi_details m_linkable
+
    let flags = hsc_dflags hsc_env0
      in do unless (gopt Opt_KeepHiFiles flags) $
                addFilesToClean flags TFL_CurrentModule $
@@ -173,23 +178,23 @@ compileOne' m_tc_result mHscMessage
         (HscUpToDate, _) ->
             -- TODO recomp014 triggers this assert. What's going on?!
             -- ASSERT( isJust maybe_old_linkable || isNoLink (ghcLink dflags) )
-            return hmi0 { hm_linkable = maybe_old_linkable }
+            return $! coreHmi maybe_old_linkable
         (HscNotGeneratingCode, HscNothing) ->
             let mb_linkable = if isHsBootOrSig src_flavour
                                 then Nothing
                                 -- TODO: Questionable.
                                 else Just (LM (ms_hs_date summary) this_mod [])
-            in return hmi0 { hm_linkable = mb_linkable }
+            in return $! coreHmi mb_linkable
         (HscNotGeneratingCode, _) -> panic "compileOne HscNotGeneratingCode"
         (_, HscNothing) -> panic "compileOne HscNothing"
         (HscUpdateBoot, HscInterpreted) -> do
-            return hmi0
+            return $! coreHmi Nothing
         (HscUpdateBoot, _) -> do
             touchObjectFile dflags object_filename
-            return hmi0
+            return $! coreHmi Nothing
         (HscUpdateSig, HscInterpreted) ->
-            let linkable = LM (ms_hs_date summary) this_mod []
-            in return hmi0 { hm_linkable = Just linkable }
+            let !linkable = LM (ms_hs_date summary) this_mod []
+            in return $! coreHmi (Just linkable)
         (HscUpdateSig, _) -> do
             output_fn <- getOutputFilename next_phase
                             (Temporary TFL_CurrentModule) basename dflags
@@ -208,9 +213,16 @@ compileOne' m_tc_result mHscMessage
                               (Just location)
                               []
             o_time <- getModificationUTCTime object_filename
-            let linkable = LM o_time this_mod [DotO object_filename]
-            return hmi0 { hm_linkable = Just linkable }
-        (HscRecomp cgguts summary, HscInterpreted) -> do
+            let !linkable = LM o_time this_mod [DotO object_filename]
+            return $! coreHmi $ Just linkable
+        (HscRecomp cgguts summary iface_gen, HscInterpreted) -> do
+            -- In interpreted mode the regular codeGen backend is not run
+            -- so we generate a interface without codeGen info.
+            (iface, no_change) <- iface_gen
+            -- If we interpret the code, then we can write the interface file here.
+            liftIO $ hscMaybeWriteIface dflags iface no_change
+                                (ms_location summary)
+
             (hasStub, comp_bc, spt_entries) <-
                 hscInteractive hsc_env cgguts summary
 
@@ -228,29 +240,44 @@ compileOne' m_tc_result mHscMessage
               -- with the filesystem's clock.  It's just as accurate:
               -- if the source is modified, then the linkable will
               -- be out of date.
-            let linkable = LM unlinked_time (ms_mod summary)
+            let !linkable = LM unlinked_time (ms_mod summary)
                            (hs_unlinked ++ stub_o)
-            return hmi0 { hm_linkable = Just linkable }
-        (HscRecomp cgguts summary, _) -> do
+            return $! HomeModInfo iface hmi_details (Just linkable)
+        (HscRecomp cgguts summary iface_gen, _) -> do
             output_fn <- getOutputFilename next_phase
                             (Temporary TFL_CurrentModule)
                             basename dflags next_phase (Just location)
             -- We're in --make mode: finish the compilation pipeline.
+
+            -- We use this IORef the get out the iface from the otherwise
+            -- opaque pipeline once it's created. Otherwise we would have
+            -- to thread it through runPipeline.
+            if_ref <- newIORef Nothing :: IO (IORef (Maybe ModIface))
+            let iface_gen' = do
+                    res@(iface, _no_change) <- iface_gen
+                    writeIORef if_ref $ Just iface
+                    return res
+
             _ <- runPipeline StopLn hsc_env
                               (output_fn,
                                Nothing,
-                               Just (HscOut src_flavour mod_name (HscRecomp cgguts summary)))
+                               Just (HscOut src_flavour mod_name
+                                        (HscRecomp cgguts summary iface_gen')))
                               (Just basename)
                               Persistent
                               (Just location)
                               []
+            iface <- (expectJust "Iface callback") <$> readIORef if_ref
                   -- The object filename comes from the ModLocation
             o_time <- getModificationUTCTime object_filename
-            let linkable = LM o_time this_mod [DotO object_filename]
-            return hmi0 { hm_linkable = Just linkable }
+            let !linkable = LM o_time this_mod [DotO object_filename]
+            return $! HomeModInfo iface hmi_details (Just linkable)
 
  where dflags0     = ms_hspp_opts summary
 
+       expectIface :: Maybe ModIface -> ModIface
+       expectIface = expectJust "compileOne': Interface expected "
+
        this_mod    = ms_mod summary
        location    = ms_location summary
        input_fn    = expectJust "compile:hs" (ml_hs_file location)
@@ -735,17 +762,22 @@ pipeLoop phase input_fn = do
      -> do liftIO $ debugTraceMsg dflags 4
                                   (text "Running phase" <+> ppr phase)
            (next_phase, output_fn) <- runHookedPhase phase input_fn dflags
-           r <- pipeLoop next_phase output_fn
            case phase of
-               HscOut {} ->
-                   whenGeneratingDynamicToo dflags $ do
-                       setDynFlags $ dynamicTooMkDynamicDynFlags dflags
-                       -- TODO shouldn't ignore result:
-                       _ <- pipeLoop phase input_fn
-                       return ()
-               _ ->
-                   return ()
-           return r
+               HscOut {} -> do
+                   -- We don't pass Opt_BuildDynamicToo to the backend
+                   -- in DynFlags.
+                   -- Instead it's run twice with flags accordingly set
+                   -- per run.
+                   let noDynToo = pipeLoop next_phase output_fn
+                   let dynToo = do
+                          setDynFlags $ gopt_unset dflags Opt_BuildDynamicToo
+                          r <- pipeLoop next_phase output_fn
+                          setDynFlags $ dynamicTooMkDynamicDynFlags dflags
+                          -- TODO shouldn't ignore result:
+                          _ <- pipeLoop phase input_fn
+                          return r
+                   ifGeneratingDynamicToo dflags dynToo noDynToo
+               _ -> pipeLoop next_phase output_fn
 
 runHookedPhase :: PhasePlus -> FilePath -> DynFlags
                -> CompPipeline (PhasePlus, FilePath)
@@ -1112,7 +1144,7 @@ runPhase (RealPhase (Hsc src_flavour)) input_fn dflags0
 
   -- run the compiler!
         let msg hsc_env _ what _ = oneShotMsg hsc_env what
-        (result, _) <- liftIO $ hscIncrementalCompile True Nothing (Just msg) hsc_env'
+        (result, _, _) <- liftIO $ hscIncrementalCompile True Nothing (Just msg) hsc_env'
                             mod_summary source_unchanged Nothing (1,1)
 
         return (HscOut src_flavour mod_name result,
@@ -1149,13 +1181,22 @@ runPhase (HscOut src_flavour mod_name result) _ dflags = do
                        basename = dropExtension input_fn
                    liftIO $ compileEmptyStub dflags hsc_env' basename location mod_name
                    return (RealPhase StopLn, o_file)
-            HscRecomp cgguts mod_summary
+            HscRecomp cgguts mod_summary iface_gen
               -> do output_fn <- phaseOutputFilename next_phase
 
                     PipeState{hsc_env=hsc_env'} <- getPipeState
 
                     (outputFilename, mStub, foreign_files) <- liftIO $
                       hscGenHardCode hsc_env' cgguts mod_summary output_fn
+
+
+                    (iface, no_change) <- liftIO iface_gen
+
+                    -- See Note [Writing interface files]
+                    let if_dflags = dflags `gopt_unset` Opt_BuildDynamicToo
+                    liftIO $ hscMaybeWriteIface if_dflags iface no_change
+                                                    (ms_location mod_summary)
+
                     stub_o <- liftIO (mapM (compileStub hsc_env') mStub)
                     foreign_os <- liftIO $
                       mapM (uncurry (compileForeign hsc_env')) foreign_files