Remove extCoreName from DynFlags
authorIan Lynagh <ian@well-typed.com>
Fri, 26 Apr 2013 21:18:45 +0000 (22:18 +0100)
committerIan Lynagh <ian@well-typed.com>
Fri, 26 Apr 2013 21:18:45 +0000 (22:18 +0100)
We now just pass the filename as an argument

compiler/coreSyn/MkExternalCore.lhs
compiler/main/DriverPipeline.hs
compiler/main/DynFlags.hs
compiler/main/GHC.hs
compiler/main/HscMain.hs

index 9628c88..e84dff9 100644 (file)
@@ -37,16 +37,15 @@ import qualified Data.ByteString as BS
 import Data.Char
 import System.IO
 
-emitExternalCore :: DynFlags -> CgGuts -> IO ()
-emitExternalCore dflags cg_guts
+emitExternalCore :: DynFlags -> FilePath -> CgGuts -> IO ()
+emitExternalCore dflags extCore_filename cg_guts
  | gopt Opt_EmitExternalCore dflags
- = (do handle <- openFile corename WriteMode
+ = (do handle <- openFile extCore_filename WriteMode
        hPutStrLn handle (show (mkExternalCore dflags cg_guts))
        hClose handle)
    `catchIO` (\_ -> pprPanic "Failed to open or write external core output file"
-                             (text corename))
-   where corename = extCoreName dflags
-emitExternalCore _ _
+                             (text extCore_filename))
+emitExternalCore _ _ _
  | otherwise
  = return ()
 
index de717b0..1328ffe 100644 (file)
@@ -148,8 +148,7 @@ compileOne' m_tc_result mHscMessage
    output_fn <- getOutputFilename next_phase
                         Temporary basename dflags next_phase (Just location)
 
-   let dflags' = dflags { extCoreName = basename ++ ".hcr" }
-   let hsc_env' = hsc_env { hsc_dflags = dflags' }
+   let extCore_filename = basename ++ ".hcr"
 
    -- -fforce-recomp should also work with --make
    let force_recomp = gopt Opt_ForceRecomp dflags
@@ -165,7 +164,7 @@ compileOne' m_tc_result mHscMessage
    e <- genericHscCompileGetFrontendResult
             always_do_basic_recompilation_check
             m_tc_result mHscMessage
-            hsc_env' summary source_modified mb_old_iface (mod_index, nmods)
+            hsc_env summary source_modified mb_old_iface (mod_index, nmods)
 
    case e of
        Left iface ->
@@ -181,19 +180,19 @@ compileOne' m_tc_result mHscMessage
                HscInterpreted ->
                    case ms_hsc_src summary of
                    HsBootFile ->
-                       do (iface, _changed, details) <- hscSimpleIface hsc_env' tc_result mb_old_hash
+                       do (iface, _changed, details) <- hscSimpleIface hsc_env tc_result mb_old_hash
                           return (HomeModInfo{ hm_details  = details,
                                                hm_iface    = iface,
                                                hm_linkable = maybe_old_linkable })
-                   _ -> do guts0 <- hscDesugar hsc_env' summary tc_result
-                           guts <- hscSimplify hsc_env' guts0
-                           (iface, _changed, details, cgguts) <- hscNormalIface hsc_env' guts mb_old_hash
-                           (hasStub, comp_bc, modBreaks) <- hscInteractive hsc_env' cgguts summary
+                   _ -> do guts0 <- hscDesugar hsc_env summary tc_result
+                           guts <- hscSimplify hsc_env guts0
+                           (iface, _changed, details, cgguts) <- hscNormalIface hsc_env extCore_filename guts mb_old_hash
+                           (hasStub, comp_bc, modBreaks) <- hscInteractive hsc_env cgguts summary
 
                            stub_o <- case hasStub of
                                      Nothing -> return []
                                      Just stub_c -> do
-                                         stub_o <- compileStub hsc_env' stub_c
+                                         stub_o <- compileStub hsc_env stub_c
                                          return [DotO stub_o]
 
                            let hs_unlinked = [BCOs comp_bc modBreaks]
@@ -211,7 +210,7 @@ compileOne' m_tc_result mHscMessage
                                                 hm_iface    = iface,
                                                 hm_linkable = Just linkable })
                HscNothing ->
-                   do (iface, _changed, details) <- hscSimpleIface hsc_env' tc_result mb_old_hash
+                   do (iface, _changed, details) <- hscSimpleIface hsc_env tc_result mb_old_hash
                       let linkable = if isHsBoot src_flavour
                                      then maybe_old_linkable
                                      else Just (LM (ms_hs_date summary) this_mod [])
@@ -222,21 +221,21 @@ compileOne' m_tc_result mHscMessage
                _ ->
                    case ms_hsc_src summary of
                    HsBootFile ->
