diff options
author | Sylvain Henry <sylvain@haskus.fr> | 2020-05-07 18:03:36 +0200 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2020-06-13 02:13:02 -0400 |
commit | 72d086106d49bc18277f3a066e671e87e9b37a1b (patch) | |
tree | ff20c2926d4234c2cecc5d230859fc9fce09bb85 /compiler | |
parent | 7a02599afe836ac32c2e732671415d0afdfbf7fb (diff) | |
download | haskell-72d086106d49bc18277f3a066e671e87e9b37a1b.tar.gz |
Refactor homeUnit
* rename thisPackage into homeUnit
* document and refactor several Backpack things
Diffstat (limited to 'compiler')
29 files changed, 160 insertions, 156 deletions
diff --git a/compiler/GHC.hs b/compiler/GHC.hs index 442fd0a323..f95c61ace5 100644 --- a/compiler/GHC.hs +++ b/compiler/GHC.hs @@ -1489,7 +1489,7 @@ findModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module findModule mod_name maybe_pkg = withSession $ \hsc_env -> do let dflags = hsc_dflags hsc_env - this_pkg = thisPackage dflags + this_pkg = homeUnit dflags -- case maybe_pkg of Just pkg | fsToUnit pkg /= this_pkg && pkg /= fsLit "this" -> liftIO $ do diff --git a/compiler/GHC/Cmm/Parser.y b/compiler/GHC/Cmm/Parser.y index 630c20e125..eb1ccae3c6 100644 --- a/compiler/GHC/Cmm/Parser.y +++ b/compiler/GHC/Cmm/Parser.y @@ -377,7 +377,7 @@ cmmtop :: { CmmParse () } | cmmdata { $1 } | decl { $1 } | 'CLOSURE' '(' NAME ',' NAME lits ')' ';' - {% liftP . withThisPackage $ \pkg -> + {% liftP . withHomeUnit $ \pkg -> do lits <- sequence $6; staticClosure pkg $3 $5 (map getLit lits) } @@ -398,7 +398,7 @@ cmmdata :: { CmmParse () } data_label :: { CmmParse CLabel } : NAME ':' - {% liftP . withThisPackage $ \pkg -> + {% liftP . withHomeUnit $ \pkg -> return (mkCmmDataLabel pkg $1) } statics :: { [CmmParse [CmmStatic]] } @@ -455,14 +455,14 @@ maybe_body :: { CmmParse () } info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) } : NAME - {% liftP . withThisPackage $ \pkg -> + {% liftP . withHomeUnit $ \pkg -> do newFunctionName $1 pkg return (mkCmmCodeLabel pkg $1, Nothing, []) } | 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')' -- ptrs, nptrs, closure type, description, type - {% liftP . withThisPackage $ \pkg -> + {% liftP . withHomeUnit $ \pkg -> do dflags <- getDynFlags let prof = profilingInfo dflags $11 $13 rep = mkRTSRep (fromIntegral $9) $ @@ -478,7 +478,7 @@ info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) } | 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')' -- ptrs, nptrs, closure type, description, type, fun type - {% liftP . withThisPackage $ \pkg -> + {% liftP . withHomeUnit $ \pkg -> do dflags <- getDynFlags let prof = profilingInfo dflags $11 $13 ty = Fun 0 (ArgSpec (fromIntegral $15)) @@ -496,7 +496,7 @@ info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) } | 'INFO_TABLE_CONSTR' '(' NAME ',' INT ',' INT ',' INT ',' INT ',' STRING ',' STRING ')' -- ptrs, nptrs, tag, closure type, description, type - {% liftP . withThisPackage $ \pkg -> + {% liftP . withHomeUnit $ \pkg -> do dflags <- getDynFlags let prof = profilingInfo dflags $13 $15 ty = Constr (fromIntegral $9) -- Tag @@ -515,7 +515,7 @@ info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) } | 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')' -- selector, closure type, description, type - {% liftP . withThisPackage $ \pkg -> + {% liftP . withHomeUnit $ \pkg -> do dflags <- getDynFlags let prof = profilingInfo dflags $9 $11 ty = ThunkSelector (fromIntegral $5) @@ -529,7 +529,7 @@ info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) } | 'INFO_TABLE_RET' '(' NAME ',' INT ')' -- closure type (no live regs) - {% liftP . withThisPackage $ \pkg -> + {% liftP . withHomeUnit $ \pkg -> do let prof = NoProfilingInfo rep = mkRTSRep (fromIntegral $5) $ mkStackRep [] return (mkCmmRetLabel pkg $3, @@ -540,7 +540,7 @@ info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) } | 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals0 ')' -- closure type, live regs - {% liftP . withThisPackage $ \pkg -> + {% liftP . withHomeUnit $ \pkg -> do dflags <- getDynFlags let platform = targetPlatform dflags live <- sequence $7 diff --git a/compiler/GHC/CmmToAsm/Monad.hs b/compiler/GHC/CmmToAsm/Monad.hs index f1890fe02c..9310c6073a 100644 --- a/compiler/GHC/CmmToAsm/Monad.hs +++ b/compiler/GHC/CmmToAsm/Monad.hs @@ -149,7 +149,7 @@ mkNatM_State us delta dflags this_mod initConfig :: DynFlags -> NCGConfig initConfig dflags = NCGConfig { ncgPlatform = targetPlatform dflags - , ncgUnitId = thisPackage dflags + , ncgUnitId = homeUnit dflags , ncgProcAlignment = cmmProcAlignment dflags , ncgDebugLevel = debugLevel dflags , ncgExternalDynamicRefs = gopt Opt_ExternalDynamicRefs dflags diff --git a/compiler/GHC/CoreToStg/Prep.hs b/compiler/GHC/CoreToStg/Prep.hs index 7420475813..cc408ca46f 100644 --- a/compiler/GHC/CoreToStg/Prep.hs +++ b/compiler/GHC/CoreToStg/Prep.hs @@ -1556,9 +1556,9 @@ lookupNaturalSDataConName dflags hsc_env = case integerLibrary dflags of -- | Helper for 'lookupMkIntegerName', 'lookupIntegerSDataConName' guardIntegerUse :: DynFlags -> IO a -> IO a guardIntegerUse dflags act - | thisPackage dflags == primUnitId + | homeUnit dflags == primUnitId = return $ panic "Can't use Integer in ghc-prim" - | thisPackage dflags == integerUnitId + | homeUnit dflags == integerUnitId = return $ panic "Can't use Integer in integer-*" | otherwise = act @@ -1568,11 +1568,11 @@ guardIntegerUse dflags act -- literals in `base`. If we do, we get interface loading error for GHC.Natural. guardNaturalUse :: DynFlags -> IO a -> IO a guardNaturalUse dflags act - | thisPackage dflags == primUnitId + | homeUnit dflags == primUnitId = return $ panic "Can't use Natural in ghc-prim" - | thisPackage dflags == integerUnitId + | homeUnit dflags == integerUnitId = return $ panic "Can't use Natural in integer-*" - | thisPackage dflags == baseUnitId + | homeUnit dflags == baseUnitId = return $ panic "Can't use Natural in base" | otherwise = act diff --git a/compiler/GHC/Driver/Backpack.hs b/compiler/GHC/Driver/Backpack.hs index 5d5be6c1ff..177a601425 100644 --- a/compiler/GHC/Driver/Backpack.hs +++ b/compiler/GHC/Driver/Backpack.hs @@ -171,9 +171,12 @@ withBkpSession cid insts deps session_type do_this = do hscTarget = case session_type of TcSession -> HscNothing _ -> hscTarget dflags, - thisUnitIdInsts_ = Just insts, - thisComponentId_ = Just cid, - thisUnitId = + homeUnitInstantiations = insts, + -- if we don't have any instantiation, don't + -- fill `homeUnitInstanceOfId` as it makes no + -- sense (we're not instantiating anything) + homeUnitInstanceOfId = if null insts then Nothing else Just cid, + homeUnitId = case session_type of TcSession -> newUnitId cid Nothing -- No hash passed if no instances @@ -312,7 +315,7 @@ buildUnit session cid insts lunit = do unitPackageId = PackageId compat_fs, unitPackageName = compat_pn, unitPackageVersion = makeVersion [], - unitId = toUnitId (thisPackage dflags), + unitId = toUnitId (homeUnit dflags), unitComponentName = Nothing, unitInstanceOf = cid, unitInstantiations = insts, @@ -652,7 +655,7 @@ hsunitModuleGraph dflags unit = do -- requirement. let node_map = Map.fromList [ ((ms_mod_name n, ms_hsc_src n == HsigFile), n) | n <- nodes ] - req_nodes <- fmap catMaybes . forM (thisUnitIdInsts dflags) $ \(mod_name, _) -> + req_nodes <- fmap catMaybes . forM (homeUnitInstantiations dflags) $ \(mod_name, _) -> let has_local = Map.member (mod_name, True) node_map in if has_local then return Nothing diff --git a/compiler/GHC/Driver/Finder.hs b/compiler/GHC/Driver/Finder.hs index da59c6f611..6a7b9eb3ee 100644 --- a/compiler/GHC/Driver/Finder.hs +++ b/compiler/GHC/Driver/Finder.hs @@ -74,7 +74,7 @@ flushFinderCaches :: HscEnv -> IO () flushFinderCaches hsc_env = atomicModifyIORef' fc_ref $ \fm -> (filterInstalledModuleEnv is_ext fm, ()) where - this_pkg = thisPackage (hsc_dflags hsc_env) + this_pkg = homeUnit (hsc_dflags hsc_env) fc_ref = hsc_FC hsc_env is_ext mod _ | not (moduleUnit mod `unitIdEq` this_pkg) = True | otherwise = False @@ -135,7 +135,7 @@ findPluginModule hsc_env mod_name = findExactModule :: HscEnv -> InstalledModule -> IO InstalledFindResult findExactModule hsc_env mod = let dflags = hsc_dflags hsc_env - in if moduleUnit mod `unitIdEq` thisPackage dflags + in if moduleUnit mod `unitIdEq` homeUnit dflags then findInstalledHomeModule hsc_env (moduleName mod) else findPackageModule hsc_env mod @@ -245,7 +245,7 @@ modLocationCache hsc_env mod do_this = do mkHomeInstalledModule :: DynFlags -> ModuleName -> InstalledModule mkHomeInstalledModule dflags mod_name = - let iuid = thisUnitId dflags + let iuid = homeUnitId dflags in Module iuid mod_name -- This returns a module because it's more convenient for users @@ -253,7 +253,7 @@ addHomeModuleToFinder :: HscEnv -> ModuleName -> ModLocation -> IO Module addHomeModuleToFinder hsc_env mod_name loc = do let mod = mkHomeInstalledModule (hsc_dflags hsc_env) mod_name addToFinderCache (hsc_FC hsc_env) mod (InstalledFound loc mod) - return (mkModule (thisPackage (hsc_dflags hsc_env)) mod_name) + return (mkHomeModule (hsc_dflags hsc_env) mod_name) uncacheModule :: HscEnv -> ModuleName -> IO () uncacheModule hsc_env mod_name = do @@ -279,7 +279,7 @@ findHomeModule hsc_env mod_name = do } where dflags = hsc_dflags hsc_env - uid = thisPackage dflags + uid = homeUnit dflags -- | Implements the search for a module name in the home package only. Calling -- this function directly is usually *not* what you want; currently, it's used @@ -678,7 +678,7 @@ cantFindErr cannot_find _ dflags mod_name find_result NotFound { fr_paths = files, fr_pkg = mb_pkg , fr_mods_hidden = mod_hiddens, fr_pkgs_hidden = pkg_hiddens , fr_unusables = unusables, fr_suggestions = suggest } - | Just pkg <- mb_pkg, pkg /= thisPackage dflags + | Just pkg <- mb_pkg, pkg /= homeUnit dflags -> not_found_in_package pkg files | not (null suggest) @@ -794,7 +794,7 @@ cantFindInstalledErr cannot_find _ dflags mod_name find_result text "was found" $$ looks_like_srcpkgid pkg InstalledNotFound files mb_pkg - | Just pkg <- mb_pkg, not (pkg `unitIdEq` thisPackage dflags) + | Just pkg <- mb_pkg, not (pkg `unitIdEq` homeUnit dflags) -> not_found_in_package pkg files | null files diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs index b850502a8c..ebc822aac5 100644 --- a/compiler/GHC/Driver/Main.hs +++ b/compiler/GHC/Driver/Main.hs @@ -470,12 +470,12 @@ hsc_typecheck keep_rn mod_summary mb_rdr_module = do dflags = hsc_dflags hsc_env outer_mod = ms_mod mod_summary mod_name = moduleName outer_mod - outer_mod' = mkModule (thisPackage dflags) mod_name + outer_mod' = mkHomeModule dflags mod_name inner_mod = canonicalizeHomeModule dflags mod_name src_filename = ms_hspp_file mod_summary real_loc = realSrcLocSpan $ mkRealSrcLoc (mkFastString src_filename) 1 1 keep_rn' = gopt Opt_WriteHie dflags || keep_rn - MASSERT( moduleUnit outer_mod == thisPackage dflags ) + MASSERT( isHomeModule dflags outer_mod ) tc_result <- if hsc_src == HsigFile && not (isHoleModule inner_mod) then ioMsgMaybe $ tcRnInstantiateSignature hsc_env outer_mod' real_loc else @@ -1116,8 +1116,8 @@ hscCheckSafe' m l = do dflags <- getDynFlags (tw, pkgs) <- isModSafe m l case tw of - False -> return (Nothing, pkgs) - True | isHomePkg dflags m -> return (Nothing, pkgs) + False -> return (Nothing, pkgs) + True | isHomeModule dflags m -> return (Nothing, pkgs) -- TODO: do we also have to check the trust of the instantiation? -- Not necessary if that is reflected in dependencies | otherwise -> return (Just $ toUnitId (moduleUnit m), pkgs) @@ -1191,7 +1191,7 @@ hscCheckSafe' m l = do packageTrusted _ Sf_Safe False _ = True packageTrusted _ Sf_SafeInferred False _ = True packageTrusted dflags _ _ m - | isHomePkg dflags m = True + | isHomeModule dflags m = True | otherwise = unitIsTrusted $ unsafeGetUnitInfo dflags (moduleUnit m) lookup' :: Module -> Hsc (Maybe ModIface) @@ -1210,11 +1210,6 @@ hscCheckSafe' m l = do return iface' - isHomePkg :: DynFlags -> Module -> Bool - isHomePkg dflags m - | thisPackage dflags == moduleUnit m = True - | otherwise = False - -- | Check the list of packages are trusted. checkPkgTrust :: Set UnitId -> Hsc () checkPkgTrust pkgs = do @@ -1493,7 +1488,7 @@ hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do let -- Make up a module name to give the NCG. We can't pass bottom here -- lest we reproduce #11784. mod_name = mkModuleName $ "Cmm$" ++ FilePath.takeFileName filename - cmm_mod = mkModule (thisPackage dflags) mod_name + cmm_mod = mkHomeModule dflags mod_name -- Compile decls in Cmm files one decl at a time, to avoid re-ordering -- them in SRT analysis. diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs index a3d2c0b1bb..c34df2c589 100644 --- a/compiler/GHC/Driver/Make.hs +++ b/compiler/GHC/Driver/Make.hs @@ -656,7 +656,7 @@ discardIC hsc_env | nameIsFromExternalPackage this_pkg old_name = old_name | otherwise = ic_name empty_ic where - this_pkg = thisPackage dflags + this_pkg = homeUnit dflags old_name = ic_name old_ic -- | If there is no -o option, guess the name of target executable @@ -1200,7 +1200,7 @@ parUpsweep_one mod home_mod_map comp_graph_loops lcl_dflags mHscMessage cleanup zipWith f home_imps (repeat NotBoot) ++ zipWith f home_src_imps (repeat IsBoot) where f mn isBoot = GWIB - { gwib_mod = mkModule (thisPackage lcl_dflags) mn + { gwib_mod = mkHomeModule lcl_dflags mn , gwib_isBoot = isBoot } @@ -2213,7 +2213,7 @@ enableCodeGenForTH = hscTarget dflags == HscNothing && -- Don't enable codegen for TH on indefinite packages; we -- can't compile anything anyway! See #16219. - not (isIndefinite dflags) + homeUnitIsDefinite dflags -- | Update the every ModSummary that is depended on -- by a module that needs unboxed tuples. We enable codegen to @@ -2560,12 +2560,12 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) $$ text "Saw:" <+> quotes (ppr pi_mod_name) $$ text "Expected:" <+> quotes (ppr wanted_mod) - when (hsc_src == HsigFile && isNothing (lookup pi_mod_name (thisUnitIdInsts dflags))) $ + when (hsc_src == HsigFile && isNothing (lookup pi_mod_name (homeUnitInstantiations dflags))) $ let suggested_instantiated_with = hcat (punctuate comma $ [ ppr k <> text "=" <> ppr v | (k,v) <- ((pi_mod_name, mkHoleModule pi_mod_name) - : thisUnitIdInsts dflags) + : homeUnitInstantiations dflags) ]) in throwE $ unitBag $ mkPlainErrMsg pi_local_dflags pi_mod_name_loc $ text "Unexpected signature:" <+> quotes (ppr pi_mod_name) diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs index 5d39436f3b..fa9527b74e 100644 --- a/compiler/GHC/Driver/Pipeline.hs +++ b/compiler/GHC/Driver/Pipeline.hs @@ -379,7 +379,7 @@ compileEmptyStub dflags hsc_env basename location mod_name = do -- https://gitlab.haskell.org/ghc/ghc/issues/12673 -- and https://github.com/haskell/cabal/issues/2257 empty_stub <- newTempName dflags TFL_CurrentModule "c" - let src = text "int" <+> ppr (mkModule (thisPackage dflags) mod_name) <+> text "= 0;" + let src = text "int" <+> ppr (mkHomeModule dflags mod_name) <+> text "= 0;" writeFile empty_stub (showSDoc dflags (pprCode CStyle src)) _ <- runPipeline StopLn hsc_env (empty_stub, Nothing, Nothing) @@ -1312,7 +1312,7 @@ runPhase (RealPhase cc_phase) input_fn dflags -- way we do the import depends on whether we're currently compiling -- the base package or not. ++ (if platformOS platform == OSMinGW32 && - thisPackage dflags == baseUnitId + homeUnit dflags == baseUnitId then [ "-DCOMPILING_BASE_PACKAGE" ] else []) diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs index 04fcfb2d0c..694874a179 100644 --- a/compiler/GHC/Driver/Session.hs +++ b/compiler/GHC/Driver/Session.hs @@ -66,7 +66,7 @@ module GHC.Driver.Session ( addWay', updateWays, - thisPackage, thisComponentId, thisUnitIdInsts, + homeUnit, mkHomeModule, isHomeModule, -- ** Log output putLogMsg, @@ -254,7 +254,7 @@ import GHC.Unit.Module import {-# SOURCE #-} GHC.Driver.Plugins import {-# SOURCE #-} GHC.Driver.Hooks import GHC.Builtin.Names ( mAIN ) -import {-# SOURCE #-} GHC.Unit.State (PackageState, emptyPackageState, PackageDatabase, mkIndefUnitId, updateIndefUnitId) +import {-# SOURCE #-} GHC.Unit.State (PackageState, emptyPackageState, PackageDatabase, updateIndefUnitId) import GHC.Driver.Phases ( Phase(..), phaseInputExt ) import GHC.Driver.Flags import GHC.Driver.Ways @@ -528,9 +528,9 @@ data DynFlags = DynFlags { solverIterations :: IntWithInf, -- ^ Number of iterations in the constraints solver -- Typically only 1 is needed - thisUnitId :: UnitId, -- ^ Target unit-id - thisComponentId_ :: Maybe IndefUnitId, -- ^ Unit-id to instantiate - thisUnitIdInsts_ :: Maybe [(ModuleName, Module)], -- ^ How to instantiate the unit-id above + homeUnitId :: UnitId, -- ^ Target home unit-id + homeUnitInstanceOfId :: Maybe IndefUnitId, -- ^ Unit-id to instantiate + homeUnitInstantiations:: [(ModuleName, Module)], -- ^ How to instantiate `homeUnitInstanceOfId` unit -- ways ways :: Set Way, -- ^ Way flags from the command line @@ -1329,9 +1329,9 @@ defaultDynFlags mySettings llvmConfig = reductionDepth = treatZeroAsInf mAX_REDUCTION_DEPTH, solverIterations = treatZeroAsInf mAX_SOLVER_ITERATIONS, - thisUnitId = toUnitId mainUnitId, - thisUnitIdInsts_ = Nothing, - thisComponentId_ = Nothing, + homeUnitId = toUnitId mainUnitId, + homeUnitInstanceOfId = Nothing, + homeUnitInstantiations = [], objectDir = Nothing, dylibInstallName = Nothing, @@ -1961,34 +1961,31 @@ setOutputHi f d = d { outputHi = f} setJsonLogAction :: DynFlags -> DynFlags setJsonLogAction d = d { log_action = jsonLogAction } -thisComponentId :: DynFlags -> IndefUnitId -thisComponentId dflags = - let pkgstate = pkgState dflags - in case thisComponentId_ dflags of - Just uid -> updateIndefUnitId pkgstate uid - Nothing -> - case thisUnitIdInsts_ dflags of - Just _ -> - throwGhcException $ CmdLineError ("Use of -instantiated-with requires -this-component-id") - Nothing -> mkIndefUnitId pkgstate (unitFS (thisPackage dflags)) - -thisUnitIdInsts :: DynFlags -> [(ModuleName, Module)] -thisUnitIdInsts dflags = - case thisUnitIdInsts_ dflags of - Just insts -> insts - Nothing -> [] - -thisPackage :: DynFlags -> Unit -thisPackage dflags = - case thisUnitIdInsts_ dflags of - Nothing -> default_uid - Just insts - | all (\(x,y) -> mkHoleModule x == y) insts - -> mkVirtUnit (thisComponentId dflags) insts - | otherwise - -> default_uid - where - default_uid = RealUnit (Definite (thisUnitId dflags)) +-- | Make a module in home unit +mkHomeModule :: DynFlags -> ModuleName -> Module +mkHomeModule dflags = mkModule (homeUnit dflags) + +-- | Test if the module comes from the home unit +isHomeModule :: DynFlags -> Module -> Bool +isHomeModule dflags m = moduleUnit m == homeUnit dflags + +-- | Get home unit +homeUnit :: DynFlags -> Unit +homeUnit dflags = + case (homeUnitInstanceOfId dflags, homeUnitInstantiations dflags) of + (Nothing,[]) -> RealUnit (Definite (homeUnitId dflags)) + (Nothing, _) -> throwGhcException $ CmdLineError ("Use of -instantiated-with requires -this-component-id") + (Just _, []) -> throwGhcException $ CmdLineError ("Use of -this-component-id requires -instantiated-with") + (Just u, is) + -- detect fully indefinite units: all their instantiations are hole + -- modules and the home unit id is the same as the instantiating unit + -- id (see Note [About units] in GHC.Unit) + | all (isHoleModule . snd) is && u == homeUnitId dflags + -> mkVirtUnit (updateIndefUnitId (pkgState dflags) u) is + -- otherwise it must be that we compile a fully definite units + -- TODO: error when the unit is partially instantiated?? + | otherwise + -> RealUnit (Definite (homeUnitId dflags)) parseUnitInsts :: String -> Instantiations parseUnitInsts str = case filter ((=="").snd) (readP_to_S parse str) of @@ -2001,13 +1998,13 @@ parseUnitInsts str = case filter ((=="").snd) (readP_to_S parse str) of m <- parseHoleyModule return (n, m) -setUnitIdInsts :: String -> DynFlags -> DynFlags -setUnitIdInsts s d = - d { thisUnitIdInsts_ = Just (parseUnitInsts s) } +setUnitInstantiations :: String -> DynFlags -> DynFlags +setUnitInstantiations s d = + d { homeUnitInstantiations = parseUnitInsts s } -setComponentId :: String -> DynFlags -> DynFlags -setComponentId s d = - d { thisComponentId_ = Just (Indefinite (UnitId (fsLit s)) Nothing) } +setUnitInstanceOf :: String -> DynFlags -> DynFlags +setUnitInstanceOf s d = + d { homeUnitInstanceOfId = Just (Indefinite (UnitId (fsLit s)) Nothing) } addPluginModuleName :: String -> DynFlags -> DynFlags addPluginModuleName name d = d { pluginModNames = (mkModuleName name) : (pluginModNames d) } @@ -2330,8 +2327,8 @@ dynamic_flags_deps = [ -- as specifying that the number of -- parallel builds is equal to the -- result of getNumProcessors - , make_ord_flag defFlag "instantiated-with" (sepArg setUnitIdInsts) - , make_ord_flag defFlag "this-component-id" (sepArg setComponentId) + , make_ord_flag defFlag "instantiated-with" (sepArg setUnitInstantiations) + , make_ord_flag defFlag "this-component-id" (sepArg setUnitInstanceOf) -- RTS options ------------------------------------------------------------- , make_ord_flag defFlag "H" (HasArg (\s -> upd (\d -> @@ -4588,20 +4585,20 @@ parseUnitArg = fmap UnitIdArg parseUnit setUnitId :: String -> DynFlags -> DynFlags -setUnitId p d = d { thisUnitId = stringToUnitId p } +setUnitId p d = d { homeUnitId = stringToUnitId p } -- | Given a 'ModuleName' of a signature in the home library, find -- out how it is instantiated. E.g., the canonical form of -- A in @p[A=q[]:A]@ is @q[]:A@. canonicalizeHomeModule :: DynFlags -> ModuleName -> Module canonicalizeHomeModule dflags mod_name = - case lookup mod_name (thisUnitIdInsts dflags) of - Nothing -> mkModule (thisPackage dflags) mod_name + case lookup mod_name (homeUnitInstantiations dflags) of + Nothing -> mkHomeModule dflags mod_name Just mod -> mod canonicalizeModuleIfHome :: DynFlags -> Module -> Module canonicalizeModuleIfHome dflags mod - = if thisPackage dflags == moduleUnit mod + = if homeUnit dflags == moduleUnit mod then canonicalizeHomeModule dflags (moduleName mod) else mod diff --git a/compiler/GHC/Driver/Types.hs b/compiler/GHC/Driver/Types.hs index 0249d5cfad..5ae44bca21 100644 --- a/compiler/GHC/Driver/Types.hs +++ b/compiler/GHC/Driver/Types.hs @@ -1593,7 +1593,7 @@ The details are a bit tricky though: in the Home Package Table (HPT). When you say :load, that's when we extend the HPT. - * The 'thisPackage' field of DynFlags is *not* set to 'interactive'. + * The 'homeUnitId' field of DynFlags is *not* set to 'interactive'. It stays as 'main' (or whatever -this-unit-id says), and is the package to which :load'ed modules are added to. @@ -1603,7 +1603,7 @@ The details are a bit tricky though: call to initTc in initTcInteractive, which in turn get the module from it 'icInteractiveModule' field of the interactive context. - The 'thisPackage' field stays as 'main' (or whatever -this-unit-id says. + The 'homeUnitId' field stays as 'main' (or whatever -this-unit-id says. * The main trickiness is that the type environment (tcg_type_env) and fixity envt (tcg_fix_env), now contain entities from all the @@ -1848,11 +1848,11 @@ shadowed_by ids = shadowed shadowed id = getOccName id `elemOccSet` new_occs new_occs = mkOccSet (map getOccName ids) +-- | Set the 'DynFlags.homeUnitId' to 'interactive' setInteractivePackage :: HscEnv -> HscEnv --- Set the 'thisPackage' DynFlag to 'interactive' setInteractivePackage hsc_env = hsc_env { hsc_dflags = (hsc_dflags hsc_env) - { thisUnitId = toUnitId interactiveUnitId } } + { homeUnitId = toUnitId interactiveUnitId } } setInteractivePrintName :: InteractiveContext -> Name -> InteractiveContext setInteractivePrintName ic n = ic{ic_int_print = n} @@ -2013,7 +2013,7 @@ mkPrintUnqualified dflags env = QueryQualify qual_name -- is only one exposed package which exports this module, don't qualify. mkQualModule :: DynFlags -> QueryQualifyModule mkQualModule dflags mod - | moduleUnit mod == thisPackage dflags = False + | isHomeModule dflags mod = False | [(_, pkgconfig)] <- lookup, mkUnit pkgconfig == moduleUnit mod @@ -2305,7 +2305,7 @@ lookupType dflags hpt pte name where mod = ASSERT2( isExternalName name, ppr name ) if isHoleName name - then mkModule (thisPackage dflags) (moduleName (nameModule name)) + then mkHomeModule dflags (moduleName (nameModule name)) else nameModule name -- | As 'lookupType', but with a marginally easier-to-use interface diff --git a/compiler/GHC/HsToCore.hs b/compiler/GHC/HsToCore.hs index 408cf6439d..c7ebb509f9 100644 --- a/compiler/GHC/HsToCore.hs +++ b/compiler/GHC/HsToCore.hs @@ -174,7 +174,7 @@ deSugar hsc_env ; let used_names = mkUsedNames tcg_env pluginModules = map lpModule (cachedPlugins (hsc_dflags hsc_env)) - ; deps <- mkDependencies (thisUnitId (hsc_dflags hsc_env)) + ; deps <- mkDependencies (homeUnitId (hsc_dflags hsc_env)) (map mi_module pluginModules) tcg_env ; used_th <- readIORef tc_splice_used diff --git a/compiler/GHC/HsToCore/Usage.hs b/compiler/GHC/HsToCore/Usage.hs index 0c48b5744d..7a00d75b23 100644 --- a/compiler/GHC/HsToCore/Usage.hs +++ b/compiler/GHC/HsToCore/Usage.hs @@ -250,7 +250,7 @@ mk_mod_usage_info pit hsc_env this_mod direct_imports used_names where hpt = hsc_HPT hsc_env dflags = hsc_dflags hsc_env - this_pkg = thisPackage dflags + this_pkg = homeUnit dflags used_mods = moduleEnvKeys ent_map dir_imp_mods = moduleEnvKeys direct_imports diff --git a/compiler/GHC/Iface/Load.hs b/compiler/GHC/Iface/Load.hs index b04db0842d..7572a69b6b 100644 --- a/compiler/GHC/Iface/Load.hs +++ b/compiler/GHC/Iface/Load.hs @@ -64,6 +64,7 @@ import GHC.Types.Name import GHC.Types.Name.Env import GHC.Types.Avail import GHC.Unit.Module +import GHC.Unit.State import GHC.Data.Maybe import GHC.Utils.Error import GHC.Driver.Finder @@ -401,7 +402,7 @@ loadInterface doc_str mod from -- Hole modules get special treatment = do dflags <- getDynFlags -- Redo search for our local hole module - loadInterface doc_str (mkModule (thisPackage dflags) (moduleName mod)) from + loadInterface doc_str (mkHomeModule dflags (moduleName mod)) from | otherwise = withTimingSilentD (text "loading interface") (pure ()) $ do { -- Read the state @@ -619,7 +620,7 @@ is_external_sig dflags iface = -- It's a signature iface... mi_semantic_module iface /= mi_module iface && -- and it's not from the local package - moduleUnit (mi_module iface) /= thisPackage dflags + moduleUnit (mi_module iface) /= homeUnit dflags -- | This is an improved version of 'findAndReadIface' which can also -- handle the case when a user requests @p[A=<B>]:M@ but we only @@ -642,7 +643,7 @@ computeInterface doc_str hi_boot_file mod0 = do MASSERT( not (isHoleModule mod0) ) dflags <- getDynFlags case getModuleInstantiation mod0 of - (imod, Just indef) | not (unitIsDefinite (thisPackage dflags)) -> do + (imod, Just indef) | homeUnitIsIndefinite dflags -> do r <- findAndReadIface doc_str imod mod0 hi_boot_file case r of Succeeded (iface0, path) -> do @@ -728,7 +729,7 @@ wantHiBootFile dflags eps mod from -- The boot-ness of the requested interface, -- based on the dependencies in directly-imported modules where - this_package = thisPackage dflags == moduleUnit mod + this_package = homeUnit dflags == moduleUnit mod badSourceImport :: Module -> SDoc badSourceImport mod @@ -927,7 +928,7 @@ findAndReadIface doc_str mod wanted_mod_with_insts hi_boot_file (ml_hi_file loc) -- See Note [Home module load error] - if moduleUnit mod `unitIdEq` thisPackage dflags && + if moduleUnit mod `unitIdEq` homeUnit dflags && not (isOneShot (ghcMode dflags)) then return (Failed (homeModError mod loc)) else do r <- read_file file_path diff --git a/compiler/GHC/Iface/Make.hs b/compiler/GHC/Iface/Make.hs index 38e8e94be7..b93d46e2d0 100644 --- a/compiler/GHC/Iface/Make.hs +++ b/compiler/GHC/Iface/Make.hs @@ -166,7 +166,7 @@ mkIfaceTc hsc_env safe_mode mod_details let pluginModules = map lpModule (cachedPlugins (hsc_dflags hsc_env)) deps <- mkDependencies - (thisUnitId (hsc_dflags hsc_env)) + (homeUnitId (hsc_dflags hsc_env)) (map mi_module pluginModules) tc_result let hpc_info = emptyHpcInfo other_hpc_info used_th <- readIORef tc_splice_used diff --git a/compiler/GHC/Iface/Recomp.hs b/compiler/GHC/Iface/Recomp.hs index 03223c5712..5b58457f73 100644 --- a/compiler/GHC/Iface/Recomp.hs +++ b/compiler/GHC/Iface/Recomp.hs @@ -212,7 +212,7 @@ checkVersions hsc_env mod_summary iface -- readIface will have verified that the UnitId matches, -- but we ALSO must make sure the instantiation matches up. See -- test case bkpcabal04! - ; if moduleUnit (mi_module iface) /= thisPackage (hsc_dflags hsc_env) + ; if moduleUnit (mi_module iface) /= homeUnit (hsc_dflags hsc_env) then return (RecompBecause "-this-unit-id changed", Nothing) else do { ; recomp <- checkFlagHash hsc_env iface ; if recompileRequired recomp then return (recomp, Nothing) else do { @@ -250,7 +250,7 @@ checkVersions hsc_env mod_summary iface ; return (recomp, Just iface) }}}}}}}}}} where - this_pkg = thisPackage (hsc_dflags hsc_env) + this_pkg = homeUnit (hsc_dflags hsc_env) -- This is a bit of a hack really mod_deps :: ModuleNameEnv ModuleNameWithIsBoot mod_deps = mkModDeps (dep_mods (mi_deps iface)) @@ -332,7 +332,7 @@ checkHsig mod_summary iface = do dflags <- getDynFlags let outer_mod = ms_mod mod_summary inner_mod = canonicalizeHomeModule dflags (moduleName outer_mod) - MASSERT( moduleUnit outer_mod == thisPackage dflags ) + MASSERT( moduleUnit outer_mod == homeUnit dflags ) case inner_mod == mi_semantic_module iface of True -> up_to_date (text "implementing module unchanged") False -> return (RecompBecause "implementing module changed") @@ -447,7 +447,7 @@ checkDependencies hsc_env summary iface prev_dep_plgn = dep_plgins (mi_deps iface) prev_dep_pkgs = dep_pkgs (mi_deps iface) - this_pkg = thisPackage (hsc_dflags hsc_env) + this_pkg = homeUnit (hsc_dflags hsc_env) dep_missing (mb_pkg, L _ mod) = do find_res <- liftIO $ findImportedModule hsc_env mod (mb_pkg) @@ -1348,7 +1348,7 @@ mkHashFun -> (Name -> IO Fingerprint) mkHashFun hsc_env eps name | isHoleModule orig_mod - = lookup (mkModule (thisPackage dflags) (moduleName orig_mod)) + = lookup (mkHomeModule dflags (moduleName orig_mod)) | otherwise = lookup orig_mod where diff --git a/compiler/GHC/Iface/Recomp/Flags.hs b/compiler/GHC/Iface/Recomp/Flags.hs index 03313c61f2..eac1277b75 100644 --- a/compiler/GHC/Iface/Recomp/Flags.hs +++ b/compiler/GHC/Iface/Recomp/Flags.hs @@ -36,7 +36,7 @@ fingerprintDynFlags :: DynFlags -> Module fingerprintDynFlags dflags@DynFlags{..} this_mod nameio = let mainis = if mainModIs == this_mod then Just mainFunIs else Nothing -- see #5878 - -- pkgopts = (thisPackage dflags, sort $ packageFlags dflags) + -- pkgopts = (homeUnit dflags, sort $ packageFlags dflags) safeHs = setSafeMode safeHaskell -- oflags = sort $ filter filterOFlags $ flags dflags diff --git a/compiler/GHC/Iface/Rename.hs b/compiler/GHC/Iface/Rename.hs index b7d5895490..487525f2d3 100644 --- a/compiler/GHC/Iface/Rename.hs +++ b/compiler/GHC/Iface/Rename.hs @@ -341,7 +341,7 @@ rnIfaceGlobal n = do -- went from <A> to <B>. let m'' = if isHoleModule m' -- Pull out the local guy!! - then mkModule (thisPackage dflags) (moduleName m') + then mkHomeModule dflags (moduleName m') else m' iface <- liftIO . initIfaceCheck (text "rnIfaceGlobal") hsc_env $ loadSysInterface (text "rnIfaceGlobal") m'' diff --git a/compiler/GHC/Parser/Lexer.x b/compiler/GHC/Parser/Lexer.x index 1411ba32ff..542af41557 100644 --- a/compiler/GHC/Parser/Lexer.x +++ b/compiler/GHC/Parser/Lexer.x @@ -55,7 +55,7 @@ module GHC.Parser.Lexer ( appendError, allocateComments, MonadP(..), - getRealSrcLoc, getPState, withThisPackage, + getRealSrcLoc, getPState, withHomeUnit, failMsgP, failLocMsgP, srcParseFail, getErrorMessages, getMessages, popContext, pushModuleContext, setLastToken, setSrcLoc, @@ -2088,7 +2088,7 @@ warnopt f options = f `EnumSet.member` pWarningFlags options -- See 'mkParserFlags' or 'mkParserFlags'' for ways to construct this. data ParserFlags = ParserFlags { pWarningFlags :: EnumSet WarningFlag - , pThisPackage :: Unit -- ^ key of package currently being compiled + , pHomeUnit :: Unit -- ^ unit currently being compiled , pExtsBitmap :: !ExtsBitmap -- ^ bitmap of permitted extensions } @@ -2183,8 +2183,8 @@ failLocMsgP loc1 loc2 str = getPState :: P PState getPState = P $ \s -> POk s s -withThisPackage :: (Unit -> a) -> P a -withThisPackage f = P $ \s@(PState{options = o}) -> POk s (f (pThisPackage o)) +withHomeUnit :: (Unit -> a) -> P a +withHomeUnit f = P $ \s@(PState{options = o}) -> POk s (f (pHomeUnit o)) getExts :: P ExtsBitmap getExts = P $ \s -> POk s (pExtsBitmap . options $ s) @@ -2512,12 +2512,12 @@ mkParserFlags' -> ParserFlags -- ^ Given exactly the information needed, set up the 'ParserFlags' -mkParserFlags' warningFlags extensionFlags thisPackage +mkParserFlags' warningFlags extensionFlags homeUnit safeImports isHaddock rawTokStream usePosPrags = ParserFlags { pWarningFlags = warningFlags - , pThisPackage = thisPackage - , pExtsBitmap = safeHaskellBit .|. langExtBits .|. optBits + , pHomeUnit = homeUnit + , pExtsBitmap = safeHaskellBit .|. langExtBits .|. optBits } where safeHaskellBit = SafeHaskellBit `setBitIf` safeImports @@ -2578,7 +2578,7 @@ mkParserFlags = mkParserFlags' <$> DynFlags.warningFlags <*> DynFlags.extensionFlags - <*> DynFlags.thisPackage + <*> DynFlags.homeUnit <*> safeImportsOn <*> gopt Opt_Haddock <*> gopt Opt_KeepRawTokenStream diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs index deee12a726..533a794807 100644 --- a/compiler/GHC/Rename/Module.hs +++ b/compiler/GHC/Rename/Module.hs @@ -373,8 +373,8 @@ rnHsForeignDecl (ForeignImport { fd_name = name, fd_sig_ty = ty, fd_fi = spec }) ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) TypeLevel Nothing ty -- Mark any PackageTarget style imports as coming from the current package - ; let unitId = thisPackage $ hsc_dflags topEnv - spec' = patchForeignImport unitId spec + ; let unitId = homeUnit $ hsc_dflags topEnv + spec' = patchForeignImport unitId spec ; return (ForeignImport { fd_i_ext = noExtField , fd_name = name', fd_sig_ty = ty' diff --git a/compiler/GHC/Rename/Names.hs b/compiler/GHC/Rename/Names.hs index ccc72bac36..69c0746646 100644 --- a/compiler/GHC/Rename/Names.hs +++ b/compiler/GHC/Rename/Names.hs @@ -448,7 +448,7 @@ calculateAvails dflags iface mod_safe' want_boot imported_by = ptrust = trust == Sf_Trustworthy || trust_pkg (dependent_mods, dependent_pkgs, pkg_trust_req) - | pkg == thisPackage dflags = + | pkg == homeUnit dflags = -- Imported module is from the home package -- Take its dependent modules and add imp_mod itself -- Take its dependent packages unchanged diff --git a/compiler/GHC/Runtime/Eval.hs b/compiler/GHC/Runtime/Eval.hs index 9c490f56c2..55b4f3d32b 100644 --- a/compiler/GHC/Runtime/Eval.hs +++ b/compiler/GHC/Runtime/Eval.hs @@ -814,7 +814,7 @@ getContext = withSession $ \HscEnv{ hsc_IC=ic } -> -- its full top-level scope available. moduleIsInterpreted :: GhcMonad m => Module -> m Bool moduleIsInterpreted modl = withSession $ \h -> - if moduleUnit modl /= thisPackage (hsc_dflags h) + if not (isHomeModule (hsc_dflags h) modl) then return False else case lookupHpt (hsc_HPT h) (moduleName modl) of Just details -> return (isJust (mi_globals (hm_iface details))) diff --git a/compiler/GHC/Runtime/Linker.hs b/compiler/GHC/Runtime/Linker.hs index 740e3a7a43..22cd871fad 100644 --- a/compiler/GHC/Runtime/Linker.hs +++ b/compiler/GHC/Runtime/Linker.hs @@ -655,7 +655,7 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods ; return (lnks_needed, pkgs_needed) } where dflags = hsc_dflags hsc_env - this_pkg = thisPackage dflags + this_pkg = homeUnit dflags -- The ModIface contains the transitive closure of the module dependencies -- within the current package, *except* for boot modules: if we encounter diff --git a/compiler/GHC/StgToCmm/Monad.hs b/compiler/GHC/StgToCmm/Monad.hs index 280a71674b..6beb08398b 100644 --- a/compiler/GHC/StgToCmm/Monad.hs +++ b/compiler/GHC/StgToCmm/Monad.hs @@ -49,7 +49,7 @@ module GHC.StgToCmm.Monad ( getModuleName, -- ideally we wouldn't export these, but some other modules access internal state - getState, setState, getSelfLoop, withSelfLoop, getInfoDown, getDynFlags, getThisPackage, + getState, setState, getSelfLoop, withSelfLoop, getInfoDown, getDynFlags, -- more localised access to monad state CgIdInfo(..), @@ -474,9 +474,6 @@ instance HasDynFlags FCode where getPlatform :: FCode Platform getPlatform = targetPlatform <$> getDynFlags -getThisPackage :: FCode Unit -getThisPackage = liftM thisPackage getDynFlags - withInfoDown :: FCode a -> CgInfoDownwards -> FCode a withInfoDown (FCode fcode) info_down = FCode $ \_ state -> fcode info_down state diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs index 300a870709..0471b85666 100644 --- a/compiler/GHC/Tc/Module.hs +++ b/compiler/GHC/Tc/Module.hs @@ -183,7 +183,7 @@ tcRnModule hsc_env mod_sum save_rn_syntax err_msg = mkPlainErrMsg (hsc_dflags hsc_env) loc $ text "Module does not have a RealSrcSpan:" <+> ppr this_mod - this_pkg = thisPackage (hsc_dflags hsc_env) + this_pkg = homeUnit (hsc_dflags hsc_env) pair :: (Module, SrcSpan) pair@(this_mod,_) @@ -2830,7 +2830,7 @@ loadUnqualIfaces hsc_env ictxt = initIfaceTcRn $ do mapM_ (loadSysInterface doc) (moduleSetElts (mkModuleSet unqual_mods)) where - this_pkg = thisPackage (hsc_dflags hsc_env) + this_pkg = homeUnit (hsc_dflags hsc_env) unqual_mods = [ nameModule name | gre <- globalRdrEnvElts (ic_rn_gbl_env ictxt) diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs index 8ff9ad0d3e..6af35c77c2 100644 --- a/compiler/GHC/Tc/TyCl.hs +++ b/compiler/GHC/Tc/TyCl.hs @@ -61,6 +61,7 @@ import GHC.Types.Var import GHC.Types.Var.Env import GHC.Types.Var.Set import GHC.Unit.Module +import GHC.Unit.State import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.Name.Env @@ -172,7 +173,7 @@ 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 thisPackage getDynFlags + ; this_uid <- fmap homeUnit getDynFlags ; checkSynCycles this_uid tyclss tyclds ; traceTc "Done synonym cycle check" (ppr tyclss) @@ -4009,7 +4010,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!) - , unitIsDefinite (thisPackage dflags) + , homeUnitIsDefinite 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 98458b884b..66733b0618 100644 --- a/compiler/GHC/Tc/Utils/Backpack.hs +++ b/compiler/GHC/Tc/Utils/Backpack.hs @@ -309,7 +309,7 @@ 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 | thisPackage dflags /= moduleUnit mod -> + Found _ mod | not (isHomeModule dflags mod) -> return (uniqDSetToList (moduleFreeHoles mod)) _ -> return [] where dflags = hsc_dflags hsc_env @@ -731,7 +731,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 (thisUnitIdInsts dflags) (Just nsubst) lcl_iface0 + lcl_iface <- tcRnModIface (homeUnitInstantiations dflags) (Just nsubst) lcl_iface0 let ifaces = lcl_iface : ext_ifaces -- STEP 4.1: Merge fixities (we'll verify shortly) tcg_fix_env @@ -753,7 +753,7 @@ mergeSignatures let infos = zip ifaces detailss -- Test for cycles - checkSynCycles (thisPackage dflags) (typeEnvTyCons type_env) [] + checkSynCycles (homeUnit dflags) (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,9 +1000,13 @@ instantiateSignature = do -- 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( moduleUnit outer_mod == thisPackage dflags ) + MASSERT( isHomeModule dflags outer_mod ) + MASSERT( isJust (homeUnitInstanceOfId dflags) ) + let uid = fromJust (homeUnitInstanceOfId dflags) + -- we need to fetch the most recent ppr infos from the unit + -- database because we might have modified it + uid' = updateIndefUnitId (pkgState dflags) uid inner_mod `checkImplements` Module - (mkInstantiatedUnit (thisComponentId dflags) - (thisUnitIdInsts dflags)) + (mkInstantiatedUnit uid' (homeUnitInstantiations dflags)) (moduleName outer_mod) diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs index d7fbd2e095..5030c61fd3 100644 --- a/compiler/GHC/Tc/Utils/Monad.hs +++ b/compiler/GHC/Tc/Utils/Monad.hs @@ -1857,8 +1857,8 @@ initIfaceTcRn thing_inside ; let !mod = tcg_semantic_mod tcg_env -- When we are instantiating a signature, we DEFINITELY -- do not want to knot tie. - is_instantiate = unitIsDefinite (thisPackage dflags) && - not (null (thisUnitIdInsts dflags)) + is_instantiate = homeUnitIsDefinite dflags && + not (null (homeUnitInstantiations dflags)) ; let { if_env = IfGblEnv { if_doc = text "initIfaceTcRn", if_rec_types = diff --git a/compiler/GHC/Unit/State.hs b/compiler/GHC/Unit/State.hs index 051367d9b2..d3737c08e0 100644 --- a/compiler/GHC/Unit/State.hs +++ b/compiler/GHC/Unit/State.hs @@ -59,7 +59,8 @@ module GHC.Unit.State ( pprPackages, pprPackagesSimple, pprModuleMap, - isIndefinite, + homeUnitIsIndefinite, + homeUnitIsDefinite, ) where @@ -387,7 +388,7 @@ emptyUnitInfoMap = UnitInfoMap emptyUDFM emptyUniqSet -- | Find the unit we know about with the given unit id, if any lookupUnit :: DynFlags -> Unit -> Maybe UnitInfo -lookupUnit dflags = lookupUnit' (isIndefinite dflags) (unitInfoMap (pkgState dflags)) +lookupUnit dflags = lookupUnit' (homeUnitIsIndefinite dflags) (unitInfoMap (pkgState dflags)) -- | A more specialized interface, which takes a boolean specifying -- whether or not to look for on-the-fly renamed interfaces, and @@ -485,7 +486,7 @@ initPackages dflags = withTiming dflags <- mkPackageState dflags pkg_dbs [] return (dflags{ pkgDatabase = Just read_pkg_dbs, pkgState = pkg_state, - thisUnitIdInsts_ = insts }, + homeUnitInstantiations = insts }, preload) where forcePkgDb (dflags, _) = unitInfoMap (pkgState dflags) `seq` () @@ -676,10 +677,15 @@ applyTrustFlag dflags prec_map unusable pkgs flag = Left ps -> trustFlagErr dflags flag ps Right (ps,qs) -> return (distrustAllUnits ps ++ qs) --- | A little utility to tell if the 'thisPackage' is indefinite +-- | A little utility to tell if the home unit is indefinite -- (if it is not, we should never use on-the-fly renaming.) -isIndefinite :: DynFlags -> Bool -isIndefinite dflags = not (unitIsDefinite (thisPackage dflags)) +homeUnitIsIndefinite :: DynFlags -> Bool +homeUnitIsIndefinite dflags = not (homeUnitIsDefinite dflags) + +-- | A little utility to tell if the home unit is definite +-- (if it is, we should never use on-the-fly renaming.) +homeUnitIsDefinite :: DynFlags -> Bool +homeUnitIsDefinite dflags = unitIsDefinite (homeUnit dflags) applyPackageFlag :: DynFlags @@ -1322,7 +1328,7 @@ mkPackageState -> [PreloadUnitId] -- preloaded packages -> IO (PackageState, [PreloadUnitId], -- new packages to preload - Maybe [(ModuleName, Module)]) + [(ModuleName, Module)]) mkPackageState dflags dbs preload0 = do {- @@ -1538,7 +1544,7 @@ mkPackageState dflags dbs preload0 = do -- (NB: since this is only relevant for base/rts it doesn't matter -- that thisUnitIdInsts_ is not wired yet) -- - preload3 = ordNub $ filter (/= thisPackage dflags) + preload3 = ordNub $ filter (/= homeUnit dflags) $ (basicLinkedPackages ++ preload2) -- Close the preload packages with their dependencies @@ -1564,7 +1570,7 @@ mkPackageState dflags dbs preload0 = do unwireMap = Map.fromList [ (v,k) | (k,v) <- Map.toList wired_map ], requirementContext = req_ctx } - let new_insts = fmap (map (fmap (upd_wired_in_mod wired_map))) (thisUnitIdInsts_ dflags) + let new_insts = map (fmap (upd_wired_in_mod wired_map)) (homeUnitInstantiations dflags) return (pstate, new_dep_preload, new_insts) -- | Given a wired-in 'Unit', "unwire" it into the 'Unit' @@ -1659,7 +1665,7 @@ mkModuleNameProvidersMap dflags pkg_db vis_map = hiddens = [(m, mkModMap pk m ModHidden) | m <- hidden_mods] pk = mkUnit pkg - unit_lookup uid = lookupUnit' (isIndefinite dflags) pkg_db uid + unit_lookup uid = lookupUnit' (homeUnitIsIndefinite dflags) pkg_db uid `orElse` pprPanic "unit_lookup" (ppr uid) exposed_mods = unitExposedModules pkg @@ -1968,10 +1974,10 @@ getPreloadPackagesAnd dflags pkgids0 = -- An indefinite package will have insts to HOLE, -- which is not a real package. Don't look it up. -- Fixes #14525 - if isIndefinite dflags + if homeUnitIsIndefinite dflags then [] else map (toUnitId . moduleUnit . snd) - (thisUnitIdInsts dflags) + (homeUnitInstantiations dflags) state = pkgState dflags pkg_map = unitInfoMap state preload = preloadPackages state |