Add HomeUnit type

Since Backpack the "home unit" is much more involved than what it was
before (just an identifier obtained with `-this-unit-id`). Now it is
used in conjunction with `-component-id` and `-instantiated-with` to
configure module instantiations and to detect if we are type-checking an
indefinite unit or compiling a definite one.

This patch introduces a new HomeUnit datatype which is much easier to
understand. Moreover to make GHC support several packages in the same
instances, we will need to handle several HomeUnits so having a
dedicated (documented) type is helpful.

Finally in #14335 we will also need to handle the case where we have no
HomeUnit at all because we are only loading existing interfaces for
plugins which live in a different space compared to units used to
produce target code. Several functions will have to be refactored to
accept "Maybe HomeUnit" parameters instead of implicitly querying the
HomeUnit fields in DynFlags. Having a dedicated type will make this
easier.

Bump haddock submodule

5 files changed, 32 insertions, 28 deletions

diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs
index d642a15147..8231955063 100644
--- a/compiler/GHC/Tc/Module.hs
+++ b/compiler/GHC/Tc/Module.hs
@@ -110,7 +110,7 @@ import GHC.Utils.Error
 import GHC.Types.Id as Id
 import GHC.Types.Id.Info( IdDetails(..) )
 import GHC.Types.Var.Env
-import GHC.Unit.Module
+import GHC.Unit
 import GHC.Types.Unique.FM
 import GHC.Types.Name
 import GHC.Types.Name.Env
@@ -181,15 +181,14 @@ tcRnModule hsc_env mod_sum save_rn_syntax
   where
     hsc_src = ms_hsc_src mod_sum
     dflags = hsc_dflags hsc_env
-    err_msg = mkPlainErrMsg (hsc_dflags hsc_env) loc $
+    home_unit = mkHomeUnitFromFlags dflags
+    err_msg = mkPlainErrMsg dflags loc $
               text "Module does not have a RealSrcSpan:" <+> ppr this_mod
 
-    this_pkg = homeUnit (hsc_dflags hsc_env)
-
     pair :: (Module, SrcSpan)
     pair@(this_mod,_)
       | Just (L mod_loc mod) <- hsmodName this_module
-      = (mkModule this_pkg mod, mod_loc)
+      = (mkHomeModule home_unit mod, mod_loc)
 
       | otherwise   -- 'module M where' is omitted
       = (mAIN, srcLocSpan (srcSpanStart loc))
@@ -2839,12 +2838,12 @@ loadUnqualIfaces hsc_env ictxt
   = initIfaceTcRn $ do
     mapM_ (loadSysInterface doc) (moduleSetElts (mkModuleSet unqual_mods))
   where
-    this_pkg = homeUnit (hsc_dflags hsc_env)
+    home_unit = mkHomeUnitFromFlags (hsc_dflags hsc_env)
 
     unqual_mods = [ nameModule name
                   | gre <- globalRdrEnvElts (ic_rn_gbl_env ictxt)
                   , let name = gre_name gre
-                  , nameIsFromExternalPackage this_pkg name
+                  , nameIsFromExternalPackage home_unit name
                   , isTcOcc (nameOccName name)   -- Types and classes only
                   , unQualOK gre ]               -- In scope unqualified
     doc = text "Need interface for module whose export(s) are in scope unqualified"
diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs
index ccc23c3930..113fadd20d 100644
--- a/compiler/GHC/Tc/TyCl.hs
+++ b/compiler/GHC/Tc/TyCl.hs
@@ -61,8 +61,7 @@ import GHC.Types.Id
 import GHC.Types.Var
 import GHC.Types.Var.Env
 import GHC.Types.Var.Set
-import GHC.Unit.Module
-import GHC.Unit.State
+import GHC.Unit
 import GHC.Types.Name
 import GHC.Types.Name.Set
 import GHC.Types.Name.Env
