Commit 72d08610 authored by Sylvain Henry's avatar Sylvain Henry Committed by Marge Bot

Refactor homeUnit

* rename thisPackage into homeUnit
* document and refactor several Backpack things
parent 7a02599a
...@@ -1489,7 +1489,7 @@ findModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module ...@@ -1489,7 +1489,7 @@ findModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module
findModule mod_name maybe_pkg = withSession $ \hsc_env -> do findModule mod_name maybe_pkg = withSession $ \hsc_env -> do
let let
dflags = hsc_dflags hsc_env dflags = hsc_dflags hsc_env
this_pkg = thisPackage dflags this_pkg = homeUnit dflags
-- --
case maybe_pkg of case maybe_pkg of
Just pkg | fsToUnit pkg /= this_pkg && pkg /= fsLit "this" -> liftIO $ do Just pkg | fsToUnit pkg /= this_pkg && pkg /= fsLit "this" -> liftIO $ do
......
...@@ -377,7 +377,7 @@ cmmtop :: { CmmParse () } ...@@ -377,7 +377,7 @@ cmmtop :: { CmmParse () }
| cmmdata { $1 } | cmmdata { $1 }
| decl { $1 } | decl { $1 }
| 'CLOSURE' '(' NAME ',' NAME lits ')' ';' | 'CLOSURE' '(' NAME ',' NAME lits ')' ';'
{% liftP . withThisPackage $ \pkg -> {% liftP . withHomeUnit $ \pkg ->
do lits <- sequence $6; do lits <- sequence $6;
staticClosure pkg $3 $5 (map getLit lits) } staticClosure pkg $3 $5 (map getLit lits) }
...@@ -398,7 +398,7 @@ cmmdata :: { CmmParse () } ...@@ -398,7 +398,7 @@ cmmdata :: { CmmParse () }
data_label :: { CmmParse CLabel } data_label :: { CmmParse CLabel }
: NAME ':' : NAME ':'
{% liftP . withThisPackage $ \pkg -> {% liftP . withHomeUnit $ \pkg ->
return (mkCmmDataLabel pkg $1) } return (mkCmmDataLabel pkg $1) }
statics :: { [CmmParse [CmmStatic]] } statics :: { [CmmParse [CmmStatic]] }
...@@ -455,14 +455,14 @@ maybe_body :: { CmmParse () } ...@@ -455,14 +455,14 @@ maybe_body :: { CmmParse () }
info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) } info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
: NAME : NAME
{% liftP . withThisPackage $ \pkg -> {% liftP . withHomeUnit $ \pkg ->
do newFunctionName $1 pkg do newFunctionName $1 pkg
return (mkCmmCodeLabel pkg $1, Nothing, []) } return (mkCmmCodeLabel pkg $1, Nothing, []) }
| 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')' | 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
-- ptrs, nptrs, closure type, description, type -- ptrs, nptrs, closure type, description, type
{% liftP . withThisPackage $ \pkg -> {% liftP . withHomeUnit $ \pkg ->
do dflags <- getDynFlags do dflags <- getDynFlags
let prof = profilingInfo dflags $11 $13 let prof = profilingInfo dflags $11 $13
rep = mkRTSRep (fromIntegral $9) $ rep = mkRTSRep (fromIntegral $9) $
...@@ -478,7 +478,7 @@ info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) } ...@@ -478,7 +478,7 @@ info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
| 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')' | 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')'
-- ptrs, nptrs, closure type, description, type, fun type -- ptrs, nptrs, closure type, description, type, fun type
{% liftP . withThisPackage $ \pkg -> {% liftP . withHomeUnit $ \pkg ->
do dflags <- getDynFlags do dflags <- getDynFlags
let prof = profilingInfo dflags $11 $13 let prof = profilingInfo dflags $11 $13
ty = Fun 0 (ArgSpec (fromIntegral $15)) ty = Fun 0 (ArgSpec (fromIntegral $15))
...@@ -496,7 +496,7 @@ info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) } ...@@ -496,7 +496,7 @@ info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
| 'INFO_TABLE_CONSTR' '(' NAME ',' INT ',' INT ',' INT ',' INT ',' STRING ',' STRING ')' | 'INFO_TABLE_CONSTR' '(' NAME ',' INT ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
-- ptrs, nptrs, tag, closure type, description, type -- ptrs, nptrs, tag, closure type, description, type
{% liftP . withThisPackage $ \pkg -> {% liftP . withHomeUnit $ \pkg ->
do dflags <- getDynFlags do dflags <- getDynFlags
let prof = profilingInfo dflags $13 $15 let prof = profilingInfo dflags $13 $15
ty = Constr (fromIntegral $9) -- Tag ty = Constr (fromIntegral $9) -- Tag
...@@ -515,7 +515,7 @@ info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) } ...@@ -515,7 +515,7 @@ info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
| 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')' | 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')'
-- selector, closure type, description, type -- selector, closure type, description, type
{% liftP . withThisPackage $ \pkg -> {% liftP . withHomeUnit $ \pkg ->
do dflags <- getDynFlags do dflags <- getDynFlags
let prof = profilingInfo dflags $9 $11 let prof = profilingInfo dflags $9 $11
ty = ThunkSelector (fromIntegral $5) ty = ThunkSelector (fromIntegral $5)
...@@ -529,7 +529,7 @@ info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) } ...@@ -529,7 +529,7 @@ info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
| 'INFO_TABLE_RET' '(' NAME ',' INT ')' | 'INFO_TABLE_RET' '(' NAME ',' INT ')'
-- closure type (no live regs) -- closure type (no live regs)
{% liftP . withThisPackage $ \pkg -> {% liftP . withHomeUnit $ \pkg ->
do let prof = NoProfilingInfo do let prof = NoProfilingInfo
rep = mkRTSRep (fromIntegral $5) $ mkStackRep [] rep = mkRTSRep (fromIntegral $5) $ mkStackRep []
return (mkCmmRetLabel pkg $3, return (mkCmmRetLabel pkg $3,
...@@ -540,7 +540,7 @@ info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) } ...@@ -540,7 +540,7 @@ info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
| 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals0 ')' | 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals0 ')'
-- closure type, live regs -- closure type, live regs
{% liftP . withThisPackage $ \pkg -> {% liftP . withHomeUnit $ \pkg ->
do dflags <- getDynFlags do dflags <- getDynFlags
let platform = targetPlatform dflags let platform = targetPlatform dflags
live <- sequence $7 live <- sequence $7
......
...@@ -149,7 +149,7 @@ mkNatM_State us delta dflags this_mod ...@@ -149,7 +149,7 @@ mkNatM_State us delta dflags this_mod
initConfig :: DynFlags -> NCGConfig initConfig :: DynFlags -> NCGConfig
initConfig dflags = NCGConfig initConfig dflags = NCGConfig
{ ncgPlatform = targetPlatform dflags { ncgPlatform = targetPlatform dflags
, ncgUnitId = thisPackage dflags , ncgUnitId = homeUnit dflags
, ncgProcAlignment = cmmProcAlignment dflags , ncgProcAlignment = cmmProcAlignment dflags
, ncgDebugLevel = debugLevel dflags , ncgDebugLevel = debugLevel dflags
, ncgExternalDynamicRefs = gopt Opt_ExternalDynamicRefs dflags , ncgExternalDynamicRefs = gopt Opt_ExternalDynamicRefs dflags
......
...@@ -1556,9 +1556,9 @@ lookupNaturalSDataConName dflags hsc_env = case integerLibrary dflags of ...@@ -1556,9 +1556,9 @@ lookupNaturalSDataConName dflags hsc_env = case integerLibrary dflags of
-- | Helper for 'lookupMkIntegerName', 'lookupIntegerSDataConName' -- | Helper for 'lookupMkIntegerName', 'lookupIntegerSDataConName'
guardIntegerUse :: DynFlags -> IO a -> IO a guardIntegerUse :: DynFlags -> IO a -> IO a
guardIntegerUse dflags act guardIntegerUse dflags act
| thisPackage dflags == primUnitId | homeUnit dflags == primUnitId
= return $ panic "Can't use Integer in ghc-prim" = return $ panic "Can't use Integer in ghc-prim"
| thisPackage dflags == integerUnitId | homeUnit dflags == integerUnitId
= return $ panic "Can't use Integer in integer-*" = return $ panic "Can't use Integer in integer-*"
| otherwise = act | otherwise = act
...@@ -1568,11 +1568,11 @@ guardIntegerUse dflags act ...@@ -1568,11 +1568,11 @@ guardIntegerUse dflags act
-- literals in `base`. If we do, we get interface loading error for GHC.Natural. -- literals in `base`. If we do, we get interface loading error for GHC.Natural.
guardNaturalUse :: DynFlags -> IO a -> IO a guardNaturalUse :: DynFlags -> IO a -> IO a
guardNaturalUse dflags act guardNaturalUse dflags act
| thisPackage dflags == primUnitId | homeUnit dflags == primUnitId
= return $ panic "Can't use Natural in ghc-prim" = return $ panic "Can't use Natural in ghc-prim"
| thisPackage dflags == integerUnitId | homeUnit dflags == integerUnitId
= return $ panic "Can't use Natural in integer-*" = return $ panic "Can't use Natural in integer-*"
| thisPackage dflags == baseUnitId | homeUnit dflags == baseUnitId
= return $ panic "Can't use Natural in base" = return $ panic "Can't use Natural in base"
| otherwise = act | otherwise = act
......
...@@ -171,9 +171,12 @@ withBkpSession cid insts deps session_type do_this = do ...@@ -171,9 +171,12 @@ withBkpSession cid insts deps session_type do_this = do
hscTarget = case session_type of hscTarget = case session_type of
TcSession -> HscNothing TcSession -> HscNothing
_ -> hscTarget dflags, _ -> hscTarget dflags,
thisUnitIdInsts_ = Just insts, homeUnitInstantiations = insts,
thisComponentId_ = Just cid, -- if we don't have any instantiation, don't
thisUnitId = -- 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 case session_type of
TcSession -> newUnitId cid Nothing TcSession -> newUnitId cid Nothing
-- No hash passed if no instances -- No hash passed if no instances
...@@ -312,7 +315,7 @@ buildUnit session cid insts lunit = do ...@@ -312,7 +315,7 @@ buildUnit session cid insts lunit = do
unitPackageId = PackageId compat_fs, unitPackageId = PackageId compat_fs,
unitPackageName = compat_pn, unitPackageName = compat_pn,
unitPackageVersion = makeVersion [], unitPackageVersion = makeVersion [],
unitId = toUnitId (thisPackage dflags), unitId = toUnitId (homeUnit dflags),
unitComponentName = Nothing, unitComponentName = Nothing,
unitInstanceOf = cid, unitInstanceOf = cid,
unitInstantiations = insts, unitInstantiations = insts,
...@@ -652,7 +655,7 @@ hsunitModuleGraph dflags unit = do ...@@ -652,7 +655,7 @@ hsunitModuleGraph dflags unit = do
-- requirement. -- requirement.
let node_map = Map.fromList [ ((ms_mod_name n, ms_hsc_src n == HsigFile), n) let node_map = Map.fromList [ ((ms_mod_name n, ms_hsc_src n == HsigFile), n)
| n <- nodes ] | 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 let has_local = Map.member (mod_name, True) node_map
in if has_local in if has_local
then return Nothing then return Nothing
......
...@@ -74,7 +74,7 @@ flushFinderCaches :: HscEnv -> IO () ...@@ -74,7 +74,7 @@ flushFinderCaches :: HscEnv -> IO ()
flushFinderCaches hsc_env = flushFinderCaches hsc_env =
atomicModifyIORef' fc_ref $ \fm -> (filterInstalledModuleEnv is_ext fm, ()) atomicModifyIORef' fc_ref $ \fm -> (filterInstalledModuleEnv is_ext fm, ())
where where
this_pkg = thisPackage (hsc_dflags hsc_env) this_pkg = homeUnit (hsc_dflags hsc_env)
fc_ref = hsc_FC hsc_env fc_ref = hsc_FC hsc_env
is_ext mod _ | not (moduleUnit mod `unitIdEq` this_pkg) = True is_ext mod _ | not (moduleUnit mod `unitIdEq` this_pkg) = True
| otherwise = False | otherwise = False
...@@ -135,7 +135,7 @@ findPluginModule hsc_env mod_name = ...@@ -135,7 +135,7 @@ findPluginModule hsc_env mod_name =
findExactModule :: HscEnv -> InstalledModule -> IO InstalledFindResult findExactModule :: HscEnv -> InstalledModule -> IO InstalledFindResult
findExactModule hsc_env mod = findExactModule hsc_env mod =
let dflags = hsc_dflags hsc_env 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) then findInstalledHomeModule hsc_env (moduleName mod)
else findPackageModule hsc_env mod else findPackageModule hsc_env mod
...@@ -245,7 +245,7 @@ modLocationCache hsc_env mod do_this = do ...@@ -245,7 +245,7 @@ modLocationCache hsc_env mod do_this = do
mkHomeInstalledModule :: DynFlags -> ModuleName -> InstalledModule mkHomeInstalledModule :: DynFlags -> ModuleName -> InstalledModule
mkHomeInstalledModule dflags mod_name = mkHomeInstalledModule dflags mod_name =
let iuid = thisUnitId dflags let iuid = homeUnitId dflags
in Module iuid mod_name in Module iuid mod_name
-- This returns a module because it's more convenient for users -- This returns a module because it's more convenient for users
...@@ -253,7 +253,7 @@ addHomeModuleToFinder :: HscEnv -> ModuleName -> ModLocation -> IO Module ...@@ -253,7 +253,7 @@ addHomeModuleToFinder :: HscEnv -> ModuleName -> ModLocation -> IO Module
addHomeModuleToFinder hsc_env mod_name loc = do addHomeModuleToFinder hsc_env mod_name loc = do
let mod = mkHomeInstalledModule (hsc_dflags hsc_env) mod_name let mod = mkHomeInstalledModule (hsc_dflags hsc_env) mod_name
addToFinderCache (hsc_FC hsc_env) mod (InstalledFound loc mod) 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 :: HscEnv -> ModuleName -> IO ()
uncacheModule hsc_env mod_name = do uncacheModule hsc_env mod_name = do
...@@ -279,7 +279,7 @@ findHomeModule hsc_env mod_name = do ...@@ -279,7 +279,7 @@ findHomeModule hsc_env mod_name = do
} }
where where
dflags = hsc_dflags hsc_env dflags = hsc_dflags hsc_env
uid = thisPackage dflags uid = homeUnit dflags
-- | Implements the search for a module name in the home package only. Calling -- | 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 -- 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 ...@@ -678,7 +678,7 @@ cantFindErr cannot_find _ dflags mod_name find_result
NotFound { fr_paths = files, fr_pkg = mb_pkg NotFound { fr_paths = files, fr_pkg = mb_pkg
, fr_mods_hidden = mod_hiddens, fr_pkgs_hidden = pkg_hiddens , fr_mods_hidden = mod_hiddens, fr_pkgs_hidden = pkg_hiddens
, fr_unusables = unusables, fr_suggestions = suggest } , 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_found_in_package pkg files
| not (null suggest) | not (null suggest)
...@@ -794,7 +794,7 @@ cantFindInstalledErr cannot_find _ dflags mod_name find_result ...@@ -794,7 +794,7 @@ cantFindInstalledErr cannot_find _ dflags mod_name find_result
text "was found" $$ looks_like_srcpkgid pkg text "was found" $$ looks_like_srcpkgid pkg
InstalledNotFound files mb_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 -> not_found_in_package pkg files
| null files | null files
......
...@@ -470,12 +470,12 @@ hsc_typecheck keep_rn mod_summary mb_rdr_module = do ...@@ -470,12 +470,12 @@ hsc_typecheck keep_rn mod_summary mb_rdr_module = do
dflags = hsc_dflags hsc_env dflags = hsc_dflags hsc_env
outer_mod = ms_mod mod_summary outer_mod = ms_mod mod_summary
mod_name = moduleName outer_mod mod_name = moduleName outer_mod
outer_mod' = mkModule (thisPackage dflags) mod_name outer_mod' = mkHomeModule dflags mod_name
inner_mod = canonicalizeHomeModule dflags mod_name inner_mod = canonicalizeHomeModule dflags mod_name
src_filename = ms_hspp_file mod_summary src_filename = ms_hspp_file mod_summary
real_loc = realSrcLocSpan $ mkRealSrcLoc (mkFastString src_filename) 1 1 real_loc = realSrcLocSpan $ mkRealSrcLoc (mkFastString src_filename) 1 1
keep_rn' = gopt Opt_WriteHie dflags || keep_rn 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) tc_result <- if hsc_src == HsigFile && not (isHoleModule inner_mod)
then ioMsgMaybe $ tcRnInstantiateSignature hsc_env outer_mod' real_loc then ioMsgMaybe $ tcRnInstantiateSignature hsc_env outer_mod' real_loc
else else
...@@ -1116,8 +1116,8 @@ hscCheckSafe' m l = do ...@@ -1116,8 +1116,8 @@ hscCheckSafe' m l = do
dflags <- getDynFlags dflags <- getDynFlags
(tw, pkgs) <- isModSafe m l (tw, pkgs) <- isModSafe m l
case tw of case tw of
False -> return (Nothing, pkgs) False -> return (Nothing, pkgs)
True | isHomePkg dflags m -> return (Nothing, pkgs) True | isHomeModule dflags m -> return (Nothing, pkgs)
-- TODO: do we also have to check the trust of the instantiation? -- TODO: do we also have to check the trust of the instantiation?
-- Not necessary if that is reflected in dependencies -- Not necessary if that is reflected in dependencies
| otherwise -> return (Just $ toUnitId (moduleUnit m), pkgs) | otherwise -> return (Just $ toUnitId (moduleUnit m), pkgs)
...@@ -1191,7 +1191,7 @@ hscCheckSafe' m l = do ...@@ -1191,7 +1191,7 @@ hscCheckSafe' m l = do
packageTrusted _ Sf_Safe False _ = True packageTrusted _ Sf_Safe False _ = True
packageTrusted _ Sf_SafeInferred False _ = True packageTrusted _ Sf_SafeInferred False _ = True
packageTrusted dflags _ _ m packageTrusted dflags _ _ m
| isHomePkg dflags m = True | isHomeModule dflags m = True
| otherwise = unitIsTrusted $ unsafeGetUnitInfo dflags (moduleUnit m) | otherwise = unitIsTrusted $ unsafeGetUnitInfo dflags (moduleUnit m)
lookup' :: Module -> Hsc (Maybe ModIface) lookup' :: Module -> Hsc (Maybe ModIface)
...@@ -1210,11 +1210,6 @@ hscCheckSafe' m l = do ...@@ -1210,11 +1210,6 @@ hscCheckSafe' m l = do
return iface' return iface'
isHomePkg :: DynFlags -> Module -> Bool
isHomePkg dflags m
| thisPackage dflags == moduleUnit m = True
| otherwise = False
-- | Check the list of packages are trusted. -- | Check the list of packages are trusted.
checkPkgTrust :: Set UnitId -> Hsc () checkPkgTrust :: Set UnitId -> Hsc ()
checkPkgTrust pkgs = do checkPkgTrust pkgs = do
...@@ -1493,7 +1488,7 @@ hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ 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 let -- Make up a module name to give the NCG. We can't pass bottom here
-- lest we reproduce #11784. -- lest we reproduce #11784.
mod_name = mkModuleName $ "Cmm$" ++ FilePath.takeFileName filename 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 -- Compile decls in Cmm files one decl at a time, to avoid re-ordering
-- them in SRT analysis. -- them in SRT analysis.
......
...@@ -656,7 +656,7 @@ discardIC hsc_env ...@@ -656,7 +656,7 @@ discardIC hsc_env
| nameIsFromExternalPackage this_pkg old_name = old_name | nameIsFromExternalPackage this_pkg old_name = old_name
| otherwise = ic_name empty_ic | otherwise = ic_name empty_ic
where where
this_pkg = thisPackage dflags this_pkg = homeUnit dflags
old_name = ic_name old_ic old_name = ic_name old_ic
-- | If there is no -o option, guess the name of target executable -- | 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 ...@@ -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_imps (repeat NotBoot) ++
zipWith f home_src_imps (repeat IsBoot) zipWith f home_src_imps (repeat IsBoot)
where f mn isBoot = GWIB where f mn isBoot = GWIB
{ gwib_mod = mkModule (thisPackage lcl_dflags) mn { gwib_mod = mkHomeModule lcl_dflags mn
, gwib_isBoot = isBoot , gwib_isBoot = isBoot
} }
...@@ -2213,7 +2213,7 @@ enableCodeGenForTH = ...@@ -2213,7 +2213,7 @@ enableCodeGenForTH =
hscTarget dflags == HscNothing && hscTarget dflags == HscNothing &&
-- Don't enable codegen for TH on indefinite packages; we -- Don't enable codegen for TH on indefinite packages; we
-- can't compile anything anyway! See #16219. -- can't compile anything anyway! See #16219.
not (isIndefinite dflags) homeUnitIsDefinite dflags
-- | Update the every ModSummary that is depended on -- | Update the every ModSummary that is depended on
-- by a module that needs unboxed tuples. We enable codegen to -- 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) ...@@ -2560,12 +2560,12 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
$$ text "Saw:" <+> quotes (ppr pi_mod_name) $$ text "Saw:" <+> quotes (ppr pi_mod_name)
$$ text "Expected:" <+> quotes (ppr wanted_mod) $$ 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 = let suggested_instantiated_with =
hcat (punctuate comma $ hcat (punctuate comma $
[ ppr k <> text "=" <> ppr v [ ppr k <> text "=" <> ppr v
| (k,v) <- ((pi_mod_name, mkHoleModule pi_mod_name) | (k,v) <- ((pi_mod_name, mkHoleModule pi_mod_name)
: thisUnitIdInsts dflags) : homeUnitInstantiations dflags)
]) ])
in throwE $ unitBag $ mkPlainErrMsg pi_local_dflags pi_mod_name_loc $ in throwE $ unitBag $ mkPlainErrMsg pi_local_dflags pi_mod_name_loc $
text "Unexpected signature:" <+> quotes (ppr pi_mod_name) text "Unexpected signature:" <+> quotes (ppr pi_mod_name)
......
...@@ -379,7 +379,7 @@ compileEmptyStub dflags hsc_env basename location mod_name = do ...@@ -379,7 +379,7 @@ compileEmptyStub dflags hsc_env basename location mod_name = do
-- https://gitlab.haskell.org/ghc/ghc/issues/12673 -- https://gitlab.haskell.org/ghc/ghc/issues/12673
-- and https://github.com/haskell/cabal/issues/2257 -- and https://github.com/haskell/cabal/issues/2257
empty_stub <- newTempName dflags TFL_CurrentModule "c" 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)) writeFile empty_stub (showSDoc dflags (pprCode CStyle src))
_ <- runPipeline StopLn hsc_env _ <- runPipeline StopLn hsc_env
(empty_stub, Nothing, Nothing) (empty_stub, Nothing, Nothing)
...@@ -1312,7 +1312,7 @@ runPhase (RealPhase cc_phase) input_fn dflags ...@@ -1312,7 +1312,7 @@ runPhase (RealPhase cc_phase) input_fn dflags
-- way we do the import depends on whether we're currently compiling -- way we do the import depends on whether we're currently compiling
-- the base package or not. -- the base package or not.
++ (if platformOS platform == OSMinGW32 && ++ (if platformOS platform == OSMinGW32 &&
thisPackage dflags == baseUnitId homeUnit dflags == baseUnitId
then [ "-DCOMPILING_BASE_PACKAGE" ] then [ "-DCOMPILING_BASE_PACKAGE" ]
else []) else [])
......
...@@ -66,7 +66,7 @@ module GHC.Driver.Session ( ...@@ -66,7 +66,7 @@ module GHC.Driver.Session (
addWay', updateWays, addWay', updateWays,
thisPackage, thisComponentId, thisUnitIdInsts, homeUnit, mkHomeModule, isHomeModule,
-- ** Log output -- ** Log output
putLogMsg, putLogMsg,
...@@ -254,7 +254,7 @@ import GHC.Unit.Module ...@@ -254,7 +254,7 @@ import GHC.Unit.Module
import {-# SOURCE #-} GHC.Driver.Plugins import {-# SOURCE #-} GHC.Driver.Plugins
import {-# SOURCE #-} GHC.Driver.Hooks import {-# SOURCE #-} GHC.Driver.Hooks
import GHC.Builtin.Names ( mAIN ) 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.Phases ( Phase(..), phaseInputExt )
import GHC.Driver.Flags import GHC.Driver.Flags
import GHC.Driver.Ways import GHC.Driver.Ways
...@@ -528,9 +528,9 @@ data DynFlags = DynFlags { ...@@ -528,9 +528,9 @@ data DynFlags = DynFlags {
solverIterations :: IntWithInf, -- ^ Number of iterations in the constraints solver solverIterations :: IntWithInf, -- ^ Number of iterations in the constraints solver
-- Typically only 1 is needed -- Typically only 1 is needed
thisUnitId :: UnitId, -- ^ Target unit-id homeUnitId :: UnitId, -- ^ Target home unit-id
thisComponentId_ :: Maybe IndefUnitId, -- ^ Unit-id to instantiate homeUnitInstanceOfId :: Maybe IndefUnitId, -- ^ Unit-id to instantiate
thisUnitIdInsts_ :: Maybe [(ModuleName, Module)], -- ^ How to instantiate the unit-id above homeUnitInstantiations:: [(ModuleName, Module)], -- ^ How to instantiate `homeUnitInstanceOfId` unit
-- ways -- ways
ways :: Set Way, -- ^ Way flags from the command line ways :: Set Way, -- ^ Way flags from the command line
...@@ -1329,9 +1329,9 @@ defaultDynFlags mySettings llvmConfig = ...@@ -1329,9 +1329,9 @@ defaultDynFlags mySettings llvmConfig =
reductionDepth = treatZeroAsInf mAX_REDUCTION_DEPTH, reductionDepth = treatZeroAsInf mAX_REDUCTION_DEPTH,
solverIterations = treatZeroAsInf mAX_SOLVER_ITERATIONS, solverIterations = treatZeroAsInf mAX_SOLVER_ITERATIONS,
thisUnitId = toUnitId mainUnitId, homeUnitId = toUnitId mainUnitId,
thisUnitIdInsts_ = Nothing, homeUnitInstanceOfId = Nothing,
thisComponentId_ = Nothing, homeUnitInstantiations = [],
objectDir = Nothing, objectDir = Nothing,
dylibInstallName = Nothing, dylibInstallName = Nothing,
...@@ -1961,34 +1961,31 @@ setOutputHi f d = d { outputHi = f} ...@@ -1961,34 +1961,31 @@ setOutputHi f d = d { outputHi = f}
setJsonLogAction :: DynFlags -> DynFlags setJsonLogAction :: DynFlags -> DynFlags
setJsonLogAction d = d { log_action = jsonLogAction } setJsonLogAction d = d { log_action = jsonLogAction }
thisComponentId :: DynFlags -> IndefUnitId -- | Make a module in home unit
thisComponentId dflags = mkHomeModule :: DynFlags -> ModuleName -> Module
let pkgstate = pkgState dflags mkHomeModule dflags = mkModule (homeUnit dflags)
in case thisComponentId_ dflags of
Just uid -> updateIndefUnitId pkgstate uid -- | Test if the module comes from the home unit
Nothing -> isHomeModule :: DynFlags -> Module -> Bool
case thisUnitIdInsts_ dflags of isHomeModule dflags m = moduleUnit m == homeUnit dflags
Just _ ->
throwGhcException $ CmdLineError ("Use of -instantiated-with requires -this-component-id") -- | Get home unit
Nothing -> mkIndefUnitId pkgstate (unitFS (thisPackage dflags)) homeUnit :: DynFlags -> Unit
homeUnit dflags =
thisUnitIdInsts :: DynFlags -> [(ModuleName, Module)] case (homeUnitInstanceOfId dflags, homeUnitInstantiations dflags) of
thisUnitIdInsts dflags = (Nothing,[]) -> RealUnit (Definite (homeUnitId dflags))
case thisUnitIdInsts_ dflags of (Nothing, _) -> throwGhcException $ CmdLineError ("Use of -instantiated-with requires -this-component-id")
Just insts -> insts (Just _, []) -> throwGhcException $ CmdLineError ("Use of -this-component-id requires -instantiated-with")
Nothing -> [] (Just u, is)
-- detect fully indefinite units: all their instantiations are hole
thisPackage :: DynFlags -> Unit -- modules and the home unit id is the same as the instantiating unit
thisPackage dflags = -- id (see Note [About units] in GHC.Unit)
case thisUnitIdInsts_ dflags of | all (isHoleModule . snd) is && u == homeUnitId dflags
Nothing -> default_uid -> mkVirtUnit (updateIndefUnitId (pkgState dflags) u) is
Just insts -- otherwise it must be that we compile a fully definite units
| all (\(x,y) -> mkHoleModule x == y) insts -- TODO: error when the unit is partially instantiated??
-> mkVirtUnit (thisComponentId dflags) insts | otherwise
| otherwise -> RealUnit (Definite (homeUnitId dflags))
-> default_uid
where
default_uid = RealUnit (Definite (thisUnitId dflags))
parseUnitInsts :: String -> Instantiations parseUnitInsts :: String -> Instantiations
parseUnitInsts str = case filter ((=="").snd) (readP_to_S parse str) of 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 ...@@ -2001,13 +1998,13 @@ parseUnitInsts str = case filter ((=="").snd) (readP_to_S parse str) of
m <- parseHoleyModule