summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/coreSyn/MkExternalCore.lhs11
-rw-r--r--compiler/main/DriverPipeline.hs44
-rw-r--r--compiler/main/DynFlags.hs2
-rw-r--r--compiler/main/GHC.hs8
-rw-r--r--compiler/main/HscMain.hs23
5 files changed, 42 insertions, 46 deletions
diff --git a/compiler/coreSyn/MkExternalCore.lhs b/compiler/coreSyn/MkExternalCore.lhs
index 9628c88f17..e84dff900d 100644
--- a/compiler/coreSyn/MkExternalCore.lhs
+++ b/compiler/coreSyn/MkExternalCore.lhs
@@ -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 ()
diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs
index de717b05d4..1328ffe209 100644
--- a/compiler/main/DriverPipeline.hs
+++ b/compiler/main/DriverPipeline.hs
@@ -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
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 5a0f6f9f2b..33eae5a199 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -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,
diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index 3e5fe9cea9..a4aba138b9 100644
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -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
diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs
index a6d45081c3..a618a74e1a 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -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 ()
View Lorry Controller Status