Split the Hsc phase into two subphases
authorIan Lynagh <ian@well-typed.com>
Fri, 8 Mar 2013 01:52:25 +0000 (01:52 +0000)
committerIan Lynagh <ian@well-typed.com>
Sat, 9 Mar 2013 15:39:24 +0000 (15:39 +0000)
The goal is that the second subphase will be run twice when using
-dynamic-too

compiler/main/DriverPipeline.hs
compiler/main/HscMain.hs

index 5bd0694..08f1b98 100644 (file)
@@ -609,7 +609,7 @@ runPipeline' start_phase hsc_env env input_fn
   -- Execute the pipeline...
   let state = PipeState{ hsc_env, maybe_loc, maybe_stub_o = maybe_stub_o }
 
-  evalP (pipeLoop start_phase input_fn) env state
+  evalP (pipeLoop (RealPhase start_phase) input_fn) env state
 
 -- -----------------------------------------------------------------------------
 -- The pipeline uses a monad to carry around various bits of information
@@ -685,14 +685,14 @@ phaseOutputFilename next_phase = do
 -- outer pipeline loop
 
 -- | pipeLoop runs phases until we reach the stop phase
-pipeLoop :: Phase -> FilePath -> CompPipeline (DynFlags, FilePath)
+pipeLoop :: PhasePlus -> FilePath -> CompPipeline (DynFlags, FilePath)
 pipeLoop phase input_fn = do
   env <- getPipeEnv
   dflags <- getDynFlags
   let happensBefore' = happensBefore dflags
       stopPhase = stop_phase env
-  case () of
-   _ | phase `eqPhase` stopPhase            -- All done
+  case phase of
+   RealPhase realPhase | realPhase `eqPhase` stopPhase            -- All done
      -> -- Sometimes, a compilation phase doesn't actually generate any output
         -- (eg. the CPP phase when -fcpp is not turned on).  If we end on this
         -- stage, but we wanted to keep the output, then we have to explicitly
@@ -713,15 +713,15 @@ pipeLoop phase input_fn = do
                return (dflags, final_fn)
 
 
-     | not (phase `happensBefore'` stopPhase)
+     | not (realPhase `happensBefore'` stopPhase)
         -- Something has gone wrong.  We'll try to cover all the cases when
         -- this could happen, so if we reach here it is a panic.
         -- eg. it might happen if the -C flag is used on a source file that
         -- has {-# OPTIONS -fasm #-}.
-     -> panic ("pipeLoop: at phase " ++ show phase ++
+     -> panic ("pipeLoop: at phase " ++ show realPhase ++
            " but I wanted to stop at phase " ++ show stopPhase)
 
-     | otherwise
+   _
      -> do liftIO $ debugTraceMsg dflags 4
                                   (ptext (sLit "Running phase") <+> ppr phase)
            (next_phase, output_fn) <- runPhase phase input_fn dflags
@@ -777,6 +777,12 @@ getOutputFilename stop_phase output basename dflags next_phase maybe_location
              | Just d <- odir = d </> persistent
              | otherwise      = persistent
 
+data PhasePlus = RealPhase Phase
+               | HscOut HscSource ModuleName HscStatus
+
+instance Outputable PhasePlus where
+    ppr (RealPhase p) = ppr p
+    ppr (HscOut {}) = text "HscOut"
 
 -- -----------------------------------------------------------------------------
 -- | Each phase in the pipeline returns the next phase to execute, and the
@@ -788,10 +794,10 @@ getOutputFilename stop_phase output basename dflags next_phase maybe_location
 -- of a source file can change the latter stages of the pipeline from
 -- taking the via-C route to using the native code generator.
 --
-runPhase :: Phase       -- ^ Run this phase
+runPhase :: PhasePlus   -- ^ Run this phase
          -> FilePath    -- ^ name of the input file
          -> DynFlags    -- ^ for convenience, we pass the current dflags in
-         -> CompPipeline (Phase,               -- next phase to run
+         -> CompPipeline (PhasePlus,           -- next phase to run
                           FilePath)            -- output filename
 
         -- Invariant: the output filename always contains the output
@@ -802,7 +808,7 @@ runPhase :: Phase       -- ^ Run this phase
 -------------------------------------------------------------------------------
 -- Unlit phase
 
-runPhase (Unlit sf) input_fn dflags
+runPhase (RealPhase (Unlit sf)) input_fn dflags
   = do
        output_fn <- phaseOutputFilename (Cpp sf)
 
@@ -818,7 +824,7 @@ runPhase (Unlit sf) input_fn dflags
 
        liftIO $ SysTools.runUnlit dflags flags
 
-       return (Cpp sf, output_fn)
+       return (RealPhase (Cpp sf), output_fn)
   where
        -- escape the characters \, ", and ', but don't try to escape
        -- Unicode or anything else (so we don't use Util.charToC
@@ -837,7 +843,7 @@ runPhase (Unlit sf) input_fn dflags
 -- Cpp phase : (a) gets OPTIONS out of file
 --             (b) runs cpp if necessary
 
-runPhase (Cpp sf) input_fn dflags0
+runPhase (RealPhase (Cpp sf)) input_fn dflags0
   = do
        src_opts <- liftIO $ getOptionsFromFile dflags0 input_fn
        (dflags1, unhandled_flags, warns)
@@ -852,7 +858,7 @@ runPhase (Cpp sf) input_fn dflags0
 
            -- no need to preprocess CPP, just pass input file along
            -- to the next phase of the pipeline.
-           return (HsPp sf, input_fn)
+           return (RealPhase (HsPp sf), input_fn)
         else do
             output_fn <- phaseOutputFilename (HsPp sf)
             liftIO $ doCpp dflags1 True{-raw-} False{-no CC opts-}
@@ -869,17 +875,17 @@ runPhase (Cpp sf) input_fn dflags0
 
             setDynFlags dflags2
 
-            return (HsPp sf, output_fn)
+            return (RealPhase (HsPp sf), output_fn)
 
 -------------------------------------------------------------------------------
 -- HsPp phase
 
-runPhase (HsPp sf) input_fn dflags
+runPhase (RealPhase (HsPp sf)) input_fn dflags
   = do
        if not (gopt Opt_Pp dflags) then
            -- no need to preprocess, just pass input file along
            -- to the next phase of the pipeline.
-          return (Hsc sf, input_fn)
+          return (RealPhase (Hsc sf), input_fn)
         else do
             let hspp_opts = getOpts dflags opt_F
             PipeEnv{src_basename, src_suffix} <- getPipeEnv
@@ -901,14 +907,14 @@ runPhase (HsPp sf) input_fn dflags
             liftIO $ checkProcessArgsResult dflags1 unhandled_flags
             liftIO $ handleFlagWarnings dflags1 warns
 
-            return (Hsc sf, output_fn)
+            return (RealPhase (Hsc sf), output_fn)
 
 -----------------------------------------------------------------------------
 -- Hsc phase
 
 -- Compilation of a single module, in "legacy" mode (_not_ under
 -- the direction of the compilation manager).
-runPhase (Hsc src_flavour) input_fn dflags0
+runPhase (RealPhase (Hsc src_flavour)) input_fn dflags0
  = do   -- normal Hsc mode, not mkdependHS
 
         PipeEnv{ stop_phase=stop,
@@ -936,40 +942,16 @@ runPhase (Hsc src_flavour) input_fn dflags0
                     (src_imps,imps,L _ mod_name) <- getImports dflags buf input_fn (basename <.> suff)
                     return (Just buf, mod_name, imps, src_imps)
 
-  -- Build a ModLocation to pass to hscMain.
-  -- The source filename is rather irrelevant by now, but it's used
-  -- by hscMain for messages.  hscMain also needs
-  -- the .hi and .o filenames, and this is as good a way
-  -- as any to generate them, and better than most. (e.g. takes
-  -- into accout the -osuf flags)
-        location1 <- liftIO $ mkHomeModLocation2 dflags mod_name basename suff
-
-  -- Boot-ify it if necessary
-        let location2 | isHsBoot src_flavour = addBootSuffixLocn location1
-                      | otherwise            = location1
-
-
-  -- Take -ohi into account if present
-  -- This can't be done in mkHomeModuleLocation because
-  -- it only applies to the module being compiles
-        let ohi = outputHi dflags
-            location3 | Just fn <- ohi = location2{ ml_hi_file = fn }
-                      | otherwise      = location2
-
   -- Take -o into account if present
   -- Very like -ohi, but we must *only* do this if we aren't linking
   -- (If we're linking then the -o applies to the linked thing, not to
   -- the object file for one module.)
   -- Note the nasty duplication with the same computation in compileFile above
-        let expl_o_file = outputFile dflags
-            location4 | Just ofile <- expl_o_file
-                      , isNoLink (ghcLink dflags)
-                      = location3 { ml_obj_file = ofile }
-                      | otherwise = location3
+        location <- getLocation src_flavour mod_name
 
-            o_file = ml_obj_file location4      -- The real object file
+        let o_file = ml_obj_file location -- The real object file
 
-        setModLocation location4
+        setModLocation location
 
   -- Figure out if the source has changed, for recompilation avoidance.
   --
@@ -980,7 +962,6 @@ runPhase (Hsc src_flavour) input_fn dflags0
   -- date wrt M.hs (or M.o doesn't exist) so we must recompile regardless.
         src_timestamp <- liftIO $ getModificationUTCTime (basename <.> suff)
 
-        let hsc_lang = hscTarget dflags
         source_unchanged <- liftIO $
           if not (isStopLn stop)
                 -- SourceModified unconditionally if
@@ -996,18 +977,13 @@ runPhase (Hsc src_flavour) input_fn dflags0
                                   then return SourceUnmodified
                                   else return SourceModified
 
-  -- get the DynFlags
-        let next_phase = hscPostBackendPhase dflags src_flavour hsc_lang
-        output_fn  <- phaseOutputFilename next_phase
-
-        let dflags' = dflags { hscOutName = output_fn,
-                               extCoreName = basename ++ ".hcr" }
+        let dflags' = dflags { extCoreName = basename ++ ".hcr" }
 
         setDynFlags dflags'
         PipeState{hsc_env=hsc_env'} <- getPipeState
 
   -- Tell the finder cache about this module
-        mod <- liftIO $ addHomeModuleToFinder hsc_env' mod_name location4
+        mod <- liftIO $ addHomeModuleToFinder hsc_env' mod_name location
 
   -- Make the ModSummary to hand to hscMain
         let
@@ -1016,7 +992,7 @@ runPhase (Hsc src_flavour) input_fn dflags0
                                         ms_hspp_file = input_fn,
                                         ms_hspp_opts = dflags,
                                         ms_hspp_buf  = hspp_buf,
-                                        ms_location  = location4,
+                                        ms_location  = location,
                                         ms_hs_date   = src_timestamp,
                                         ms_obj_date  = Nothing,
                                         ms_textual_imps = imps,
@@ -1026,44 +1002,60 @@ runPhase (Hsc src_flavour) input_fn dflags0
         result <- liftIO $ hscCompileOneShot hsc_env'
                                mod_summary source_unchanged
 
+        return (HscOut src_flavour mod_name result,
+                panic "HscOut doesn't have an input filename")
+
+runPhase (HscOut src_flavour mod_name result) _ dflags = do
+        location <- getLocation src_flavour mod_name
+        let o_file = ml_obj_file location -- The real object file
+            hsc_lang = hscTarget dflags
+            next_phase = hscPostBackendPhase dflags src_flavour hsc_lang
+
         case result of
             HscNotGeneratingCode ->
-                return (next_phase,
+                return (RealPhase next_phase,
                         panic "No output filename from Hsc when no-code")
             HscUpToDate ->
-                do liftIO $ touchObjectFile dflags' o_file
+                do liftIO $ touchObjectFile dflags o_file
                    -- The .o file must have a later modification date
                    -- than the source file (else we wouldn't get Nothing)
                    -- but we touch it anyway, to keep 'make' happy (we think).
-                   return (StopLn, o_file)
+                   return (RealPhase StopLn, o_file)
             HscUpdateBoot ->
                 do -- In the case of hs-boot files, generate a dummy .o-boot
                    -- stamp file for the benefit of Make
-                   liftIO $ touchObjectFile dflags' o_file
-                   whenGeneratingDynamicToo dflags' $ do
-                       let dyn_o_file = addBootSuffix (replaceExtension o_file (dynObjectSuf dflags'))
-                       liftIO $ touchObjectFile dflags' dyn_o_file
-                   return (next_phase, o_file)
-            HscRecomp outputFilename mStub
-              -> do case mStub of
+                   liftIO $ touchObjectFile dflags o_file
+                   whenGeneratingDynamicToo dflags $ do
+                       let dyn_o_file = addBootSuffix (replaceExtension o_file (dynObjectSuf dflags))
+                       liftIO $ touchObjectFile dflags dyn_o_file
+                   return (RealPhase next_phase, o_file)
+            HscRecomp cgguts mod_summary
+              -> do output_fn <- phaseOutputFilename next_phase
+
+                    let dflags' = dflags { hscOutName = output_fn }
+                    setDynFlags dflags'
+                    PipeState{hsc_env=hsc_env'} <- getPipeState
+
+                    (outputFilename, mStub) <- liftIO $ hscGenHardCode hsc_env' cgguts mod_summary
+                    case mStub of
                         Nothing -> return ()
                         Just stub_c ->
                             do stub_o <- liftIO $ compileStub hsc_env' stub_c
                                setStubO stub_o
 
-                    return (next_phase, outputFilename)
+                    return (RealPhase next_phase, outputFilename)
 
 -----------------------------------------------------------------------------
 -- Cmm phase
 
-runPhase CmmCpp input_fn dflags
+runPhase (RealPhase CmmCpp) input_fn dflags
   = do
        output_fn <- phaseOutputFilename Cmm
        liftIO $ doCpp dflags False{-not raw-} True{-include CC opts-}
                       input_fn output_fn
-       return (Cmm, output_fn)
+       return (RealPhase Cmm, output_fn)
 
-runPhase Cmm input_fn dflags
+runPhase (RealPhase Cmm) input_fn dflags
   = do
         PipeEnv{src_basename} <- getPipeEnv
         let hsc_lang = hscTarget dflags
@@ -1080,7 +1072,7 @@ runPhase Cmm input_fn dflags
 
         liftIO $ hscCompileCmmFile hsc_env input_fn
 
-        return (next_phase, output_fn)
+        return (RealPhase next_phase, output_fn)
 
 -----------------------------------------------------------------------------
 -- Cc phase
@@ -1088,7 +1080,7 @@ runPhase Cmm input_fn dflags
 -- we don't support preprocessing .c files (with -E) now.  Doing so introduces
 -- way too many hacks, and I can't say I've ever used it anyway.
 
-runPhase cc_phase input_fn dflags
+runPhase (RealPhase cc_phase) input_fn dflags
    | any (cc_phase `eqPhase`) [Cc, Ccpp, HCc, Cobjc, Cobjcpp]
    = do
         let platform = targetPlatform dflags
@@ -1212,12 +1204,12 @@ runPhase cc_phase input_fn dflags
                        ++ pkg_extra_cc_opts
                        ))
 
-        return (next_phase, output_fn)
+        return (RealPhase next_phase, output_fn)
 
 -----------------------------------------------------------------------------
 -- Splitting phase
 
-runPhase Splitter input_fn dflags
+runPhase (RealPhase Splitter) input_fn dflags
   = do  -- tmp_pfx is the prefix used for the split .s files
 
         split_s_prefix <- liftIO $ SysTools.newTempName dflags "split"
@@ -1241,14 +1233,14 @@ runPhase Splitter input_fn dflags
                                  [ split_s_prefix ++ "__" ++ show n ++ ".s"
                                  | n <- [1..n_files]]
 
-        return (SplitAs,
+        return (RealPhase SplitAs,
                 "**splitter**") -- we don't use the filename in SplitAs
 
 -----------------------------------------------------------------------------
 -- As, SpitAs phase : Assembler
 
 -- This is for calling the assembler on a regular assembly file (not split).
-runPhase As input_fn dflags
+runPhase (RealPhase As) input_fn dflags
   = do
         -- LLVM from version 3.0 onwards doesn't support the OS X system
         -- assembler, so we use clang as the assembler instead. (#5636)
@@ -1310,12 +1302,12 @@ runPhase As input_fn dflags
             runAssembler (input_fn ++ "-dyn")
                          (replaceExtension output_fn (dynObjectSuf dflags))
 
-        return (next_phase, output_fn)
+        return (RealPhase next_phase, output_fn)
 
 
 -- This is for calling the assembler on a split assembly file (so a collection
 -- of assembly files)
-runPhase SplitAs _input_fn dflags
+runPhase (RealPhase SplitAs) _input_fn dflags
   = do
         -- we'll handle the stub_o file in this phase, so don't MergeStub,
         -- just jump straight to StopLn afterwards.
@@ -1395,12 +1387,12 @@ runPhase SplitAs _input_fn dflags
         -- join them into a single .o file
         liftIO $ joinObjectFiles dflags (map split_obj [1..n]) output_fn
 
-        return (next_phase, output_fn)
+        return (RealPhase next_phase, output_fn)
 
 -----------------------------------------------------------------------------
 -- LlvmOpt phase
 
-runPhase LlvmOpt input_fn dflags
+runPhase (RealPhase LlvmOpt) input_fn dflags
   = do
     ver <- liftIO $ readIORef (llvmVersion dflags)
 
@@ -1428,7 +1420,7 @@ runPhase LlvmOpt input_fn dflags
                 ++ [SysTools.Option tbaa]
                 ++ map SysTools.Option lo_opts)
 
-    return (LlvmLlc, output_fn)
+    return (RealPhase LlvmLlc, output_fn)
   where 
         -- we always (unless -optlo specified) run Opt since we rely on it to
         -- fix up some pretty big deficiencies in the code we generate
@@ -1437,7 +1429,7 @@ runPhase LlvmOpt input_fn dflags
 -----------------------------------------------------------------------------
 -- LlvmLlc phase
 
-runPhase LlvmLlc input_fn dflags
+runPhase (RealPhase LlvmLlc) input_fn dflags
   = do
     ver <- liftIO $ readIORef (llvmVersion dflags)
 
@@ -1472,7 +1464,7 @@ runPhase LlvmLlc input_fn dflags
                 ++ map SysTools.Option abiOpts
                 ++ map SysTools.Option sseOpts)
 
-    return (next_phase, output_fn)
+    return (RealPhase next_phase, output_fn)
   where
         -- Bug in LLVM at O3 on OSX.
         llvmOpts = if platformOS (targetPlatform dflags) == OSDarwin
@@ -1506,17 +1498,17 @@ runPhase LlvmLlc input_fn dflags
 -----------------------------------------------------------------------------
 -- LlvmMangle phase
 
-runPhase LlvmMangle input_fn dflags
+runPhase (RealPhase LlvmMangle) input_fn dflags
   = do
       let next_phase = if gopt Opt_SplitObjs dflags then Splitter else As
       output_fn <- phaseOutputFilename next_phase
       liftIO $ llvmFixupAsm dflags input_fn output_fn
-      return (next_phase, output_fn)
+      return (RealPhase next_phase, output_fn)
 
 -----------------------------------------------------------------------------
 -- merge in stub objects
 
-runPhase MergeStub input_fn dflags
+runPhase (RealPhase MergeStub) input_fn dflags
  = do
      PipeState{maybe_stub_o} <- getPipeState
      output_fn <- phaseOutputFilename StopLn
@@ -1531,10 +1523,10 @@ runPhase MergeStub input_fn dflags
            let dyn_input_fn  = replaceExtension input_fn  (dynObjectSuf dflags)
                dyn_output_fn = replaceExtension output_fn (dynObjectSuf dflags)
            liftIO $ joinObjectFiles dflags [dyn_input_fn, stub_o] dyn_output_fn
-         return (StopLn, output_fn)
+         return (RealPhase StopLn, output_fn)
 
 -- warning suppression
-runPhase other _input_fn _dflags =
+runPhase (RealPhase other) _input_fn _dflags =
    panic ("runPhase: don't know how to run phase " ++ show other)
 
 maybeMergeStub :: CompPipeline Phase
@@ -1543,6 +1535,46 @@ maybeMergeStub
      PipeState{maybe_stub_o} <- getPipeState
      if isJust maybe_stub_o then return MergeStub else return StopLn
 
+getLocation :: HscSource -> ModuleName -> CompPipeline ModLocation
+getLocation src_flavour mod_name = do
+    dflags <- getDynFlags
+
+    PipeEnv{ src_basename=basename,
+             src_suffix=suff } <- getPipeEnv
+
+    -- Build a ModLocation to pass to hscMain.
+    -- The source filename is rather irrelevant by now, but it's used
+    -- by hscMain for messages.  hscMain also needs
+    -- the .hi and .o filenames, and this is as good a way
+    -- as any to generate them, and better than most. (e.g. takes
+    -- into account the -osuf flags)
+    location1 <- liftIO $ mkHomeModLocation2 dflags mod_name basename suff
+
+    -- Boot-ify it if necessary
+    let location2 | isHsBoot src_flavour = addBootSuffixLocn location1
+                  | otherwise            = location1
+
+
+    -- Take -ohi into account if present
+    -- This can't be done in mkHomeModuleLocation because
+    -- it only applies to the module being compiles
+    let ohi = outputHi dflags
+        location3 | Just fn <- ohi = location2{ ml_hi_file = fn }
+                  | otherwise      = location2
+
+    -- Take -o into account if present
+    -- Very like -ohi, but we must *only* do this if we aren't linking
+    -- (If we're linking then the -o applies to the linked thing, not to
+    -- the object file for one module.)
+    -- Note the nasty duplication with the same computation in compileFile above
+    let expl_o_file = outputFile dflags
+        location4 | Just ofile <- expl_o_file
+                  , isNoLink (ghcLink dflags)
+                  = location3 { ml_obj_file = ofile }
+                  | otherwise = location3
+
+    return location4
+
 -----------------------------------------------------------------------------
 -- MoveBinary sort-of-phase
 -- After having produced a binary, move it somewhere else and generate a
index 975ff9d..0aab82f 100644 (file)
@@ -529,12 +529,7 @@ data HscStatus
     = HscNotGeneratingCode
     | HscUpToDate
     | HscUpdateBoot
-    | HscRecomp
-          FilePath
-          (Maybe FilePath) -- Has stub files. This is a hack. We can't compile
-                           -- C files here since it's done in DriverPipeline.
-                           -- For now we just return True if we want the caller
-                           -- to compile them for us.
+    | HscRecomp CgGuts ModSummary
 
 type Messager = HscEnv -> (Int,Int) -> RecompileRequired -> ModSummary -> IO ()
 
@@ -655,8 +650,7 @@ hscCompileOneShot hsc_env mod_summary src_changed
                            guts <- hscSimplify' guts0
                            (iface, changed, _details, cgguts) <- hscNormalIface' guts mb_old_hash
                            liftIO $ hscWriteIface dflags iface changed mod_summary
-                           (outputFilename, mStub) <- liftIO $ hscGenHardCode hsc_env' cgguts mod_summary
-                           return $ HscRecomp outputFilename mStub
+                           return $ HscRecomp cgguts mod_summary
 
         stable = case src_changed of
                      SourceUnmodifiedAndStable -> True