Commit ffc0d578 authored by Sylvain Henry's avatar Sylvain Henry
Browse files

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
parent cf97889a
Pipeline #23387 passed with stages
in 406 minutes and 28 seconds
......@@ -312,7 +312,7 @@ import GHC.Tc.Utils.Monad ( finalSafeMode, fixSafeInstances, initIfaceTcRn )
import GHC.Iface.Load ( loadSysInterface )
import GHC.Tc.Types
import GHC.Core.Predicate
import GHC.Unit.State
import GHC.Unit
import GHC.Types.Name.Set
import GHC.Types.Name.Reader
import GHC.Hs
......@@ -342,7 +342,6 @@ import GHC.Driver.Ppr
import GHC.SysTools
import GHC.SysTools.BaseDir
import GHC.Types.Annotations
import GHC.Unit.Module
import GHC.Utils.Panic
import GHC.Platform
import GHC.Data.Bag ( listToBag )
......@@ -1165,8 +1164,12 @@ getInsts = withSession $ \hsc_env ->
return $ ic_instances (hsc_IC hsc_env)
getPrintUnqual :: GhcMonad m => m PrintUnqualified
getPrintUnqual = withSession $ \hsc_env ->
return (icPrintUnqual (hsc_dflags hsc_env) (hsc_IC hsc_env))
getPrintUnqual = withSession $ \hsc_env -> do
let dflags = hsc_dflags hsc_env
return $ icPrintUnqual
(unitState dflags)
(mkHomeUnitFromFlags dflags)
(hsc_IC hsc_env)
-- | Container for information about a 'Module'.
data ModuleInfo = ModuleInfo {
......@@ -1261,7 +1264,11 @@ mkPrintUnqualifiedForModule :: GhcMonad m =>
ModuleInfo
-> m (Maybe PrintUnqualified) -- XXX: returns a Maybe X
mkPrintUnqualifiedForModule minf = withSession $ \hsc_env -> do
return (fmap (mkPrintUnqualified (hsc_dflags hsc_env)) (minf_rdr_env minf))
let dflags = hsc_dflags hsc_env
mk_print_unqual = mkPrintUnqualified
(unitState dflags)
(mkHomeUnitFromFlags dflags)
return (fmap mk_print_unqual (minf_rdr_env minf))
modInfoLookupName :: GhcMonad m =>
ModuleInfo -> Name
......@@ -1494,12 +1501,10 @@ showRichTokenStream ts = go startLoc ts ""
-- using the algorithm that is used for an @import@ declaration.
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 = homeUnit dflags
--
let dflags = hsc_dflags hsc_env
home_unit = mkHomeUnitFromFlags dflags
case maybe_pkg of
Just pkg | fsToUnit pkg /= this_pkg && pkg /= fsLit "this" -> liftIO $ do
Just pkg | not (isHomeUnit home_unit (fsToUnit pkg)) && pkg /= fsLit "this" -> liftIO $ do
res <- findImportedModule hsc_env mod_name maybe_pkg
case res of
Found _ m -> return m
......@@ -1511,7 +1516,7 @@ findModule mod_name maybe_pkg = withSession $ \hsc_env -> do
Nothing -> liftIO $ do
res <- findImportedModule hsc_env mod_name maybe_pkg
case res of
Found loc m | moduleUnit m /= this_pkg -> return m
Found loc m | not (isHomeModule home_unit m) -> return m
| otherwise -> modNotLoadedError dflags m loc
err -> throwOneError $ noModError dflags noSrcSpan mod_name err
......
......@@ -101,7 +101,10 @@ core2core hsc_env guts@(ModGuts { mg_module = mod
dflags = hsc_dflags hsc_env
home_pkg_rules = hptRules hsc_env (dep_mods deps)
hpt_rule_base = mkRuleBase home_pkg_rules
print_unqual = mkPrintUnqualified dflags rdr_env
print_unqual = mkPrintUnqualified
(unitState dflags)
(mkHomeUnitFromFlags dflags)
rdr_env
-- mod: get the module out of the current HscEnv so we can retrieve it from the monad.
-- This is very convienent for the users of the monad (e.g. plugins do not have to
-- consume the ModGuts to find the module) but somewhat ugly because mg_module may
......@@ -663,7 +666,7 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode)
}
where
dflags = hsc_dflags hsc_env
print_unqual = mkPrintUnqualified dflags rdr_env
print_unqual = mkPrintUnqualified (unitState dflags) (mkHomeUnitFromFlags dflags) rdr_env
simpl_env = mkSimplEnv mode
active_rule = activeRule mode
active_unf = activeUnfolding mode
......
......@@ -48,7 +48,7 @@ import GHC.Types.Id.Info
import GHC.Builtin.Types
import GHC.Core.DataCon
import GHC.Types.Basic
import GHC.Unit.Module
import GHC.Unit
import GHC.Types.Unique.Supply
import GHC.Data.Maybe
import GHC.Data.OrdList
......@@ -1496,10 +1496,11 @@ mkConvertNumLiteral hsc_env = do
let
dflags = hsc_dflags hsc_env
platform = targetPlatform dflags
home_unit = mkHomeUnitFromFlags dflags
guardBignum act
| homeUnitId dflags == primUnitId
| isHomeUnitInstanceOf home_unit primUnitId
= return $ panic "Bignum literals are not supported in ghc-prim"
| homeUnitId dflags == bignumUnitId
| isHomeUnitInstanceOf home_unit bignumUnitId
= return $ panic "Bignum literals are not supported in ghc-bignum"
| otherwise = act
......
......@@ -137,7 +137,7 @@ withBkpSession :: IndefUnitId
-> BkpM a
withBkpSession cid insts deps session_type do_this = do
dflags <- getDynFlags
let cid_fs = unitIdFS (indefUnit cid)
let cid_fs = unitFS (indefUnit cid)
is_primary = False
uid_str = unpackFS (mkInstantiatedUnitHash cid insts)
cid_str = unpackFS cid_fs
......@@ -172,12 +172,12 @@ withBkpSession cid insts deps session_type do_this = do
backend = case session_type of
TcSession -> NoBackend
_ -> backend dflags,
homeUnitInstantiations = insts,
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 =
homeUnitInstanceOf_ = if null insts then Nothing else Just (indefUnit cid),
homeUnitId_ =
case session_type of
TcSession -> newUnitId cid Nothing
-- No hash passed if no instances
......@@ -286,7 +286,6 @@ buildUnit session cid insts lunit = do
dflags <- getDynFlags
mod_graph <- hsunitModuleGraph dflags (unLoc lunit)
-- pprTrace "mod_graph" (ppr mod_graph) $ return ()
msg <- mkBackpackMsg
ok <- load' LoadAllTargets (Just msg) mod_graph
......@@ -310,6 +309,7 @@ buildUnit session cid insts lunit = do
let compat_fs = unitIdFS (indefUnit cid)
compat_pn = PackageName compat_fs
unit_id = homeUnitId (mkHomeUnitFromFlags (hsc_dflags hsc_env))
return GenericUnitInfo {
-- Stub data
......@@ -317,7 +317,7 @@ buildUnit session cid insts lunit = do
unitPackageId = PackageId compat_fs,
unitPackageName = compat_pn,
unitPackageVersion = makeVersion [],
unitId = toUnitId (homeUnit dflags),
unitId = unit_id,
unitComponentName = Nothing,
unitInstanceOf = cid,
unitInstantiations = insts,
......@@ -562,7 +562,7 @@ type PackageNameMap a = Map PackageName a
-- to use this for anything
unitDefines :: UnitState -> LHsUnit PackageName -> (PackageName, HsComponentId)
unitDefines pkgstate (L _ HsUnit{ hsunitName = L _ pn@(PackageName fs) })
= (pn, HsComponentId pn (updateIndefUnitId pkgstate (Indefinite (UnitId fs) Nothing)))
= (pn, HsComponentId pn (mkIndefUnitId pkgstate (UnitId fs)))
bkpPackageNameMap :: UnitState -> [LHsUnit PackageName] -> PackageNameMap HsComponentId
bkpPackageNameMap pkgstate units = Map.fromList (map (unitDefines pkgstate) units)
......@@ -642,6 +642,7 @@ hsunitModuleGraph :: DynFlags -> HsUnit HsComponentId -> BkpM ModuleGraph
hsunitModuleGraph dflags unit = do
let decls = hsunitBody unit
pn = hsPackageName (unLoc (hsunitName unit))
home_unit = mkHomeUnitFromFlags dflags
-- 1. Create a HsSrcFile/HsigFile summary for every
-- explicitly mentioned module/signature.
......@@ -655,7 +656,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 (homeUnitInstantiations dflags) $ \(mod_name, _) ->
req_nodes <- fmap catMaybes . forM (homeUnitInstantiations home_unit) $ \(mod_name, _) ->
let has_local = Map.member (mod_name, True) node_map
in if has_local
then return Nothing
......
......@@ -76,10 +76,9 @@ flushFinderCaches :: HscEnv -> IO ()
flushFinderCaches hsc_env =
atomicModifyIORef' fc_ref $ \fm -> (filterInstalledModuleEnv is_ext fm, ())
where
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
fc_ref = hsc_FC hsc_env
home_unit = mkHomeUnitFromFlags (hsc_dflags hsc_env)
is_ext mod _ = not (isHomeInstalledModule home_unit mod)
addToFinderCache :: IORef FinderCache -> InstalledModule -> InstalledFindResult -> IO ()
addToFinderCache ref key val =
......@@ -136,8 +135,8 @@ 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` homeUnit dflags
let home_unit = mkHomeUnitFromFlags (hsc_dflags hsc_env)
in if isHomeInstalledModule home_unit mod
then findInstalledHomeModule hsc_env (moduleName mod)
else findPackageModule hsc_env mod
......@@ -176,7 +175,8 @@ orIfNotFound this or_this = do
-- was successful.)
homeSearchCache :: HscEnv -> ModuleName -> IO InstalledFindResult -> IO InstalledFindResult
homeSearchCache hsc_env mod_name do_this = do
let mod = mkHomeInstalledModule (hsc_dflags hsc_env) mod_name
let home_unit = mkHomeUnitFromFlags (hsc_dflags hsc_env)
mod = mkHomeInstalledModule home_unit mod_name
modLocationCache hsc_env mod do_this
findExposedPackageModule :: HscEnv -> ModuleName -> Maybe FastString
......@@ -248,21 +248,18 @@ modLocationCache hsc_env mod do_this = do
addToFinderCache (hsc_FC hsc_env) mod result
return result
mkHomeInstalledModule :: DynFlags -> ModuleName -> InstalledModule
mkHomeInstalledModule dflags mod_name =
let iuid = homeUnitId dflags
in Module iuid mod_name
-- This returns a module because it's more convenient for users
addHomeModuleToFinder :: HscEnv -> ModuleName -> ModLocation -> IO Module
addHomeModuleToFinder hsc_env mod_name loc = do
let mod = mkHomeInstalledModule (hsc_dflags hsc_env) mod_name
let home_unit = mkHomeUnitFromFlags (hsc_dflags hsc_env)
mod = mkHomeInstalledModule home_unit mod_name
addToFinderCache (hsc_FC hsc_env) mod (InstalledFound loc mod)
return (mkHomeModule (hsc_dflags hsc_env) mod_name)
return (mkHomeModule home_unit mod_name)
uncacheModule :: HscEnv -> ModuleName -> IO ()
uncacheModule hsc_env mod_name = do
let mod = mkHomeInstalledModule (hsc_dflags hsc_env) mod_name
let home_unit = mkHomeUnitFromFlags (hsc_dflags hsc_env)
mod = mkHomeInstalledModule home_unit mod_name
removeFromFinderCache (hsc_FC hsc_env) mod
-- -----------------------------------------------------------------------------
......@@ -272,7 +269,7 @@ findHomeModule :: HscEnv -> ModuleName -> IO FindResult
findHomeModule hsc_env mod_name = do
r <- findInstalledHomeModule hsc_env mod_name
return $ case r of
InstalledFound loc _ -> Found loc (mkModule uid mod_name)
InstalledFound loc _ -> Found loc (mkHomeModule home_unit mod_name)
InstalledNoPackage _ -> NoPackage uid -- impossible
InstalledNotFound fps _ -> NotFound {
fr_paths = fps,
......@@ -283,8 +280,9 @@ findHomeModule hsc_env mod_name = do
fr_suggestions = []
}
where
dflags = hsc_dflags hsc_env
uid = homeUnit dflags
dflags = hsc_dflags hsc_env
home_unit = mkHomeUnitFromFlags dflags
uid = homeUnitAsUnit (mkHomeUnitFromFlags 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
......@@ -307,9 +305,10 @@ findInstalledHomeModule hsc_env mod_name =
homeSearchCache hsc_env mod_name $
let
dflags = hsc_dflags hsc_env
home_unit = mkHomeUnitFromFlags dflags
home_path = importPaths dflags
hisuf = hiSuf dflags
mod = mkHomeInstalledModule dflags mod_name
mod = mkHomeInstalledModule home_unit mod_name
source_exts =
[ ("hs", mkHomeModLocationSearched dflags mod_name "hs")
......@@ -675,6 +674,7 @@ cantFindErr cannot_find _ dflags mod_name find_result
$$ more_info
where
pkgs = unitState dflags
home_unit = mkHomeUnitFromFlags dflags
more_info
= case find_result of
NoPackage pkg
......@@ -684,7 +684,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 /= homeUnit dflags
| Just pkg <- mb_pkg, not (isHomeUnit home_unit pkg)
-> not_found_in_package pkg files
| not (null suggest)
......@@ -793,6 +793,10 @@ cantFindInstalledErr cannot_find _ dflags mod_name find_result
= ptext cannot_find <+> quotes (ppr mod_name)
$$ more_info
where
home_unit = mkHomeUnitFromFlags dflags
unit_state = unitState dflags
build_tag = waysBuildTag (ways dflags)
more_info
= case find_result of
InstalledNoPackage pkg
......@@ -800,7 +804,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` homeUnit dflags)
| Just pkg <- mb_pkg, not (isHomeUnitId home_unit pkg)
-> not_found_in_package pkg files
| null files
......@@ -811,14 +815,11 @@ cantFindInstalledErr cannot_find _ dflags mod_name find_result
_ -> panic "cantFindInstalledErr"
build_tag = waysBuildTag (ways dflags)
pkgstate = unitState dflags
looks_like_srcpkgid :: UnitId -> SDoc
looks_like_srcpkgid pk
-- Unsafely coerce a unit id (i.e. an installed package component
-- identifier) into a PackageId and see if it means anything.
| (pkg:pkgs) <- searchPackageId pkgstate (PackageId (unitIdFS pk))
| (pkg:pkgs) <- searchPackageId unit_state (PackageId (unitIdFS pk))
= parens (text "This unit ID looks like the source package ID;" $$
text "the real unit ID is" <+> quotes (ftext (unitIdFS (unitId pkg))) $$
(if null pkgs then Outputable.empty
......
......@@ -101,8 +101,7 @@ import GHC.Utils.Panic
import GHC.Core.ConLike
import GHC.Parser.Annotation
import GHC.Unit.Module
import GHC.Unit.State
import GHC.Unit
import GHC.Types.Name.Reader
import GHC.Hs
import GHC.Hs.Dump
......@@ -194,7 +193,8 @@ import GHC.Iface.Ext.Debug ( diffFile, validateScopes )
newHscEnv :: DynFlags -> IO HscEnv
newHscEnv dflags = do
eps_var <- newIORef (initExternalPackageState dflags)
let home_unit = mkHomeUnitFromFlags dflags
eps_var <- newIORef (initExternalPackageState home_unit)
us <- mkSplitUniqSupply 'r'
nc_var <- newIORef (initNameCache us knownKeyNames)
fc_var <- newIORef emptyInstalledModuleEnv
......@@ -469,14 +469,15 @@ hsc_typecheck keep_rn mod_summary mb_rdr_module = do
hsc_env <- getHscEnv
let hsc_src = ms_hsc_src mod_summary
dflags = hsc_dflags hsc_env
home_unit = mkHomeUnitFromFlags dflags
outer_mod = ms_mod mod_summary
mod_name = moduleName outer_mod
outer_mod' = mkHomeModule dflags mod_name
inner_mod = canonicalizeHomeModule dflags mod_name
outer_mod' = mkHomeModule home_unit mod_name
inner_mod = homeModuleNameInstantiation home_unit 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( isHomeModule dflags outer_mod )
MASSERT( isHomeModule home_unit outer_mod )
tc_result <- if hsc_src == HsigFile && not (isHoleModule inner_mod)
then ioMsgMaybe $ tcRnInstantiateSignature hsc_env outer_mod' real_loc
else
......@@ -1115,10 +1116,11 @@ hscCheckSafe' :: Module -> SrcSpan
-> Hsc (Maybe UnitId, Set UnitId)
hscCheckSafe' m l = do
dflags <- getDynFlags
let home_unit = mkHomeUnitFromFlags dflags
(tw, pkgs) <- isModSafe m l
case tw of
False -> return (Nothing, pkgs)
True | isHomeModule dflags m -> return (Nothing, pkgs)
False -> return (Nothing, pkgs)
True | isHomeModule home_unit 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)
......@@ -1193,7 +1195,7 @@ hscCheckSafe' m l = do
packageTrusted _ Sf_Safe False _ = True
packageTrusted _ Sf_SafeInferred False _ = True
packageTrusted dflags _ _ m
| isHomeModule dflags m = True
| isHomeModule (mkHomeUnitFromFlags dflags) m = True
| otherwise = unitIsTrusted $ unsafeLookupUnit (unitState dflags) (moduleUnit m)
lookup' :: Module -> Hsc (Maybe ModIface)
......@@ -1486,14 +1488,15 @@ hscInteractive hsc_env cgguts location = do
hscCompileCmmFile :: HscEnv -> FilePath -> FilePath -> IO ()
hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do
let dflags = hsc_dflags hsc_env
let dflags = hsc_dflags hsc_env
home_unit = mkHomeUnitFromFlags dflags
cmm <- ioMsgMaybe $ parseCmmFile dflags filename
liftIO $ do
dumpIfSet_dyn dflags Opt_D_dump_cmm_verbose_by_proc "Parsed Cmm" FormatCMM (ppr cmm)
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 = mkHomeModule dflags mod_name
cmm_mod = mkHomeModule home_unit mod_name
-- Compile decls in Cmm files one decl at a time, to avoid re-ordering
-- them in SRT analysis.
......
......@@ -46,7 +46,7 @@ import GHC.Driver.Finder
import GHC.Driver.Monad
import GHC.Parser.Header
import GHC.Driver.Types
import GHC.Unit.Module
import GHC.Unit
import GHC.IfaceToCore ( typecheckIface )
import GHC.Tc.Utils.Monad ( initIfaceCheck )
import GHC.Driver.Main
......@@ -66,7 +66,6 @@ import GHC.Data.StringBuffer
import GHC.Types.Unique.FM
import GHC.Types.Unique.DSet
import GHC.Tc.Utils.Backpack
import GHC.Unit.State
import GHC.Types.Unique.Set
import GHC.Utils.Misc
import qualified GHC.LanguageExtensions as LangExt
......@@ -655,10 +654,10 @@ discardIC hsc_env
old_ic = hsc_IC hsc_env
empty_ic = emptyInteractiveContext dflags
keep_external_name ic_name
| nameIsFromExternalPackage this_pkg old_name = old_name
| nameIsFromExternalPackage home_unit old_name = old_name
| otherwise = ic_name empty_ic
where
this_pkg = homeUnit dflags
home_unit = mkHomeUnitFromFlags dflags
old_name = ic_name old_ic
-- | If there is no -o option, guess the name of target executable
......@@ -1202,13 +1201,14 @@ parUpsweep_one mod home_mod_map comp_graph_loops lcl_dflags mHscMessage cleanup
let home_imps = map unLoc $ ms_home_imps mod
let home_src_imps = map unLoc $ ms_home_srcimps mod
let home_unit = mkHomeUnitFromFlags lcl_dflags
-- All the textual imports of this module.
let textual_deps = Set.fromList $
zipWith f home_imps (repeat NotBoot) ++
zipWith f home_src_imps (repeat IsBoot)
where f mn isBoot = GWIB
{ gwib_mod = mkHomeModule lcl_dflags mn
{ gwib_mod = mkHomeModule home_unit mn
, gwib_isBoot = isBoot
}
......@@ -2210,7 +2210,7 @@ enableCodeGenForTH =
backend dflags == NoBackend &&
-- Don't enable codegen for TH on indefinite packages; we
-- can't compile anything anyway! See #16219.
homeUnitIsDefinite dflags
isHomeUnitDefinite (mkHomeUnitFromFlags dflags)
-- | Update the every ModSummary that is depended on
-- by a module that needs unboxed tuples. We enable codegen to
......@@ -2499,6 +2499,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
| otherwise = find_it
where
dflags = hsc_dflags hsc_env
home_unit = mkHomeUnitFromFlags dflags
check_timestamp old_summary location src_fn =
checkSummaryTimestamp
......@@ -2557,12 +2558,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 (homeUnitInstantiations dflags))) $
when (hsc_src == HsigFile && isNothing (lookup pi_mod_name (homeUnitInstantiations home_unit))) $
let suggested_instantiated_with =
hcat (punctuate comma $
[ ppr k <> text "=" <> ppr v
| (k,v) <- ((pi_mod_name, mkHoleModule pi_mod_name)
: homeUnitInstantiations dflags)
: homeUnitInstantiations home_unit)
])
in throwE $ unitBag $ mkPlainErrMsg pi_local_dflags pi_mod_name_loc $
text "Unexpected signature:" <+> quotes (ppr pi_mod_name)
......
......@@ -40,7 +40,7 @@ module GHC.Driver.Pipeline (
import GHC.Prelude
import GHC.Driver.Pipeline.Monad
import GHC.Unit.State
import GHC.Unit
import GHC.Platform.Ways
import GHC.Platform.ArchOS
import GHC.Parser.Header
......@@ -51,7 +51,6 @@ import GHC.Driver.Main
import GHC.Driver.Finder
import GHC.Driver.Types hiding ( Hsc )
import GHC.Utils.Outputable
import GHC.Unit.Module
import GHC.Utils.Error
import GHC.Driver.Session
import GHC.Driver.Backend
......@@ -382,7 +381,8 @@ 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 (mkHomeModule dflags mod_name) <+> text "= 0;"
let home_unit = mkHomeUnitFromFlags dflags
src = text "int" <+> ppr (mkHomeModule home_unit mod_name) <+> text "= 0;"
writeFile empty_stub (showSDoc dflags (pprCode CStyle src))
_ <- runPipeline StopLn hsc_env
(empty_stub, Nothing, Nothing)
......@@ -516,9 +516,9 @@ linkingNeeded dflags staticLink linkables pkg_deps = do
-- next, check libraries. XXX this only checks Haskell libraries,
-- not extra_libraries or -l things from the command line.
let pkgstate = unitState dflags
let pkg_hslibs = [ (collectLibraryPaths dflags [c], lib)
| Just c <- map (lookupUnitId pkgstate) pkg_deps,
let unit_state = unitState dflags
let pkg_hslibs = [ (collectLibraryPaths (ways dflags) [c], lib)
| Just c <- map (lookupUnitId unit_state) pkg_deps,
lib <- packageHsLibs dflags c ]
pkg_libfiles <- mapM (uncurry (findHSLib dflags)) pkg_hslibs
......@@ -1227,6 +1227,7 @@ runPhase (RealPhase cc_phase) input_fn dflags
= do
let platform = targetPlatform dflags
hcc = cc_phase `eqPhase` HCc
home_unit = mkHomeUnitFromFlags dflags
let cmdline_include_paths = includePaths dflags
......@@ -1236,7 +1237,11 @@ runPhase (RealPhase cc_phase) input_fn dflags
-- add package include paths even if we're just compiling .c
-- files; this is the Value Add(TM) that using ghc instead of
-- gcc gives you :)
pkg_include_dirs <- liftIO $ getUnitIncludePath dflags pkgs
pkg_include_dirs <- liftIO $ getUnitIncludePath
(initSDocContext dflags defaultUserStyle)
(unitState dflags)
(mkHomeUnitFromFlags dflags)
pkgs
let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) []
(includePathsGlobal cmdline_include_paths ++ pkg_include_dirs)
let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) []
......@@ -1264,11 +1269,19 @@ runPhase (RealPhase cc_phase) input_fn dflags
pkg_extra_cc_opts <- liftIO $
if hcc
then return []
else getUnitExtraCcOpts dflags pkgs
else getUnitExtraCcOpts
(initSDocContext dflags defaultUserStyle)
(unitState dflags)
(mkHomeUnitFromFlags dflags)
pkgs
framework_paths <-
if platformUsesFrameworks platform
then do pkgFrameworkPaths <- liftIO $ getUnitFrameworkPath dflags pkgs
then do pkgFrameworkPaths <- liftIO $ getUnitFrameworkPath
(initSDocContext dflags defaultUserStyle)
(unitState dflags)
(mkHomeUnitFromFlags dflags)
pkgs
let cmdlineFrameworkPaths = frameworkPaths dflags
return $ map ("-F"++)
(cmdlineFrameworkPaths ++ pkgFrameworkPaths)
......@@ -1315,7 +1328,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 &&
homeUnitId dflags == baseUnitId
isHomeUnitId home_unit baseUnitId
then [ "-DCOMPILING_BASE_PACKAGE" ]
else [])
......@@ -1671,7 +1684,12 @@ linkBinary' staticLink dflags o_files dep_units = do
then return output_fn
else do d <- getCurrentDirectory
return $ normalise (d </> output_fn)
pkg_lib_paths <- getUnitLibraryPath dflags dep_units
pkg_lib_paths <- getUnitLibraryPath
(initSDocContext dflags defaultUserStyle)
(unitState dflags)
(mkHomeUnitFromFlags dflags)
(ways dflags)
dep_units
let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths
get_pkg_lib_path_opts l
| osElfTarget (platformOS platform) &&
......@@ -1940,7 +1958,11 @@ linkStaticLib dflags o_files dep_units = do
output_exists <- doesFileExist full_output_fn
(when output_exists) $ removeFile full_output_fn
pkg_cfgs_init <- getPreloadUnitsAnd dflags dep_units
pkg_cfgs_init <- getPreloadUnitsAnd
(initSDocContext dflags defaultUserStyle)
(unitState dflags)
(mkHomeUnitFromFlags dflags)
dep_units
let pkg_cfgs
| gopt Opt_LinkRts dflags
......@@ -1969,7 +1991,11 @@ doCpp dflags raw input_fn output_fn = do
let hscpp_opts = picPOpts dflags
let cmdline_include_paths = includePaths dflags
pkg_include_dirs <- getUnitIncludePath dflags []
pkg_include_dirs <- getUnitIncludePath
(initSDocContext dflags defaultUserStyle)