Commit bfd0a78c authored by Sylvain Henry's avatar Sylvain Henry Committed by Marge Bot

Don't return preload units when we set DyNFlags

Preload units can be retrieved in UnitState when needed (i.e. in GHCi)
parent ac964c83
......@@ -594,10 +594,10 @@ checkBrokenTablesNextToCode' dflags
-- flags. If you are not doing linking or doing static linking, you
-- can ignore the list of packages returned.
--
setSessionDynFlags :: GhcMonad m => DynFlags -> m [UnitId]
setSessionDynFlags :: GhcMonad m => DynFlags -> m ()
setSessionDynFlags dflags = do
dflags' <- checkNewDynFlags dflags
(dflags''', preload) <- liftIO $ initUnits dflags'
dflags''' <- liftIO $ initUnits dflags'
-- Interpreter
interp <- if gopt Opt_ExternalInterpreter dflags
......@@ -637,12 +637,14 @@ setSessionDynFlags dflags = do
-- already one set up
}
invalidateModSummaryCache
return preload
-- | Sets the program 'DynFlags'. Note: this invalidates the internal
-- cached module graph, causing more work to be done the next time
-- 'load' is called.
setProgramDynFlags :: GhcMonad m => DynFlags -> m [UnitId]
--
-- Returns a boolean indicating if preload units have changed and need to be
-- reloaded.
setProgramDynFlags :: GhcMonad m => DynFlags -> m Bool
setProgramDynFlags dflags = setProgramDynFlags_ True dflags
-- | Set the action taken when the compiler produces a message. This
......@@ -654,17 +656,17 @@ setLogAction action = do
void $ setProgramDynFlags_ False $
dflags' { log_action = action }
setProgramDynFlags_ :: GhcMonad m => Bool -> DynFlags -> m [UnitId]
setProgramDynFlags_ :: GhcMonad m => Bool -> DynFlags -> m Bool
setProgramDynFlags_ invalidate_needed dflags = do
dflags' <- checkNewDynFlags dflags
dflags_prev <- getProgramDynFlags
(dflags'', preload) <-
if (packageFlagsChanged dflags_prev dflags')
then liftIO $ initUnits dflags'
else return (dflags', [])
let changed = packageFlagsChanged dflags_prev dflags'
dflags'' <- if changed
then liftIO $ initUnits dflags'
else return dflags'
modifySession $ \h -> h{ hsc_dflags = dflags'' }
when invalidate_needed $ invalidateModSummaryCache
return preload
return changed
-- When changing the DynFlags, we want the changes to apply to future
......
......@@ -203,8 +203,7 @@ withBkpSession cid insts deps session_type do_this = do
} )) $ do
dflags <- getSessionDynFlags
-- pprTrace "flags" (ppr insts <> ppr deps) $ return ()
-- Calls initUnits
_ <- setSessionDynFlags dflags
setSessionDynFlags dflags -- calls initUnits
do_this
withBkpExeSession :: [(Unit, ModRenaming)] -> BkpM a -> BkpM a
......@@ -392,8 +391,7 @@ addPackage pkg = do
{ unitDatabasePath = "(in memory " ++ showSDoc dflags (ppr (unitId pkg)) ++ ")"
, unitDatabaseUnits = [pkg]
}
_ <- GHC.setSessionDynFlags (dflags { unitDatabases = Just (dbs ++ [newdb]) })
return ()
GHC.setSessionDynFlags (dflags { unitDatabases = Just (dbs ++ [newdb]) })
compileInclude :: Int -> (Int, Unit) -> BkpM ()
compileInclude n (i, uid) = do
......
......@@ -69,7 +69,7 @@ doMkDependHS srcs = do
hiSuf = "hi",
objectSuf = "o"
}
_ <- GHC.setSessionDynFlags dflags
GHC.setSessionDynFlags dflags
when (null (depSuffixes dflags)) $ liftIO $
throwGhcExceptionIO (ProgramError "You must specify at least one -dep-suffix")
......
......@@ -183,7 +183,7 @@ showTerm term = do
showPpr dflags bname ++
") :: Prelude.IO Prelude.String"
dl = hsc_dynLinker hsc_env
_ <- GHC.setSessionDynFlags dflags{log_action=noop_log}
GHC.setSessionDynFlags dflags{log_action=noop_log}
txt_ <- withExtendedLinkEnv dl
[(bname, fhv)]
(GHC.compileExprRemote expr)
......
......@@ -572,7 +572,7 @@ listUnitInfo state = Map.elems (unitInfoMap state)
-- 'packageFlags' field of the 'DynFlags', and it will update the
-- 'unitState' in 'DynFlags' and return a list of packages to
-- link in.
initUnits :: DynFlags -> IO (DynFlags, [UnitId])
initUnits :: DynFlags -> IO DynFlags
initUnits dflags = do
let forceUnitInfoMap (state, _) = unitInfoMap state `seq` ()
......@@ -592,7 +592,7 @@ initUnits dflags = do
}
dflags'' = upd_wired_in_home_instantiations dflags'
return (dflags'', preloadUnits state)
return dflags''
-- -----------------------------------------------------------------------------
-- Reading the unit database(s)
......
......@@ -58,7 +58,7 @@ import GHC.Driver.Types ( tyThingParent_maybe, handleFlagWarnings, getSafeMode,
import GHC.Unit.Module
import GHC.Types.Name
import GHC.Unit.State ( unitIsTrusted, unsafeLookupUnit, unsafeLookupUnitId,
listVisibleModuleNames, pprFlag )
listVisibleModuleNames, pprFlag, preloadUnits )
import GHC.Iface.Syntax ( showToHeader )
import GHC.Core.Ppr.TyThing
import GHC.Builtin.Names
......@@ -2934,7 +2934,7 @@ newDynFlags interactive_only minus_opts = do
when (not interactive_only) $ do
(dflags1, _, _) <- liftIO $ GHC.parseDynamicFlags dflags0 lopts
new_pkgs <- GHC.setProgramDynFlags dflags1
must_reload <- GHC.setProgramDynFlags dflags1
-- if the package flags changed, reset the context and link
-- the new packages.
......@@ -2946,7 +2946,9 @@ newDynFlags interactive_only minus_opts = do
"package flags have changed, resetting and loading new packages..."
-- delete targets and all eventually defined breakpoints. (#1620)
clearAllTargets
liftIO $ linkPackages hsc_env new_pkgs
when must_reload $ do
let units = preloadUnits (unitState dflags2)
liftIO $ linkPackages hsc_env units
-- package flags changed, we can't re-use any of the old context
setContextAfterLoad False []
-- and copy the package state to the interactive DynFlags
......
module LinkerUnload (init) where
import GHC
import GHC.Unit.State
import GHC.Driver.Session
import GHC.Runtime.Linker as Linker
import System.Environment
......@@ -15,6 +16,6 @@ loadPackages = do
dflags <- getSessionDynFlags
let dflags' = dflags { hscTarget = HscNothing
, ghcLink = LinkInMemory }
pkgs <- setSessionDynFlags dflags'
setSessionDynFlags dflags'
hsc_env <- getSession
liftIO $ Linker.linkPackages hsc_env pkgs
liftIO $ Linker.linkPackages hsc_env (preloadUnits (unitState dflags'))
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