Commit 3c22606b authored by Simon Marlow's avatar Simon Marlow

Rationalise GhcMode, HscTarget and GhcLink

This patch cleans up the GHC API, and adds some functionality: we can
now compile to object code inside GHCi.

Previously we had:

  data GhcMode
    = BatchCompile
    | Interactive
    | OneShot
    | JustTypecheck
    | MkDepend
  
  data HscTarget
    = HscC
    | HscAsm
    | HscJava
    | HscInterpreted
    | HscNothing

There was redundancy here; if GhcMode is Interactive, then only
HscInterpreted makes sense, and JustTypecheck required HscNothing.
Now we have:

  data GhcMode
    = CompManager       -- ^ --make, GHCi, etc.
    | OneShot           -- ^ ghc -c Foo.hs
    | MkDepend          -- ^ ghc -M, see Finder for why we need this

and HscTarget remains as before.

Previously GhcLink looked like this:

  data GhcLink = NoLink | StaticLink

Now we have:

  data GhcLink = NoLink | LinkBinary | LinkInMemory

The idea being that you can have an HscTarget of HscAsm (for example)
and still link in memory.

There are two new flags:

  -fobject-code selects object code as the target (selects
                either -fasm or -fvia-C, whichever is the default)
                This can be usd with ':set' in GHCi, or on the command line.

  -fbyte-code   sets byte-code as the target.  Only works in GHCi.
                One day maybe this could save the byte code in a file
                when used outside GHCi.

  (names chosen for consistency with -fno-code).