-                       do (iface, changed, details) <- hscSimpleIface hsc_env' tc_result mb_old_hash
-                          hscWriteIface dflags' iface changed summary
-                          touchObjectFile dflags' object_filename
+                       do (iface, changed, details) <- hscSimpleIface hsc_env tc_result mb_old_hash
+                          hscWriteIface dflags iface changed summary
+                          touchObjectFile dflags object_filename
                           return (HomeModInfo{ hm_details  = details,
                                                hm_iface    = iface,
                                                hm_linkable = maybe_old_linkable })
 
-                   _ -> do guts0 <- hscDesugar hsc_env' summary tc_result
-                           guts <- hscSimplify hsc_env' guts0
-                           (iface, changed, details, cgguts) <- hscNormalIface hsc_env' guts mb_old_hash
-                           hscWriteIface dflags' iface changed summary
+                   _ -> do guts0 <- hscDesugar hsc_env summary tc_result
+                           guts <- hscSimplify hsc_env guts0
+                           (iface, changed, details, cgguts) <- hscNormalIface hsc_env extCore_filename guts mb_old_hash
+                           hscWriteIface dflags iface changed summary
 
                            -- We're in --make mode: finish the compilation pipeline.
                            let mod_name = ms_mod_name summary
-                           _ <- runPipeline StopLn hsc_env'
+                           _ <- runPipeline StopLn hsc_env
                                              (output_fn,
                                               Just (HscOut src_flavour mod_name (HscRecomp cgguts summary)))
                                              (Just basename)
@@ -984,9 +983,8 @@ runPhase (RealPhase (Hsc src_flavour)) input_fn dflags0
                                   then return SourceUnmodified
                                   else return SourceModified
 
-        let dflags' = dflags { extCoreName = basename ++ ".hcr" }
+        let extCore_filename = basename ++ ".hcr"
 
-        setDynFlags dflags'
         PipeState{hsc_env=hsc_env'} <- getPipeState
 
   -- Tell the finder cache about this module
@@ -1006,7 +1004,7 @@ runPhase (RealPhase (Hsc src_flavour)) input_fn dflags0
                                         ms_srcimps      = src_imps }
 
   -- run the compiler!
-        result <- liftIO $ hscCompileOneShot hsc_env'
+        result <- liftIO $ hscCompileOneShot hsc_env' extCore_filename
                                mod_summary source_unchanged
 
         return (HscOut src_flavour mod_name result,
@@ -1061,16 +1059,12 @@ runPhase (RealPhase CmmCpp) input_fn dflags
 
 runPhase (RealPhase Cmm) input_fn dflags
   = do
-        PipeEnv{src_basename} <- getPipeEnv
         let hsc_lang = hscTarget dflags
 
         let next_phase = hscPostBackendPhase dflags HsSrcFile hsc_lang
 
         output_fn <- phaseOutputFilename next_phase
 
-        let dflags' = dflags { extCoreName = src_basename ++ ".hcr" }
-
-        setDynFlags dflags'
         PipeState{hsc_env} <- getPipeState
 
         liftIO $ hscCompileCmmFile hsc_env input_fn output_fn
index 5a0f6f9..33eae5a 100644 (file)
@@ -560,7 +560,6 @@ data DynFlags = DynFlags {
   ghcLink               :: GhcLink,
   hscTarget             :: HscTarget,
   settings              :: Settings,
-  extCoreName           :: String,      -- ^ Name of the .hcr output file
   verbosity             :: Int,         -- ^ Verbosity level: see Note [Verbosity levels]
   optLevel              :: Int,         -- ^ Optimisation level
   simplPhases           :: Int,         -- ^ Number of simplifier phases
@@ -1212,7 +1211,6 @@ defaultDynFlags mySettings =
         ghcMode                 = CompManager,
         ghcLink                 = LinkBinary,
         hscTarget               = defaultHscTarget (sTargetPlatform mySettings),
-        extCoreName             = "",
         verbosity               = 0,
         optLevel                = 0,
         simplPhases             = 2,
index 3e5fe9c..a4aba13 100644 (file)
@@ -892,8 +892,10 @@ compileToCoreSimplified = compileCore True
 -- The resulting .o, .hi, and executable files, if any, are stored in the
 -- current directory, and named according to the module name.
 -- This has only so far been tested with a single self-contained module.
-compileCoreToObj :: GhcMonad m => Bool -> CoreModule -> FilePath -> m ()
-compileCoreToObj simplify cm@(CoreModule{ cm_module = mName }) output_fn = do
+compileCoreToObj :: GhcMonad m
+                 => Bool -> CoreModule -> FilePath -> FilePath -> m ()
+compileCoreToObj simplify cm@(CoreModule{ cm_module = mName })
+                 output_fn extCore_filename = do
   dflags      <- getSessionDynFlags
   currentTime <- liftIO $ getCurrentTime
   cwd         <- liftIO $ getCurrentDirectory
@@ -919,7 +921,7 @@ compileCoreToObj simplify cm@(CoreModule{ cm_module = mName }) output_fn = do
       }
 
   hsc_env <- getSession
-  liftIO $ hscCompileCore hsc_env simplify (cm_safe cm) modSum (cm_binds cm) output_fn
+  liftIO $ hscCompileCore hsc_env simplify (cm_safe cm) modSum (cm_binds cm) output_fn extCore_filename
 
 
 compileCore :: GhcMonad m => Bool -> FilePath -> m CoreModule
index a6d4508..a618a74 100644 (file)
@@ -616,10 +616,11 @@ genericHscFrontend mod_summary
 
 -- Compile Haskell, boot and extCore in OneShot mode.
 hscCompileOneShot :: HscEnv
+                  -> FilePath
                   -> ModSummary
                   -> SourceModified
                   -> IO HscStatus
-hscCompileOneShot hsc_env mod_summary src_changed
+hscCompileOneShot hsc_env extCore_filename mod_summary src_changed
   = do
     -- One-shot mode needs a knot-tying mutable variable for interface
     -- files. See TcRnTypes.TcGblEnv.tcg_type_env_var.
@@ -648,7 +649,7 @@ hscCompileOneShot hsc_env mod_summary src_changed
                     _ ->
                         do guts0 <- hscDesugar' (ms_location mod_summary) tc_result
                            guts <- hscSimplify' guts0
-                           (iface, changed, _details, cgguts) <- hscNormalIface' guts mb_old_hash
+                           (iface, changed, _details, cgguts) <- hscNormalIface' extCore_filename guts mb_old_hash
                            liftIO $ hscWriteIface dflags iface changed mod_summary
                            return $ HscRecomp cgguts mod_summary
 
@@ -1082,16 +1083,18 @@ hscSimpleIface' tc_result mb_old_iface = do
     return (new_iface, no_change, details)
 
 hscNormalIface :: HscEnv
+               -> FilePath
                -> ModGuts
                -> Maybe Fingerprint
                -> IO (ModIface, Bool, ModDetails, CgGuts)
-hscNormalIface hsc_env simpl_result mb_old_iface =
-    runHsc hsc_env $ hscNormalIface' simpl_result mb_old_iface
+hscNormalIface hsc_env extCore_filename simpl_result mb_old_iface =
+    runHsc hsc_env $ hscNormalIface' extCore_filename simpl_result mb_old_iface
 
-hscNormalIface' :: ModGuts
+hscNormalIface' :: FilePath
+                -> ModGuts
                 -> Maybe Fingerprint
                 -> Hsc (ModIface, Bool, ModDetails, CgGuts)
-hscNormalIface' simpl_result mb_old_iface = do
+hscNormalIface' extCore_filename simpl_result mb_old_iface = do
     hsc_env <- getHscEnv
     (cg_guts, details) <- {-# SCC "CoreTidy" #-}
                           liftIO $ tidyProgram hsc_env simpl_result
@@ -1110,7 +1113,7 @@ hscNormalIface' simpl_result mb_old_iface = do
     -- This should definitely be here and not after CorePrep,
     -- because CorePrep produces unqualified constructor wrapper declarations,
     -- so its output isn't valid External Core (without some preprocessing).
-    liftIO $ emitExternalCore (hsc_dflags hsc_env) cg_guts
+    liftIO $ emitExternalCore (hsc_dflags hsc_env) extCore_filename cg_guts
     liftIO $ dumpIfaceStats hsc_env
 
     -- Return the prepared code.
@@ -1556,11 +1559,11 @@ hscParseThingWithLocation source linenumber parser str
             return thing
 
 hscCompileCore :: HscEnv -> Bool -> SafeHaskellMode -> ModSummary
-               -> CoreProgram -> FilePath -> IO ()
-hscCompileCore hsc_env simplify safe_mode mod_summary binds output_filename
+               -> CoreProgram -> FilePath -> FilePath -> IO ()
+hscCompileCore hsc_env simplify safe_mode mod_summary binds output_filename extCore_filename
   = runHsc hsc_env $ do
         guts <- maybe_simplify (mkModGuts (ms_mod mod_summary) safe_mode binds)
-        (iface, changed, _details, cgguts) <- hscNormalIface' guts Nothing
+        (iface, changed, _details, cgguts) <- hscNormalIface' extCore_filename guts Nothing
         liftIO $ hscWriteIface (hsc_dflags hsc_env) iface changed mod_summary
         _ <- liftIO $ hscGenHardCode hsc_env cgguts mod_summary output_filename
         return ()