[Git][ghc/ghc][master] Don't store HomeUnit in UnitConfig

[Marge Bot]

 Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC


Commits:
bcb68a3f by Sylvain Henry at 2020-08-31T23:03:27-04:00
Don't store HomeUnit in UnitConfig

Allow the creation of a UnitConfig (hence of a UnitState) without having
a HomeUnit. It's required for #14335.

- - - - -


1 changed file:

- compiler/GHC/Unit/State.hs


Changes:

=====================================
compiler/GHC/Unit/State.hs
=====================================
@@ -315,7 +315,12 @@ instance Monoid UnitVisibility where
 data UnitConfig = UnitConfig
    { unitConfigPlatformArchOS :: !ArchOS        -- ^ Platform arch and OS
    , unitConfigWays           :: !Ways          -- ^ Ways to use
-   , unitConfigHomeUnit       :: !HomeUnit      -- ^ Home unit
+
+   , unitConfigAllowVirtual   :: !Bool          -- ^ Allow virtual units
+      -- ^ Do we allow the use of virtual units instantiated on-the-fly (see Note
+      -- [About units] in GHC.Unit). This should only be true when we are
+      -- type-checking an indefinite unit (not producing any code).
+
    , unitConfigProgramName    :: !String
       -- ^ Name of the compiler (e.g. "GHC", "GHCJS"). Used to fetch environment
       -- variables such as "GHC[JS]_PACKAGE_PATH".
@@ -344,18 +349,28 @@ data UnitConfig = UnitConfig
 
 initUnitConfig :: DynFlags -> UnitConfig
 initUnitConfig dflags =
-   let home_unit = mkHomeUnitFromFlags dflags
+   let !hu_id             = homeUnitId_ dflags
+       !hu_instanceof     = homeUnitInstanceOf_ dflags
+       !hu_instantiations = homeUnitInstantiations_ dflags
+
        autoLink
          | not (gopt Opt_AutoLinkPackages dflags) = []
          -- By default we add base & rts to the preload units (when they are
          -- found in the unit database) except when we are building them
-         | otherwise = filter (not . isHomeUnitId home_unit) [baseUnitId, rtsUnitId]
+         | otherwise = filter (hu_id /=) [baseUnitId, rtsUnitId]
+
+       -- if the home unit is indefinite, it means we are type-checking it only
+       -- (not producing any code). Hence we can use virtual units instantiated
+       -- on-the-fly. See Note [About units] in GHC.Unit
+       allow_virtual_units = case (hu_instanceof, hu_instantiations) of
+            (Just u, is) -> u == hu_id && any (isHoleModule . snd) is
+            _            -> False
 
    in UnitConfig
       { unitConfigPlatformArchOS = platformArchOS (targetPlatform dflags)
       , unitConfigProgramName    = programName dflags
       , unitConfigWays           = ways dflags
-      , unitConfigHomeUnit       = home_unit
+      , unitConfigAllowVirtual   = allow_virtual_units
 
       , unitConfigGlobalDB       = globalPackageDatabasePath dflags
       , unitConfigGHCDir         = topDir dflags
@@ -1624,24 +1639,14 @@ mkUnitState ctx printer cfg = do
          , wireMap                      = wired_map
          , unwireMap                    = Map.fromList [ (v,k) | (k,v) <- Map.toList wired_map ]
          , requirementContext           = req_ctx
-         , allowVirtualUnits            = unitConfigAllowVirtualUnits cfg
+         , allowVirtualUnits            = unitConfigAllowVirtual cfg
          }
 
   return (state, raw_dbs)
 
--- | Do we allow the use of virtual units instantiated on-the-fly (see Note
--- [About units] in GHC.Unit). This should only be true when we are
--- type-checking an indefinite unit (not producing any code).
-unitConfigAllowVirtualUnits :: UnitConfig -> Bool
-unitConfigAllowVirtualUnits cfg =
-   -- when the home unit is indefinite, it means we are type-checking it only
-   -- (not producing any code). Hence we can use virtual units instantiated
-   -- on-the-fly (see Note [About units] in GHC.Unit)
-   isHomeUnitIndefinite (unitConfigHomeUnit cfg)
-
 -- | Given a wired-in 'Unit', "unwire" it into the 'Unit'
 -- that it was recorded as in the package database.
-unwireUnit :: UnitState -> Unit-> Unit
+unwireUnit :: UnitState -> Unit -> Unit
 unwireUnit state uid@(RealUnit (Definite def_uid)) =
     maybe uid (RealUnit . Definite) (Map.lookup def_uid (unwireMap state))
 unwireUnit _ uid = uid
@@ -1733,7 +1738,7 @@ mkModuleNameProvidersMap ctx cfg pkg_map closure vis_map =
     hiddens = [(m, mkModMap pk m ModHidden) | m <- hidden_mods]
 
     pk = mkUnit pkg
-    unit_lookup uid = lookupUnit' (unitConfigAllowVirtualUnits cfg) pkg_map closure uid
+    unit_lookup uid = lookupUnit' (unitConfigAllowVirtual cfg) pkg_map closure uid
                         `orElse` pprPanic "unit_lookup" (ppr uid)
 
     exposed_mods = unitExposedModules pkg



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bcb68a3f7f85b9fdef6f4845e608d086b01e6a58

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bcb68a3f7f85b9fdef6f4845e608d086b01e6a58
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200831/8af04cb0/attachment-0001.html>