Changes to the GHC API: newSession no longer takes the GhcMode
argument.  The GhcMode defaults to CompManager, which is usually what
you want.  To do JustTypecheck now, just set hscTarget to HscNothing.
parent d55443e6
...@@ -78,14 +78,17 @@ deSugar hsc_env ...@@ -78,14 +78,17 @@ deSugar hsc_env
tcg_rules = rules, tcg_rules = rules,
tcg_insts = insts, tcg_insts = insts,
tcg_fam_insts = fam_insts }) tcg_fam_insts = fam_insts })
= do { showPass dflags "Desugar"
= do { let dflags = hsc_dflags hsc_env
; showPass dflags "Desugar"
-- Desugar the program -- Desugar the program
; let export_set = availsToNameSet exports ; let export_set = availsToNameSet exports
; let auto_scc = mkAutoScc mod export_set ; let auto_scc = mkAutoScc mod export_set
; let noDbgSites = [] ; let noDbgSites = []
; mb_res <- case ghcMode dflags of ; let target = hscTarget dflags
JustTypecheck -> return (Just ([], [], NoStubs, noHpcInfo, noDbgSites)) ; mb_res <- case target of
HscNothing -> return (Just ([], [], NoStubs, noHpcInfo, noDbgSites))
_ -> do (binds_cvr,ds_hpc_info) _ -> do (binds_cvr,ds_hpc_info)
<- if opt_Hpc <- if opt_Hpc
then addCoverageTicksToBinds dflags mod mod_loc binds then addCoverageTicksToBinds dflags mod mod_loc binds
...@@ -107,7 +110,7 @@ deSugar hsc_env ...@@ -107,7 +110,7 @@ deSugar hsc_env
{ -- Add export flags to bindings { -- Add export flags to bindings
keep_alive <- readIORef keep_var keep_alive <- readIORef keep_var
; let final_prs = addExportFlags ghci_mode export_set ; let final_prs = addExportFlags target export_set
keep_alive all_prs ds_rules keep_alive all_prs ds_rules
ds_binds = [Rec final_prs] ds_binds = [Rec final_prs]
-- Notice that we put the whole lot in a big Rec, even the foreign binds -- Notice that we put the whole lot in a big Rec, even the foreign binds
...@@ -178,10 +181,6 @@ deSugar hsc_env ...@@ -178,10 +181,6 @@ deSugar hsc_env
; return (Just mod_guts) ; return (Just mod_guts)
}}} }}}
where
dflags = hsc_dflags hsc_env
ghci_mode = ghcMode (hsc_dflags hsc_env)
mkAutoScc :: Module -> NameSet -> AutoScc mkAutoScc :: Module -> NameSet -> AutoScc
mkAutoScc mod exports mkAutoScc mod exports
| not opt_SccProfilingOn -- No profiling | not opt_SccProfilingOn -- No profiling
...@@ -233,7 +232,7 @@ deSugarExpr hsc_env this_mod rdr_env type_env tc_expr ...@@ -233,7 +232,7 @@ deSugarExpr hsc_env this_mod rdr_env type_env tc_expr
-- it's just because the type checker is rather busy already and -- it's just because the type checker is rather busy already and
-- I didn't want to pass in yet another mapping. -- I didn't want to pass in yet another mapping.
addExportFlags ghci_mode exports keep_alive prs rules addExportFlags target exports keep_alive prs rules
= [(add_export bndr, rhs) | (bndr,rhs) <- prs] = [(add_export bndr, rhs) | (bndr,rhs) <- prs]
where where
add_export bndr add_export bndr
...@@ -262,7 +261,7 @@ addExportFlags ghci_mode exports keep_alive prs rules ...@@ -262,7 +261,7 @@ addExportFlags ghci_mode exports keep_alive prs rules
-- isExternalName separates the user-defined top-level names from those -- isExternalName separates the user-defined top-level names from those
-- introduced by the type checker. -- introduced by the type checker.
is_exported :: Name -> Bool is_exported :: Name -> Bool
is_exported | ghci_mode == Interactive = isExternalName is_exported | target == HscInterpreted = isExternalName
| otherwise = (`elemNameSet` exports) | otherwise = (`elemNameSet` exports)
ppr_ds_rules [] = empty ppr_ds_rules [] = empty
......
...@@ -166,9 +166,10 @@ debug_enabled = do ...@@ -166,9 +166,10 @@ debug_enabled = do
breakpoints_enabled = do breakpoints_enabled = do
ghcMode <- getGhcModeDs ghcMode <- getGhcModeDs
currentModule <- getModuleDs currentModule <- getModuleDs
dflags <- getDOptsDs
ignore_breakpoints <- doptDs Opt_IgnoreBreakpoints ignore_breakpoints <- doptDs Opt_IgnoreBreakpoints
return ( not ignore_breakpoints return ( not ignore_breakpoints
&& ghcMode == Interactive && hscTarget dflags == HscInterpreted
&& currentModule /= iNTERACTIVE ) && currentModule /= iNTERACTIVE )
maybeInsertBreakpoint lhsexpr@(L loc _) ty = do maybeInsertBreakpoint lhsexpr@(L loc _) ty = do
......
...@@ -832,9 +832,8 @@ check_old_iface hsc_env mod_summary source_unchanged maybe_iface ...@@ -832,9 +832,8 @@ check_old_iface hsc_env mod_summary source_unchanged maybe_iface
-- If the source has changed and we're in interactive mode, avoid reading -- If the source has changed and we're in interactive mode, avoid reading
-- an interface; just return the one we might have been supplied with. -- an interface; just return the one we might have been supplied with.
; ghc_mode <- getGhcMode ; let dflags = hsc_dflags hsc_env
; if (ghc_mode == Interactive || ghc_mode == JustTypecheck) ; if not (isObjectTarget (hscTarget dflags)) && not source_unchanged then
&& not source_unchanged then
return (outOfDate, maybe_iface) return (outOfDate, maybe_iface)
else else
case maybe_iface of { case maybe_iface of {
......
...@@ -250,7 +250,7 @@ compileStub dflags mod location = do ...@@ -250,7 +250,7 @@ compileStub dflags mod location = do
-- --------------------------------------------------------------------------- -- ---------------------------------------------------------------------------
-- Link -- Link
link :: GhcMode -- interactive or batch link :: GhcLink -- interactive or batch
-> DynFlags -- dynamic flags -> DynFlags -- dynamic flags
-> Bool -- attempt linking in batch mode? -> Bool -- attempt linking in batch mode?
-> HomePackageTable -- what to link -> HomePackageTable -- what to link
...@@ -264,15 +264,15 @@ link :: GhcMode -- interactive or batch ...@@ -264,15 +264,15 @@ link :: GhcMode -- interactive or batch
-- will succeed. -- will succeed.
#ifdef GHCI #ifdef GHCI
link Interactive dflags batch_attempt_linking hpt link LinkInMemory dflags batch_attempt_linking hpt
= do -- Not Linking...(demand linker will do the job) = do -- Not Linking...(demand linker will do the job)
return Succeeded return Succeeded
#endif #endif
link JustTypecheck dflags batch_attempt_linking hpt link NoLink dflags batch_attempt_linking hpt
= return Succeeded = return Succeeded
link BatchCompile dflags batch_attempt_linking hpt link LinkBinary dflags batch_attempt_linking hpt
| batch_attempt_linking | batch_attempt_linking
= do = do
let let
...@@ -317,7 +317,7 @@ link BatchCompile dflags batch_attempt_linking hpt ...@@ -317,7 +317,7 @@ link BatchCompile dflags batch_attempt_linking hpt
-- Don't showPass in Batch mode; doLink will do that for us. -- Don't showPass in Batch mode; doLink will do that for us.
let link = case ghcLink dflags of let link = case ghcLink dflags of
MkDLL -> doMkDLL MkDLL -> doMkDLL
StaticLink -> staticLink LinkBinary -> staticLink
link dflags obj_files pkg_deps link dflags obj_files pkg_deps
debugTraceMsg dflags 3 (text "link: done") debugTraceMsg dflags 3 (text "link: done")
...@@ -377,7 +377,7 @@ doLink dflags stop_phase o_files ...@@ -377,7 +377,7 @@ doLink dflags stop_phase o_files
| otherwise | otherwise
= case ghcLink dflags of = case ghcLink dflags of
NoLink -> return () NoLink -> return ()
StaticLink -> staticLink dflags o_files link_pkgs LinkBinary -> staticLink dflags o_files link_pkgs
MkDLL -> doMkDLL dflags o_files link_pkgs MkDLL -> doMkDLL dflags o_files link_pkgs
where where
-- Always link in the haskell98 package for static linking. Other -- Always link in the haskell98 package for static linking. Other
......
{-# OPTIONS -fno-warn-missing-fields #-} {-# OPTIONS -fno-warn-missing-fields #-}
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- --
...@@ -16,7 +17,7 @@ module DynFlags ( ...@@ -16,7 +17,7 @@ module DynFlags (
-- Dynamic flags -- Dynamic flags
DynFlag(..), DynFlag(..),
DynFlags(..), DynFlags(..),
HscTarget(..), HscTarget(..), isObjectTarget,
GhcMode(..), isOneShot, GhcMode(..), isOneShot,
GhcLink(..), isNoLink, GhcLink(..), isNoLink,
PackageFlag(..), PackageFlag(..),
...@@ -335,24 +336,35 @@ data HscTarget ...@@ -335,24 +336,35 @@ data HscTarget
| HscNothing | HscNothing
deriving (Eq, Show) deriving (Eq, Show)
-- | will this target result in an object file on the disk?
isObjectTarget :: HscTarget -> Bool
isObjectTarget HscC = True
isObjectTarget HscAsm = True
isObjectTarget _ = False
-- | The 'GhcMode' tells us whether we're doing multi-module
-- compilation (controlled via the "GHC" API) or one-shot
-- (single-module) compilation. This makes a difference primarily to
-- the "Finder": in one-shot mode we look for interface files for
-- imported modules, but in multi-module mode we look for source files
-- in order to check whether they need to be recompiled.
data GhcMode data GhcMode
= BatchCompile -- | @ghc --make Main@ = CompManager -- ^ --make, GHCi, etc.
| Interactive -- | @ghc --interactive@ | OneShot -- ^ ghc -c Foo.hs
| OneShot -- | @ghc -c Foo.hs@ | MkDepend -- ^ ghc -M, see Finder for why we need this
| JustTypecheck -- | Development environemnts, refactorer, etc.
| MkDepend
deriving Eq deriving Eq
isOneShot :: GhcMode -> Bool isOneShot :: GhcMode -> Bool
isOneShot OneShot = True isOneShot OneShot = True
isOneShot _other = False isOneShot _other = False
-- | What kind of linking to do.
data GhcLink -- What to do in the link step, if there is one data GhcLink -- What to do in the link step, if there is one
= -- Only relevant for modes = NoLink -- Don't link at all
-- DoMake and StopBefore StopLn | LinkBinary -- Link object code into a binary
NoLink -- Don't link at all | LinkInMemory -- Use the in-memory dynamic linker
| StaticLink -- Ordinary linker [the default]
| MkDLL -- Make a DLL | MkDLL -- Make a DLL
deriving Eq
isNoLink :: GhcLink -> Bool isNoLink :: GhcLink -> Bool
isNoLink NoLink = True isNoLink NoLink = True
...@@ -381,8 +393,8 @@ initDynFlags dflags = do ...@@ -381,8 +393,8 @@ initDynFlags dflags = do
defaultDynFlags = defaultDynFlags =
DynFlags { DynFlags {
ghcMode = OneShot, ghcMode = CompManager,
ghcLink = StaticLink, ghcLink = LinkBinary,
coreToDo = Nothing, coreToDo = Nothing,
stgToDo = Nothing, stgToDo = Nothing,
hscTarget = defaultHscTarget, hscTarget = defaultHscTarget,
...@@ -995,10 +1007,13 @@ dynamic_flags = [ ...@@ -995,10 +1007,13 @@ dynamic_flags = [
------ Compiler flags ----------------------------------------------- ------ Compiler flags -----------------------------------------------
, ( "fasm", AnySuffix (\_ -> setObjTarget HscAsm) )
, ( "fvia-c", NoArg (setObjTarget HscC) )
, ( "fvia-C", NoArg (setObjTarget HscC) )
, ( "fno-code", NoArg (setTarget HscNothing)) , ( "fno-code", NoArg (setTarget HscNothing))
, ( "fasm", AnySuffix (\_ -> setTarget HscAsm) ) , ( "fbyte-code", NoArg (setTarget HscInterpreted) )
, ( "fvia-c", NoArg (setTarget HscC) ) , ( "fobject-code", NoArg (setTarget defaultHscTarget) )
, ( "fvia-C", NoArg (setTarget HscC) )
, ( "fglasgow-exts", NoArg (mapM_ setDynFlag glasgowExtsFlags) ) , ( "fglasgow-exts", NoArg (mapM_ setDynFlag glasgowExtsFlags) )
, ( "fno-glasgow-exts", NoArg (mapM_ unSetDynFlag glasgowExtsFlags) ) , ( "fno-glasgow-exts", NoArg (mapM_ unSetDynFlag glasgowExtsFlags) )
...@@ -1133,12 +1148,23 @@ setPackageName p ...@@ -1133,12 +1148,23 @@ setPackageName p
where where
pid = stringToPackageId p pid = stringToPackageId p
-- we can only switch between HscC, and HscAsmm with dynamic flags -- If we're linking a binary, then only targets that produce object
-- (-fvia-C, -fasm, -filx respectively). -- code are allowed (requests for other target types are ignored).
setTarget l = upd (\dfs -> case hscTarget dfs of setTarget l = upd set
HscC -> dfs{ hscTarget = l } where
HscAsm -> dfs{ hscTarget = l } set dfs
_ -> dfs) | ghcLink dfs /= LinkBinary || isObjectTarget l = dfs{ hscTarget = l }
| otherwise = dfs
-- Changes the target only if we're compiling object code. This is
-- used by -fasm and -fvia-C, which switch from one to the other, but
-- not from bytecode to object-code. The idea is that -fasm/-fvia-C
-- can be safely used in an OPTIONS_GHC pragma.
setObjTarget l = upd set
where
set dfs
| isObjectTarget (hscTarget dfs) = dfs { hscTarget = l }
| otherwise = dfs
setOptLevel :: Int -> DynFlags -> DynFlags setOptLevel :: Int -> DynFlags -> DynFlags
setOptLevel n dflags setOptLevel n dflags
......
...@@ -14,7 +14,8 @@ module GHC ( ...@@ -14,7 +14,8 @@ module GHC (
newSession, newSession,
-- * Flags and settings -- * Flags and settings
DynFlags(..), DynFlag(..), Severity(..), GhcMode(..), HscTarget(..), dopt, DynFlags(..), DynFlag(..), Severity(..), HscTarget(..), dopt,
GhcMode(..), GhcLink(..),
parseDynamicFlags, parseDynamicFlags,
getSessionDynFlags, getSessionDynFlags,
setSessionDynFlags, setSessionDynFlags,
...@@ -356,10 +357,8 @@ GLOBAL_VAR(v_bkptLinkEnv, [], [(Name, HValue)]) ...@@ -356,10 +357,8 @@ GLOBAL_VAR(v_bkptLinkEnv, [], [(Name, HValue)])
-- | Starts a new session. A session consists of a set of loaded -- | Starts a new session. A session consists of a set of loaded
-- modules, a set of options (DynFlags), and an interactive context. -- modules, a set of options (DynFlags), and an interactive context.
-- ToDo: GhcMode should say "keep typechecked code" and\/or "keep renamed newSession :: Maybe FilePath -> IO Session
-- code". newSession mb_top_dir = do
newSession :: GhcMode -> Maybe FilePath -> IO Session
newSession mode mb_top_dir = do
-- catch ^C -- catch ^C
main_thread <- myThreadId main_thread <- myThreadId
modifyMVar_ interruptTargetThread (return . (main_thread :)) modifyMVar_ interruptTargetThread (return . (main_thread :))
...@@ -367,7 +366,7 @@ newSession mode mb_top_dir = do ...@@ -367,7 +366,7 @@ newSession mode mb_top_dir = do
dflags0 <- initSysTools mb_top_dir defaultDynFlags dflags0 <- initSysTools mb_top_dir defaultDynFlags
dflags <- initDynFlags dflags0 dflags <- initDynFlags dflags0
env <- newHscEnv dflags{ ghcMode=mode } env <- newHscEnv dflags
ref <- newIORef env ref <- newIORef env
return (Session ref) return (Session ref)
...@@ -528,10 +527,9 @@ depanal (Session ref) excluded_mods allow_dup_roots = do ...@@ -528,10 +527,9 @@ depanal (Session ref) excluded_mods allow_dup_roots = do
old_graph = hsc_mod_graph hsc_env old_graph = hsc_mod_graph hsc_env
showPass dflags "Chasing dependencies" showPass dflags "Chasing dependencies"
when (gmode == BatchCompile) $ debugTraceMsg dflags 2 (hcat [
debugTraceMsg dflags 2 (hcat [ text "Chasing modules from: ",
text "Chasing modules from: ", hcat (punctuate comma (map pprTarget targets))])
hcat (punctuate comma (map pprTarget targets))])
r <- downsweep hsc_env old_graph excluded_mods allow_dup_roots r <- downsweep hsc_env old_graph excluded_mods allow_dup_roots
case r of case r of
...@@ -610,8 +608,7 @@ load2 s@(Session ref) how_much mod_graph = do ...@@ -610,8 +608,7 @@ load2 s@(Session ref) how_much mod_graph = do
let let
-- check the stability property for each module. -- check the stability property for each module.
stable_mods@(stable_obj,stable_bco) stable_mods@(stable_obj,stable_bco)
| BatchCompile <- ghci_mode = ([],[]) = checkStability hpt1 mg2_with_srcimps all_home_mods
| otherwise = checkStability hpt1 mg2_with_srcimps all_home_mods
-- prune bits of the HPT which are definitely redundant now, -- prune bits of the HPT which are definitely redundant now,
-- to save space. -- to save space.
...@@ -719,13 +716,16 @@ load2 s@(Session ref) how_much mod_graph = do ...@@ -719,13 +716,16 @@ load2 s@(Session ref) how_much mod_graph = do
a_root_is_Main = any ((==main_mod).ms_mod) mod_graph a_root_is_Main = any ((==main_mod).ms_mod) mod_graph
do_linking = a_root_is_Main || no_hs_main do_linking = a_root_is_Main || no_hs_main
when (ghci_mode == BatchCompile && isJust ofile && not do_linking) $ when (ghcLink dflags == LinkBinary
debugTraceMsg dflags 1 (text ("Warning: output was redirected with -o, " ++ && isJust ofile && not do_linking) $
"but no output will be generated\n" ++ debugTraceMsg dflags 1 $
"because there is no " ++ moduleNameString (moduleName main_mod) ++ " module.")) text ("Warning: output was redirected with -o, " ++
"but no output will be generated\n" ++
"because there is no " ++
moduleNameString (moduleName main_mod) ++ " module.")
-- link everything together -- link everything together
linkresult <- link ghci_mode dflags do_linking (hsc_HPT hsc_env1) linkresult <- link (ghcLink dflags) dflags do_linking (hsc_HPT hsc_env1)
loadFinish Succeeded linkresult ref hsc_env1 loadFinish Succeeded linkresult ref hsc_env1
...@@ -755,7 +755,7 @@ load2 s@(Session ref) how_much mod_graph = do ...@@ -755,7 +755,7 @@ load2 s@(Session ref) how_much mod_graph = do
(eltsUFM (hsc_HPT hsc_env))) do (eltsUFM (hsc_HPT hsc_env))) do
-- Link everything together -- Link everything together
linkresult <- link ghci_mode dflags False hpt4 linkresult <- link (ghcLink dflags) dflags False hpt4
let hsc_env4 = hsc_env1{ hsc_HPT = hpt4 } let hsc_env4 = hsc_env1{ hsc_HPT = hpt4 }
loadFinish Failed linkresult ref hsc_env4 loadFinish Failed linkresult ref hsc_env4
...@@ -868,15 +868,13 @@ checkModule session@(Session ref) mod = do ...@@ -868,15 +868,13 @@ checkModule session@(Session ref) mod = do
unload :: HscEnv -> [Linkable] -> IO () unload :: HscEnv -> [Linkable] -> IO ()
unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables' unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables'
= case ghcMode (hsc_dflags hsc_env) of = case ghcLink (hsc_dflags hsc_env) of
BatchCompile -> return ()
JustTypecheck -> return ()
#ifdef GHCI #ifdef GHCI
Interactive -> Linker.unload (hsc_dflags hsc_env) stable_linkables LinkInMemory -> Linker.unload (hsc_dflags hsc_env) stable_linkables
#else #else
Interactive -> panic "unload: no interpreter" LinkInMemory -> panic "unload: no interpreter"
#endif #endif
other -> panic "unload: strange mode" other -> return ()
-- ----------------------------------------------------------------------------- -- -----------------------------------------------------------------------------
-- checkStability -- checkStability
...@@ -893,9 +891,6 @@ unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables' ...@@ -893,9 +891,6 @@ unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables'
module. So we need to know that we will definitely not be recompiling module. So we need to know that we will definitely not be recompiling
any of these modules, and we can use the object code. any of these modules, and we can use the object code.
NB. stability is of no importance to BatchCompile at all, only Interactive.
(ToDo: what about JustTypecheck?)
The stability check is as follows. Both stableObject and The stability check is as follows. Both stableObject and
stableBCO are used during the upsweep phase later. stableBCO are used during the upsweep phase later.
...@@ -914,7 +909,7 @@ unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables' ...@@ -914,7 +909,7 @@ unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables'
These properties embody the following ideas: These properties embody the following ideas:
- if a module is stable: - if a module is stable, then:
- if it has been compiled in a previous pass (present in HPT) - if it has been compiled in a previous pass (present in HPT)
then it does not need to be compiled or re-linked. then it does not need to be compiled or re-linked.
- if it has not been compiled in a previous pass, - if it has not been compiled in a previous pass,
...@@ -1125,95 +1120,133 @@ upsweep_mod :: HscEnv ...@@ -1125,95 +1120,133 @@ upsweep_mod :: HscEnv
-> IO (Maybe HomeModInfo) -- Nothing => Failed -> IO (Maybe HomeModInfo) -- Nothing => Failed
upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods
= do = let
let this_mod_name = ms_mod_name summary
this_mod_name = ms_mod_name summary
this_mod = ms_mod summary this_mod = ms_mod summary
mb_obj_date = ms_obj_date summary mb_obj_date = ms_obj_date summary
obj_fn = ml_obj_file (ms_location summary) obj_fn = ml_obj_file (ms_location summary)
hs_date = ms_hs_date summary hs_date = ms_hs_date summary
is_stable_obj = this_mod_name `elem` stable_obj
is_stable_bco = this_mod_name `elem` stable_bco
old_hmi = lookupUFM old_hpt this_mod_name
-- We're using the dflags for this module now, obtained by
-- applying any options in its LANGUAGE & OPTIONS_GHC pragmas.
dflags = ms_hspp_opts summary
prevailing_target = hscTarget (hsc_dflags hsc_env)
local_target = hscTarget dflags
-- If OPTIONS_GHC contains -fasm or -fvia-C, be careful that
-- we don't do anything dodgy: these should only work to change
-- from -fvia-C to -fasm and vice-versa, otherwise we could
-- end up trying to link object code to byte code.
target = if prevailing_target /= local_target
&& (not (isObjectTarget prevailing_target)
|| not (isObjectTarget local_target))
then prevailing_target
else local_target
-- store the corrected hscTarget into the summary
summary' = summary{ ms_hspp_opts = dflags { hscTarget = target } }
-- The old interface is ok if
-- a) we're compiling a source file, and the old HPT
-- entry is for a source file
-- b) we're compiling a hs-boot file
-- Case (b) allows an hs-boot file to get the interface of its
-- real source file on the second iteration of the compilation
-- manager, but that does no harm. Otherwise the hs-boot file
-- will always be recompiled
mb_old_iface
= case old_hmi of
Nothing -> Nothing
Just hm_info | isBootSummary summary -> Just iface
| not (mi_boot iface) -> Just iface
| otherwise -> Nothing
where
iface = hm_iface hm_info
compile_it :: Maybe Linkable -> IO (Maybe HomeModInfo) compile_it :: Maybe Linkable -> IO (Maybe HomeModInfo)
compile_it = upsweep_compile hsc_env old_hpt this_mod_name compile_it = upsweep_compile hsc_env old_hpt this_mod_name
summary mod_index nmods summary' mod_index nmods mb_old_iface
case ghcMode (hsc_dflags hsc_env) of compile_it_discard_iface
BatchCompile -> = upsweep_compile hsc_env old_hpt this_mod_name
case () of summary' mod_index nmods Nothing
-- Batch-compilating is easy: just check whether we have
-- an up-to-date object file. If we do, then the compiler in
-- needs to do a recompilation check. case target of
_ | Just obj_date <- mb_obj_date, obj_date >= hs_date -> do
linkable <- _any
findObjectLinkable this_mod obj_fn obj_date -- Regardless of whether we're generating object code or
compile_it (Just linkable) -- byte code, we can always use an existing object file
-- if it is *stable* (see checkStability).
| otherwise -> | is_stable_obj, isJust old_hmi ->
compile_it Nothing return old_hmi
interactive ->
case () of
_ | is_stable_obj, isJust old_hmi ->
return old_hmi
-- object is stable, and we have an entry in the -- object is stable, and we have an entry in the
-- old HPT: nothing to do -- old HPT: nothing to do
| is_stable_obj, isNothing old_hmi -> do | is_stable_obj, isNothing old_hmi -> do
linkable <- linkable <- findObjectLinkable this_mod obj_fn
findObjectLinkable this_mod obj_fn
(expectJust "upseep1" mb_obj_date) (expectJust "upseep1" mb_obj_date)
compile_it (Just linkable) compile_it (Just linkable)
-- object is stable, but we need to load the interface -- object is stable, but we need to load the interface
-- off disk to make a HMI. -- off disk to make a HMI.
| is_stable_bco -> HscInterpreted
ASSERT(isJust old_hmi) -- must be in the old_hpt | is_stable_bco ->
return old_hmi ASSERT(isJust old_hmi) -- must be in the old_hpt
return old_hmi
-- BCO is stable: nothing to do -- BCO is stable: nothing to do
| Just hmi <- old_hmi, | Just hmi <- old_hmi,
Just l <- hm_linkable hmi, not (isObjectLinkable l), Just l <- hm_linkable hmi, not (isObjectLinkable l),
linkableTime l >= ms_hs_date summary -> linkableTime l >= ms_hs_date summary ->
compile_it (Just l) compile_it (Just l)
-- we have an old BCO that is up to date with respect -- we have an old BCO that is up to date with respect
-- to the source: do a recompilation check as normal. -- to the source: do a recompilation check as normal.
| otherwise -> | otherwise ->
compile_it Nothing compile_it Nothing