@@ -174,8 +173,8 @@ tcTyClGroup (TyClGroup { group_tyclds = tyclds
 
            -- Step 1.5: Make sure we don't have any type synonym cycles
        ; traceTc "Starting synonym cycle check" (ppr tyclss)
-       ; this_uid <- fmap homeUnit getDynFlags
-       ; checkSynCycles this_uid tyclss tyclds
+       ; home_unit <- mkHomeUnitFromFlags <$> getDynFlags
+       ; checkSynCycles (homeUnitAsUnit home_unit) tyclss tyclds
        ; traceTc "Done synonym cycle check" (ppr tyclss)
 
            -- Step 2: Perform the validity check on those types/classes
@@ -4136,7 +4135,7 @@ checkValidDataCon dflags existential_ok tc con
       -- when we actually fill in the abstract type.  As such, don't
       -- warn in this case (it gives users the wrong idea about whether
       -- or not UNPACK on abstract types is supported; it is!)
-      , homeUnitIsDefinite dflags
+      , isHomeUnitDefinite (mkHomeUnitFromFlags dflags)
       = addWarnTc NoReason (bad_bang n (text "Ignoring unusable UNPACK pragma"))
       where
         is_strict = case strict_mark of
diff --git a/compiler/GHC/Tc/Utils/Backpack.hs b/compiler/GHC/Tc/Utils/Backpack.hs
index bddda199a8..5dbc90de86 100644
--- a/compiler/GHC/Tc/Utils/Backpack.hs
+++ b/compiler/GHC/Tc/Utils/Backpack.hs
@@ -21,7 +21,7 @@ module GHC.Tc.Utils.Backpack (
 import GHC.Prelude
 
 import GHC.Types.Basic (defaultFixity, TypeOrKind(..))
-import GHC.Unit.State
+import GHC.Unit
 import GHC.Tc.Gen.Export
 import GHC.Driver.Session
 import GHC.Driver.Ppr
@@ -42,7 +42,6 @@ import GHC.Iface.Load
 import GHC.Rename.Names
 import GHC.Utils.Error
 import GHC.Types.Id
-import GHC.Unit.Module
 import GHC.Types.Name
 import GHC.Types.Name.Env
 import GHC.Types.Name.Set
@@ -312,10 +311,11 @@ implicitRequirements' hsc_env normal_imports
     forM normal_imports $ \(mb_pkg, L _ imp) -> do
         found <- findImportedModule hsc_env imp mb_pkg
         case found of
-            Found _ mod | not (isHomeModule dflags mod) ->
+            Found _ mod | not (isHomeModule home_unit mod) ->
                 return (uniqDSetToList (moduleFreeHoles mod))
             _ -> return []
   where dflags = hsc_dflags hsc_env
+        home_unit = mkHomeUnitFromFlags dflags
 
 -- | Given a 'Unit', make sure it is well typed.  This is because
 -- unit IDs come from Cabal, which does not know if things are well-typed or
@@ -539,6 +539,7 @@ mergeSignatures
         inner_mod = tcg_semantic_mod tcg_env
         mod_name = moduleName (tcg_mod tcg_env)
         pkgstate = unitState dflags
+        home_unit = mkHomeUnitFromFlags dflags
 
     -- STEP 1: Figure out all of the external signature interfaces
     -- we are going to merge in.
@@ -734,7 +735,7 @@ mergeSignatures
     -- STEP 4: Rename the interfaces
     ext_ifaces <- forM thinned_ifaces $ \((Module iuid _), ireq_iface) ->
         tcRnModIface (instUnitInsts iuid) (Just nsubst) ireq_iface
-    lcl_iface <- tcRnModIface (homeUnitInstantiations dflags) (Just nsubst) lcl_iface0
+    lcl_iface <- tcRnModIface (homeUnitInstantiations home_unit) (Just nsubst) lcl_iface0
     let ifaces = lcl_iface : ext_ifaces
 
     -- STEP 4.1: Merge fixities (we'll verify shortly) tcg_fix_env
@@ -756,7 +757,7 @@ mergeSignatures
     let infos = zip ifaces detailss
 
     -- Test for cycles
-    checkSynCycles (homeUnit dflags) (typeEnvTyCons type_env) []
+    checkSynCycles (homeUnitAsUnit home_unit) (typeEnvTyCons type_env) []
 
     -- NB on type_env: it contains NO dfuns.  DFuns are recorded inside
     -- detailss, and given a Name that doesn't correspond to anything real.  See
@@ -1000,16 +1001,17 @@ instantiateSignature = do
     dflags <- getDynFlags
     let outer_mod = tcg_mod tcg_env
         inner_mod = tcg_semantic_mod tcg_env
+        home_unit = mkHomeUnitFromFlags dflags
+        unit_state = unitState dflags
     -- TODO: setup the local RdrEnv so the error messages look a little better.
     -- But this information isn't stored anywhere. Should we RETYPECHECK
     -- the local one just to get the information?  Hmm...
-    MASSERT( isHomeModule dflags outer_mod )
-    MASSERT( isJust (homeUnitInstanceOfId dflags) )
-    let uid  = fromJust (homeUnitInstanceOfId dflags)
+    MASSERT( isHomeModule home_unit outer_mod )
+    MASSERT( isHomeUnitInstantiating home_unit)
         -- we need to fetch the most recent ppr infos from the unit
         -- database because we might have modified it
-        uid' = updateIndefUnitId (unitState dflags) uid
+    let uid = mkIndefUnitId unit_state (homeUnitInstanceOf home_unit)
     inner_mod `checkImplements`
         Module
-            (mkInstantiatedUnit uid' (homeUnitInstantiations dflags))
+            (mkInstantiatedUnit uid (homeUnitInstantiations home_unit))
             (moduleName outer_mod)
diff --git a/compiler/GHC/Tc/Utils/Env.hs b/compiler/GHC/Tc/Utils/Env.hs
index 0b92d7b3d2..ea20808f98 100644
--- a/compiler/GHC/Tc/Utils/Env.hs
+++ b/compiler/GHC/Tc/Utils/Env.hs
@@ -106,6 +106,7 @@ import GHC.Driver.Session
 import GHC.Types.SrcLoc
 import GHC.Types.Basic hiding( SuccessFlag(..) )
 import GHC.Unit.Module
+import GHC.Unit.Home
 import GHC.Utils.Outputable
 import GHC.Utils.Panic
 import GHC.Utils.Encoding
@@ -146,7 +147,8 @@ lookupGlobal_maybe hsc_env name
   = do  {    -- Try local envt
           let mod = icInteractiveModule (hsc_IC hsc_env)
               dflags = hsc_dflags hsc_env
-              tcg_semantic_mod = canonicalizeModuleIfHome dflags mod
+              home_unit = mkHomeUnitFromFlags dflags
+              tcg_semantic_mod = homeModuleInstantiation home_unit mod
 
         ; if nameIsLocalOrFrom tcg_semantic_mod name
               then (return
diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs
index 47e1ab8a9d..abdd670483 100644
--- a/compiler/GHC/Tc/Utils/Monad.hs
+++ b/compiler/GHC/Tc/Utils/Monad.hs
@@ -241,6 +241,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
         th_remote_state_var  <- newIORef Nothing ;
         let {
              dflags = hsc_dflags hsc_env ;
+             home_unit = mkHomeUnitFromFlags dflags ;
 
              maybe_rn_syntax :: forall a. a -> Maybe a ;
              maybe_rn_syntax empty_val
@@ -266,8 +267,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
                 tcg_th_remote_state  = th_remote_state_var,
 
                 tcg_mod            = mod,
-                tcg_semantic_mod   =
-                    canonicalizeModuleIfHome dflags mod,
+                tcg_semantic_mod   = homeModuleInstantiation home_unit mod,
                 tcg_src            = hsc_src,
                 tcg_rdr_env        = emptyGlobalRdrEnv,
                 tcg_fix_env        = emptyNameEnv,
@@ -773,7 +773,9 @@ wrapDocLoc doc = do
 getPrintUnqualified :: DynFlags -> TcRn PrintUnqualified
 getPrintUnqualified dflags
   = do { rdr_env <- getGlobalRdrEnv
-       ; return $ mkPrintUnqualified dflags rdr_env }
+       ; let unit_state = unitState dflags
+       ; let home_unit  = mkHomeUnitFromFlags dflags
+       ; return $ mkPrintUnqualified unit_state home_unit rdr_env }
 
 -- | Like logInfoTcRn, but for user consumption
 printForUserTcRn :: SDoc -> TcRn ()
@@ -1937,10 +1939,10 @@ initIfaceTcRn thing_inside
   = do  { tcg_env <- getGblEnv
         ; dflags <- getDynFlags
         ; let !mod = tcg_semantic_mod tcg_env
+              home_unit = mkHomeUnitFromFlags dflags
               -- When we are instantiating a signature, we DEFINITELY
               -- do not want to knot tie.
-              is_instantiate = homeUnitIsDefinite dflags &&
-                               not (null (homeUnitInstantiations dflags))
+              is_instantiate = isHomeUnitInstantiating home_unit
         ; let { if_env = IfGblEnv {
                             if_doc = text "initIfaceTcRn",
                             if_rec_types =