Commit 50ad870e authored by ian@well-typed.com's avatar ian@well-typed.com
Browse files

Remove extCoreName from DynFlags

We now just pass the filename as an argument
parent da5c9c7f
......@@ -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 ()
......
......@@ -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
......
......@@ -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,
......
......@@ -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
......
......@@ -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 ()
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment