Don't return preload units when we set DyNFlags

Preload units can be retrieved in UnitState when needed (i.e. in GHCi)

7 files changed, 26 insertions, 23 deletions

diff --git a/compiler/GHC.hs b/compiler/GHC.hs
index 9f9f2ad758..b619f0c14c 100644
--- a/compiler/GHC.hs
+++ b/compiler/GHC.hs
@@ -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
diff --git a/compiler/GHC/Driver/Backpack.hs b/compiler/GHC/Driver/Backpack.hs
index 95005b405e..f798051a56 100644
--- a/compiler/GHC/Driver/Backpack.hs
+++ b/compiler/GHC/Driver/Backpack.hs
@@ -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
diff --git a/compiler/GHC/Driver/MakeFile.hs b/compiler/GHC/Driver/MakeFile.hs
index 6a50ec483f..78d030b6dd 100644
--- a/compiler/GHC/Driver/MakeFile.hs
+++ b/compiler/GHC/Driver/MakeFile.hs
@@ -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")
diff --git a/compiler/GHC/Runtime/Debugger.hs b/compiler/GHC/Runtime/Debugger.hs
index 93869b35dd..5f7ff50347 100644
--- a/compiler/GHC/Runtime/Debugger.hs
+++ b/compiler/GHC/Runtime/Debugger.hs
@@ -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)
diff --git a/compiler/GHC/Unit/State.hs b/compiler/GHC/Unit/State.hs
index 07752cb98d..c4e2d0673a 100644
--- a/compiler/GHC/Unit/State.hs
+++ b/compiler/GHC/Unit/State.hs
@@ -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)
diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs
index dc02f68544..363d959598 100644
--- a/ghc/GHCi/UI.hs
+++ b/ghc/GHCi/UI.hs
@@ -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
diff --git a/testsuite/tests/rts/linker/LinkerUnload.hs b/testsuite/tests/rts/linker/LinkerUnload.hs
index af71cadfac..7d83508400 100644
--- a/testsuite/tests/rts/linker/LinkerUnload.hs
+++ b/testsuite/tests/rts/linker/LinkerUnload.hs
@@ -1,6 +1,7 @@
 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'))