Avoid timing module map dump in initUnits

1 files changed, 24 insertions, 18 deletions

diff --git a/compiler/GHC/Unit/State.hs b/compiler/GHC/Unit/State.hs
index 537e375f9a..8d16f114d3 100644
--- a/compiler/GHC/Unit/State.hs
+++ b/compiler/GHC/Unit/State.hs
@@ -500,39 +500,45 @@ listUnitInfo state = Map.elems (unitInfoMap state)
 -- 'unitState' in 'DynFlags' and return a list of packages to
 -- link in.
 initUnits :: DynFlags -> IO (DynFlags, [UnitId])
-initUnits dflags = withTiming dflags
-                                  (text "initializing package database")
-                                  forcePkgDb $ do
-  read_pkg_dbs <-
-    case unitDatabases dflags of
-        Nothing  -> readUnitDatabases dflags
-        Just dbs -> return dbs
-
-  let
-      distrust_all db = db { unitDatabaseUnits = distrustAllUnits (unitDatabaseUnits db) }
+initUnits dflags = do
+
+  let forcePkgDb (state, _, _) = unitInfoMap state `seq` ()
+  (state,preload,raw_dbs) <- withTiming dflags
+                                (text "initializing package database")
+                                forcePkgDb $ do
+
+    -- read the databases if they have not been already read
+    raw_dbs <- case unitDatabases dflags of
+          Nothing  -> readUnitDatabases dflags
+          Just dbs -> return dbs
+
+    -- distrust all units if the flag is set
+    let distrust_all db = db { unitDatabaseUnits = distrustAllUnits (unitDatabaseUnits db) }
+        dbs
+           | gopt Opt_DistrustAllPackages dflags
+           = map distrust_all raw_dbs
+           | otherwise
+           = raw_dbs
 
-      pkg_dbs
-         | gopt Opt_DistrustAllPackages dflags = map distrust_all read_pkg_dbs
-         | otherwise                           = read_pkg_dbs
+    -- create the UnitState
+    (state,preload) <- mkUnitState dflags dbs []
 
-  (state, preload) <- mkUnitState dflags pkg_dbs []
+    return (state, preload, raw_dbs)
 
   dumpIfSet_dyn (dflags { pprCols = 200 }) Opt_D_dump_mod_map "Mod Map"
     FormatText
     (pprModuleMap (moduleNameProvidersMap state))
 
   -- Some wired units can be used to instantiate the home unit. We need to
-  -- replace their unit key by their wired unit id.
+  -- replace their unit keys by their wired unit ids.
   let wiringMap    = wireMap state
       unwiredInsts = homeUnitInstantiations dflags
       wiredInsts   = map (fmap (upd_wired_in_mod wiringMap)) unwiredInsts
 
-  return (dflags{ unitDatabases          = Just read_pkg_dbs,
+  return (dflags{ unitDatabases          = Just raw_dbs,
                   unitState              = state,
                   homeUnitInstantiations = wiredInsts },
           preload)
-  where
-    forcePkgDb (dflags, _) = unitInfoMap (unitState dflags) `seq` ()
 
 -- -----------------------------------------------------------------------------
 -- Reading the unit database(s)