Commit 5bd8e8d3 authored by Edward Z. Yang's avatar Edward Z. Yang

Make InstalledUnitId be ONLY a FastString.

It turns out that we don't really need to be able to
extract a ComponentId from UnitId, except in one case.
So compress UnitId into a single FastString.

The one case where we do need the ComponentId is when
we are compiling an instantiated version of a package;
we need the ComponentId to look up the indefinite
version of this package from the database.  So now we
just pass it in as an argument -this-component-id.

Also: ghc-pkg now no longer will unregister a package if
you register one with the same package name, if the
instantiations don't match.

Cabal submodule update which tracks the same data type
change.
Signed-off-by: default avatarEdward Z. Yang <ezyang@cs.stanford.edu>
parent 4e8a0607
......@@ -155,13 +155,14 @@ withBkpSession cid insts deps session_type do_this = do
hscTarget = case session_type of
TcSession -> HscNothing
_ -> hscTarget dflags,
thisUnitIdInsts = insts,
thisPackage =
thisUnitIdInsts_ = Just insts,
thisComponentId_ = Just cid,
thisInstalledUnitId =
case session_type of
TcSession -> newUnitId cid insts
TcSession -> newInstalledUnitId cid Nothing
-- No hash passed if no instances
_ | null insts -> newSimpleUnitId cid
| otherwise -> newDefiniteUnitId cid (Just (hashUnitId cid insts)),
_ | null insts -> newInstalledUnitId cid Nothing
| otherwise -> newInstalledUnitId cid (Just (hashUnitId cid insts)),
-- Setup all of the output directories according to our hierarchy
objectDir = Just (outdir objectDir),
hiDir = Just (outdir hiDir),
......@@ -186,7 +187,7 @@ withBkpSession cid insts deps session_type do_this = do
withBkpExeSession :: [(UnitId, ModRenaming)] -> BkpM a -> BkpM a
withBkpExeSession deps do_this = do
withBkpSession (unitIdComponentId mainUnitId) [] deps ExeSession do_this
withBkpSession (ComponentId (fsLit "main")) [] deps ExeSession do_this
getSource :: ComponentId -> BkpM (LHsUnit HsComponentId)
getSource cid = do
......@@ -282,6 +283,7 @@ buildUnit session cid insts lunit = do
packageName = compat_pn,
packageVersion = makeVersion [0],
unitId = toInstalledUnitId (thisPackage dflags),
componentId = cid,
instantiatedWith = insts,
-- Slight inefficiency here haha
exposedModules = map (\(m,n) -> (m,Just n)) mods,
......@@ -366,8 +368,9 @@ compileInclude n (i, uid) = do
case lookupPackage dflags uid of
Nothing -> do
case splitUnitIdInsts uid of
(_, Just insts) ->
innerBkpM $ compileUnit (unitIdComponentId uid) insts
(_, Just indef) ->
innerBkpM $ compileUnit (indefUnitIdComponentId indef)
(indefUnitIdInsts indef)
_ -> return ()
Just _ -> return ()
......@@ -778,3 +781,11 @@ hsModuleToModSummary pn hsc_src modname
ms_obj_date = Nothing, -- TODO do this, but problem: hi_timestamp is BOGUS
ms_iface_date = hi_timestamp
}
-- | Create a new, externally provided hashed unit id from
-- a hash.
newInstalledUnitId :: ComponentId -> Maybe FastString -> InstalledUnitId
newInstalledUnitId (ComponentId cid_fs) (Just fs)
= InstalledUnitId (cid_fs `appendFS` mkFastString "+" `appendFS` fs)
newInstalledUnitId (ComponentId cid_fs) Nothing
= InstalledUnitId cid_fs
......@@ -11,7 +11,6 @@ the keys.
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Module
(
......@@ -33,8 +32,8 @@ module Module
UnitId(..),
unitIdFS,
unitIdKey,
unitIdComponentId,
IndefUnitId(..),
IndefModule(..),
InstalledUnitId(..),
toInstalledUnitId,
ShHoleSubst,
......@@ -46,7 +45,6 @@ module Module
newUnitId,
newIndefUnitId,
newSimpleUnitId,
newDefiniteUnitId,
hashUnitId,
fsToUnitId,
stringToUnitId,
......@@ -101,8 +99,8 @@ module Module
installedModuleEq,
installedUnitIdEq,
installedUnitIdString,
newInstalledUnitId,
fsToInstalledUnitId,
componentIdToInstalledUnitId,
stringToInstalledUnitId,
emptyInstalledModuleEnv,
lookupInstalledModuleEnv,
......@@ -111,9 +109,6 @@ module Module
delInstalledModuleEnv,
DefUnitId(..),
-- * Hole module
HoleModule,
-- * The ModuleLocation type
ModLocation(..),
addBootSuffix, addBootSuffix_maybe, addBootSuffixLocn,
......@@ -172,7 +167,7 @@ import qualified FiniteMap as Map
import System.FilePath
import {-# SOURCE #-} DynFlags (DynFlags)
import {-# SOURCE #-} Packages (componentIdString, improveUnitId, PackageConfigMap, getPackageConfigMap)
import {-# SOURCE #-} Packages (componentIdString, improveUnitId, PackageConfigMap, getPackageConfigMap, displayInstalledUnitId)
-- Note [The identifier lexicon]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......@@ -482,13 +477,11 @@ class ContainsModule t where
class HasModule m where
getModule :: m Module
instance DbUnitIdModuleRep ComponentId UnitId ModuleName Module where
fromDbModule (DbModule uid mod_name) = mkModule uid mod_name
fromDbModule (DbModuleVar mod_name) = mkHoleModule mod_name
fromDbUnitId (DbUnitId { dbUnitIdComponentId = cid, dbUnitIdInsts = insts })
= newUnitId cid insts
fromDbUnitId (DbInstalledUnitId cid hash) -- TODO rename this
= newDefiniteUnitId cid (fmap mkFastStringByteString hash)
instance DbUnitIdModuleRep InstalledUnitId ComponentId UnitId ModuleName Module where
fromDbModule (DbModule uid mod_name) = mkModule uid mod_name
fromDbModule (DbModuleVar mod_name) = mkHoleModule mod_name
fromDbUnitId (DbUnitId cid insts) = newUnitId cid insts
fromDbUnitId (DbInstalledUnitId iuid) = DefiniteUnitId (DefUnitId iuid)
-- GHC never writes to the database, so it's not needed
toDbModule = error "toDbModule: not implemented"
toDbUnitId = error "toDbUnitId: not implemented"
......@@ -560,10 +553,6 @@ unitIdKey :: UnitId -> Unique
unitIdKey (IndefiniteUnitId x) = indefUnitIdKey x
unitIdKey (DefiniteUnitId (DefUnitId x)) = installedUnitIdKey x
unitIdComponentId :: UnitId -> ComponentId
unitIdComponentId (IndefiniteUnitId x) = indefUnitIdComponentId x
unitIdComponentId (DefiniteUnitId (DefUnitId x)) = installedUnitIdComponentId x
-- | A unit identifier which identifies an indefinite
-- library (with holes) that has been *on-the-fly* instantiated
-- with a substitution 'indefUnitIdInsts'. In fact, an indefinite
......@@ -600,6 +589,45 @@ instance Eq IndefUnitId where
instance Ord IndefUnitId where
u1 `compare` u2 = indefUnitIdFS u1 `compare` indefUnitIdFS u2
instance Binary IndefUnitId where
put_ bh indef = do
put_ bh (indefUnitIdComponentId indef)
put_ bh (indefUnitIdInsts indef)
get bh = do
cid <- get bh
insts <- get bh
let fs = hashUnitId cid insts
return IndefUnitId {
indefUnitIdComponentId = cid,
indefUnitIdInsts = insts,
indefUnitIdFreeHoles = unionManyUniqDSets (map (moduleFreeHoles.snd) insts),
indefUnitIdFS = fs,
indefUnitIdKey = getUnique fs
}
-- | Create a new 'IndefUnitId' given an explicit module substitution.
newIndefUnitId :: ComponentId -> [(ModuleName, Module)] -> IndefUnitId
newIndefUnitId cid insts =
IndefUnitId {
indefUnitIdComponentId = cid,
indefUnitIdInsts = sorted_insts,
indefUnitIdFreeHoles = unionManyUniqDSets (map (moduleFreeHoles.snd) insts),
indefUnitIdFS = fs,
indefUnitIdKey = getUnique fs
}
where
fs = hashUnitId cid sorted_insts
sorted_insts = sortBy (stableModuleNameCmp `on` fst) insts
data IndefModule = IndefModule {
indefModuleUnitId :: IndefUnitId,
indefModuleName :: ModuleName
} deriving (Typeable, Eq, Ord)
instance Outputable IndefModule where
ppr (IndefModule uid m) =
ppr uid <> char ':' <> ppr m
-- | An installed unit identifier identifies a library which has
-- been installed to the package database. These strings are
-- provided to us via the @-this-unit-id@ flag. The library
......@@ -610,47 +638,20 @@ instance Ord IndefUnitId where
--
-- Installed unit identifiers look something like @p+af23SAj2dZ219@,
-- or maybe just @p@ if they don't use Backpack.
data InstalledUnitId =
newtype InstalledUnitId =
InstalledUnitId {
-- | The full hashed unit identifier, including the component id
-- and the hash.
installedUnitIdFS :: FastString,
-- | Cached unique of 'unitIdFS'.
installedUnitIdKey :: Unique,
-- | The component identifier of the hashed unit identifier.
installedUnitIdComponentId :: !ComponentId
installedUnitIdFS :: FastString
}
deriving (Typeable)
-- | A 'DefUnitId' is an 'InstalledUnitId' with the invariant that
-- it only refers to a definite library; i.e., one we have generated
-- code for.
newtype DefUnitId = DefUnitId { unDefUnitId :: InstalledUnitId }
deriving (Eq, Ord, Outputable, Typeable)
instance Binary InstalledUnitId where
put_ bh uid
| cid == ComponentId fs = do
putByte bh 0
put_ bh fs
| otherwise = do
putByte bh 2
put_ bh cid
put_ bh fs
where
cid = installedUnitIdComponentId uid
fs = installedUnitIdFS uid
get bh = do b <- getByte bh
case b of
0 -> fmap fsToInstalledUnitId (get bh)
_ -> do
cid <- get bh
fs <- get bh
return (rawNewInstalledUnitId cid fs)
put_ bh (InstalledUnitId fs) = put_ bh fs
get bh = do fs <- get bh; return (InstalledUnitId fs)
instance BinaryStringRep InstalledUnitId where
fromStringRep bs = rawNewInstalledUnitId (fromStringRep cid) (mkFastStringByteString bs)
where cid = BS.Char8.takeWhile (/='+') bs
fromStringRep bs = InstalledUnitId (mkFastStringByteString bs)
-- GHC doesn't write to database
toStringRep = error "BinaryStringRep InstalledUnitId: not implemented"
......@@ -664,16 +665,21 @@ instance Uniquable InstalledUnitId where
getUnique = installedUnitIdKey
instance Outputable InstalledUnitId where
ppr uid =
if installedUnitIdComponentId uid == ComponentId (installedUnitIdFS uid)
then ppr (installedUnitIdComponentId uid)
else ftext (installedUnitIdFS uid)
ppr uid@(InstalledUnitId fs) =
getPprStyle $ \sty ->
sdocWithDynFlags $ \dflags ->
case displayInstalledUnitId dflags uid of
Just str | not (debugStyle sty) -> text str
_ -> ftext fs
installedUnitIdKey :: InstalledUnitId -> Unique
installedUnitIdKey = getUnique . installedUnitIdFS
-- | Lossy conversion to the on-disk 'InstalledUnitId' for a component.
toInstalledUnitId :: UnitId -> InstalledUnitId
toInstalledUnitId (DefiniteUnitId (DefUnitId iuid)) = iuid
toInstalledUnitId (IndefiniteUnitId indef) =
newInstalledUnitId (indefUnitIdComponentId indef) Nothing
componentIdToInstalledUnitId (indefUnitIdComponentId indef)
installedUnitIdString :: InstalledUnitId -> String
installedUnitIdString = unpackFS . installedUnitIdFS
......@@ -716,7 +722,10 @@ instance Outputable InstalledModule where
ppr p <> char ':' <> pprModuleName n
fsToInstalledUnitId :: FastString -> InstalledUnitId
fsToInstalledUnitId fs = rawNewInstalledUnitId (ComponentId fs) fs
fsToInstalledUnitId fs = InstalledUnitId fs
componentIdToInstalledUnitId :: ComponentId -> InstalledUnitId
componentIdToInstalledUnitId (ComponentId fs) = fsToInstalledUnitId fs
stringToInstalledUnitId :: String -> InstalledUnitId
stringToInstalledUnitId = fsToInstalledUnitId . mkFastString
......@@ -733,6 +742,19 @@ installedUnitIdEq :: InstalledUnitId -> UnitId -> Bool
installedUnitIdEq iuid uid =
fst (splitUnitIdInsts uid) == iuid
-- | A 'DefUnitId' is an 'InstalledUnitId' with the invariant that
-- it only refers to a definite library; i.e., one we have generated
-- code for.
newtype DefUnitId = DefUnitId { unDefUnitId :: InstalledUnitId }
deriving (Eq, Ord, Typeable)
instance Outputable DefUnitId where
ppr (DefUnitId uid) = ppr uid
instance Binary DefUnitId where
put_ bh (DefUnitId uid) = put_ bh uid
get bh = do uid <- get bh; return (DefUnitId uid)
-- | A map keyed off of 'InstalledModule'
newtype InstalledModuleEnv elt = InstalledModuleEnv (Map InstalledModule elt)
......@@ -752,12 +774,6 @@ filterInstalledModuleEnv f (InstalledModuleEnv e) =
delInstalledModuleEnv :: InstalledModuleEnv a -> InstalledModule -> InstalledModuleEnv a
delInstalledModuleEnv (InstalledModuleEnv e) m = InstalledModuleEnv (Map.delete m e)
-- | A hole module is a 'Module' representing a required
-- signature that we are going to merge in. The unit id
-- of such a hole module is guaranteed to be equipped with
-- an instantiation.
type HoleModule = (IndefUnitId, ModuleName)
-- Note [UnitId to InstalledUnitId improvement]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- Just because a UnitId is definite (has no holes) doesn't
......@@ -829,52 +845,11 @@ fingerprintUnitId prefix (Fingerprint a b)
, BS.Char8.pack (toBase62Padded a)
, BS.Char8.pack (toBase62Padded b) ]
-- | Create a new, externally provided hashed unit id from
-- a hash.
newInstalledUnitId :: ComponentId -> Maybe FastString -> InstalledUnitId
newInstalledUnitId cid@(ComponentId cid_fs) (Just fs)
= rawNewInstalledUnitId cid (cid_fs `appendFS` mkFastString "+" `appendFS` fs)
newInstalledUnitId cid@(ComponentId cid_fs) Nothing
= rawNewInstalledUnitId cid cid_fs
rawNewDefiniteUnitId :: ComponentId -> FastString -> UnitId
rawNewDefiniteUnitId cid fs =
DefiniteUnitId (DefUnitId (rawNewInstalledUnitId cid fs))
-- | Create a new 'UnitId' for an instantiated unit id.
newDefiniteUnitId :: ComponentId -> Maybe FastString -> UnitId
newDefiniteUnitId cid mb_fs =
DefiniteUnitId (DefUnitId (newInstalledUnitId cid mb_fs))
-- | Smart constructor for 'InstalledUnitId'; input 'FastString'
-- is assumed to be the FULL identifying string for this
-- UnitId (e.g., it contains the 'ComponentId').
rawNewInstalledUnitId :: ComponentId -> FastString -> InstalledUnitId
rawNewInstalledUnitId cid fs = InstalledUnitId {
installedUnitIdFS = fs,
installedUnitIdKey = getUnique fs,
installedUnitIdComponentId = cid
}
-- | Create a new, un-hashed unit identifier.
newUnitId :: ComponentId -> [(ModuleName, Module)] -> UnitId
newUnitId cid [] = newSimpleUnitId cid -- TODO: this indicates some latent bug...
newUnitId cid insts = IndefiniteUnitId $ newIndefUnitId cid insts
-- | Create a new 'IndefUnitId' given an explicit module substitution.
newIndefUnitId :: ComponentId -> [(ModuleName, Module)] -> IndefUnitId
newIndefUnitId cid insts =
IndefUnitId {
indefUnitIdComponentId = cid,
indefUnitIdInsts = sorted_insts,
indefUnitIdFreeHoles = unionManyUniqDSets (map (moduleFreeHoles.snd) insts),
indefUnitIdFS = fs,
indefUnitIdKey = getUnique fs
}
where
fs = hashUnitId cid sorted_insts
sorted_insts = sortBy (stableModuleNameCmp `on` fst) insts
pprUnitId :: UnitId -> SDoc
pprUnitId (DefiniteUnitId uid) = ppr uid
pprUnitId (IndefiniteUnitId uid) = ppr uid
......@@ -906,35 +881,16 @@ instance Outputable UnitId where
-- Performance: would prefer to have a NameCache like thing
instance Binary UnitId where
put_ bh (DefiniteUnitId (DefUnitId uid))
| cid == ComponentId fs = do
putByte bh 0
put_ bh fs
| otherwise = do
putByte bh 2
put_ bh cid
put_ bh fs
where
cid = installedUnitIdComponentId uid
fs = installedUnitIdFS uid
put_ bh (IndefiniteUnitId uid) = do
put_ bh (DefiniteUnitId def_uid) = do
putByte bh 0
put_ bh def_uid
put_ bh (IndefiniteUnitId indef_uid) = do
putByte bh 1
put_ bh cid
put_ bh insts
where
cid = indefUnitIdComponentId uid
insts = indefUnitIdInsts uid
put_ bh indef_uid
get bh = do b <- getByte bh
case b of
0 -> fmap fsToUnitId (get bh)
1 -> do
cid <- get bh
insts <- get bh
return (newUnitId cid insts)
_ -> do
cid <- get bh
fs <- get bh
return (rawNewDefiniteUnitId cid fs)
0 -> fmap DefiniteUnitId (get bh)
_ -> fmap IndefiniteUnitId (get bh)
instance Binary ComponentId where
put_ bh (ComponentId fs) = put_ bh fs
......@@ -947,7 +903,7 @@ newSimpleUnitId (ComponentId fs) = fsToUnitId fs
-- | Create a new simple unit identifier from a 'FastString'. Internally,
-- this is primarily used to specify wired-in unit identifiers.
fsToUnitId :: FastString -> UnitId
fsToUnitId fs = rawNewDefiniteUnitId (ComponentId fs) fs
fsToUnitId = DefiniteUnitId . DefUnitId . InstalledUnitId
stringToUnitId :: String -> UnitId
stringToUnitId = fsToUnitId . mkFastString
......@@ -1016,15 +972,16 @@ renameHoleUnitId' pkg_map env uid =
-- a 'Module' that we definitely can find on-disk, as well as an
-- instantiation if we need to instantiate it on the fly. If the
-- instantiation is @Nothing@ no on-the-fly renaming is needed.
splitModuleInsts :: Module -> (InstalledModule, Maybe [(ModuleName, Module)])
splitModuleInsts :: Module -> (InstalledModule, Maybe IndefModule)
splitModuleInsts m =
let (uid, mb_insts) = splitUnitIdInsts (moduleUnitId m)
in (InstalledModule uid (moduleName m), mb_insts)
let (uid, mb_iuid) = splitUnitIdInsts (moduleUnitId m)
in (InstalledModule uid (moduleName m),
fmap (\iuid -> IndefModule iuid (moduleName m)) mb_iuid)
-- | See 'splitModuleInsts'.
splitUnitIdInsts :: UnitId -> (InstalledUnitId, Maybe [(ModuleName, Module)])
splitUnitIdInsts :: UnitId -> (InstalledUnitId, Maybe IndefUnitId)
splitUnitIdInsts (IndefiniteUnitId iuid) =
(newInstalledUnitId (indefUnitIdComponentId iuid) Nothing, Just (indefUnitIdInsts iuid))
(componentIdToInstalledUnitId (indefUnitIdComponentId iuid), Just iuid)
splitUnitIdInsts (DefiniteUnitId (DefUnitId uid)) = (uid, Nothing)
generalizeIndefUnitId :: IndefUnitId -> IndefUnitId
......@@ -1044,10 +1001,8 @@ parseUnitId = parseFullUnitId <++ parseDefiniteUnitId <++ parseSimpleUnitId
insts <- parseModSubst
return (newUnitId cid insts)
parseDefiniteUnitId = do
cid <- parseComponentId
_ <- Parse.char '+'
hash <- Parse.munch1 isAlphaNum
return (newDefiniteUnitId cid (Just (mkFastString hash)))
s <- Parse.munch1 (\c -> isAlphaNum c || c `elem` "-_.+")
return (stringToUnitId s)
parseSimpleUnitId = do
cid <- parseComponentId
return (newSimpleUnitId cid)
......
......@@ -4,6 +4,7 @@ import FastString
data Module
data ModuleName
data UnitId
data InstalledUnitId
newtype ComponentId = ComponentId FastString
moduleName :: Module -> ModuleName
......
......@@ -533,12 +533,12 @@ computeInterface doc_str hi_boot_file mod0 = do
MASSERT( not (isHoleModule mod0) )
dflags <- getDynFlags
case splitModuleInsts mod0 of
(imod, Just insts) | not (unitIdIsDefinite (thisPackage dflags)) -> do
(imod, Just indef) | not (unitIdIsDefinite (thisPackage dflags)) -> do
r <- findAndReadIface doc_str imod hi_boot_file
case r of
Succeeded (iface0, path) -> do
hsc_env <- getTopEnv
r <- liftIO (rnModIface hsc_env insts Nothing iface0)
r <- liftIO (rnModIface hsc_env (indefUnitIdInsts (indefModuleUnitId indef)) Nothing iface0)
return (Succeeded (r, path))
Failed err -> return (Failed err)
(mod, _) ->
......@@ -560,7 +560,8 @@ moduleFreeHolesPrecise doc_str mod
| moduleIsDefinite mod = return (Succeeded emptyUniqDSet)
| otherwise =
case splitModuleInsts mod of
(imod, Just insts) -> do
(imod, Just indef) -> do
let insts = indefUnitIdInsts (indefModuleUnitId indef)
traceIf (text "Considering whether to load" <+> ppr mod <+>
text "to compute precise free module holes")
(eps, hpt) <- getEpsAndHpt
......
......@@ -54,11 +54,12 @@ module DynFlags (
dynFlagDependencies,
tablesNextToCode, mkTablesNextToCode,
makeDynFlagsConsistent,
thisUnitIdComponentId,
Way(..), mkBuildTag, wayRTSOnly, addWay', updateWays,
wayGeneralFlags, wayUnsetGeneralFlags,
thisPackage, thisComponentId, thisUnitIdInsts,
-- ** Safe Haskell
SafeHaskellMode(..),
safeHaskellOn, safeImportsOn, safeLanguageOn, safeInferOn,
......@@ -688,9 +689,9 @@ data DynFlags = DynFlags {
solverIterations :: IntWithInf, -- ^ Number of iterations in the constraints solver
-- Typically only 1 is needed
thisPackage :: UnitId, -- ^ unit id of package currently being compiled.
-- Not properly initialized until initPackages
thisUnitIdInsts :: [(ModuleName, Module)],
thisInstalledUnitId :: InstalledUnitId,
thisComponentId_ :: Maybe ComponentId,
thisUnitIdInsts_ :: Maybe [(ModuleName, Module)],
-- ways
ways :: [Way], -- ^ Way flags from the command line
......@@ -1487,8 +1488,9 @@ defaultDynFlags mySettings =
reductionDepth = treatZeroAsInf mAX_REDUCTION_DEPTH,
solverIterations = treatZeroAsInf mAX_SOLVER_ITERATIONS,
thisPackage = mainUnitId,
thisUnitIdInsts = [],
thisInstalledUnitId = toInstalledUnitId mainUnitId,
thisUnitIdInsts_ = Nothing,
thisComponentId_ = Nothing,
objectDir = Nothing,
dylibInstallName = Nothing,
......@@ -2003,6 +2005,34 @@ setOutputFile f d = d { outputFile = f}
setDynOutputFile f d = d { dynOutputFile = f}
setOutputHi f d = d { outputHi = f}
thisComponentId :: DynFlags -> ComponentId
thisComponentId dflags =
case thisComponentId_ dflags of
Just cid -> cid
Nothing ->
case thisUnitIdInsts_ dflags of
Just _ ->
throwGhcException $ CmdLineError ("Use of -instantiated-with requires -this-component-id")
Nothing -> ComponentId (unitIdFS (thisPackage dflags))
thisUnitIdInsts :: DynFlags -> [(ModuleName, Module)]
thisUnitIdInsts dflags =
case thisUnitIdInsts_ dflags of
Just insts -> insts
Nothing -> []
thisPackage :: DynFlags -> UnitId
thisPackage dflags =
case thisUnitIdInsts_ dflags of
Nothing -> default_uid
Just insts
| all (\(x,y) -> mkHoleModule x == y) insts
-> newUnitId (thisComponentId dflags) insts
| otherwise
-> default_uid
where
default_uid = DefiniteUnitId (DefUnitId (thisInstalledUnitId dflags))
parseUnitIdInsts :: String -> [(ModuleName, Module)]
parseUnitIdInsts str = case filter ((=="").snd) (readP_to_S parse str) of
[(r, "")] -> r
......@@ -2015,17 +2045,12 @@ parseUnitIdInsts str = case filter ((=="").snd) (readP_to_S parse str) of
return (n, m)
setUnitIdInsts :: String -> DynFlags -> DynFlags
setUnitIdInsts s d = updateWithInsts (parseUnitIdInsts s) d
updateWithInsts :: [(ModuleName, Module)] -> DynFlags -> DynFlags
updateWithInsts insts d =
-- Overwrite the instances, the instances are "indefinite"
d { thisPackage =
if not (null insts) && all (\(x,y) -> mkHoleModule x == y) insts
then newUnitId (unitIdComponentId (thisPackage d)) insts
else thisPackage d
, thisUnitIdInsts = insts
}
setUnitIdInsts s d =
d { thisUnitIdInsts_ = Just (parseUnitIdInsts s) }
setComponentId :: String -> DynFlags -> DynFlags
setComponentId s d =
d { thisComponentId_ = Just (ComponentId (fsLit s)) }
addPluginModuleName :: String -> DynFlags -> DynFlags
addPluginModuleName name d = d { pluginModNames = (mkModuleName name) : (pluginModNames d) }
......@@ -2368,6 +2393,7 @@ dynamic_flags_deps = [
-- 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)
-- RTS options -------------------------------------------------------------
, make_ord_flag defFlag "H" (HasArg (\s -> upd (\d ->
......@@ -4357,18 +4383,8 @@ parseUnitIdArg :: ReadP PackageArg
parseUnitIdArg =
fmap UnitIdArg parseUnitId
thisUnitIdComponentId :: DynFlags -> ComponentId
thisUnitIdComponentId = unitIdComponentId . thisPackage
setUnitId :: String -> DynFlags -> DynFlags
setUnitId p d =
updateWithInsts (thisUnitIdInsts d) $ d{ thisPackage = uid }
where
uid =
case filter ((=="").snd) (readP_to_S parseUnitId p) of
[(r, "")] -> r
_ -> throwGhcException $ CmdLineError ("Can't parse component id: " ++ p)
setUnitId p d = d { thisInstalledUnitId = stringToInstalledUnitId p }
-- | Given a 'ModuleName' of a signature in the home library, find
-- out how it is instantiated. E.g., the canonical form of
......
......@@ -335,7 +335,7 @@ findPackageModule hsc_env mod = do
-- for the appropriate config.
findPackageModule_ :: HscEnv -> InstalledModule -> PackageConfig -> IO InstalledFindResult
findPackageModule_ hsc_env mod pkg_conf =
ASSERT( installedModuleUnitId mod == installedPackageConfigId pkg_conf )
ASSERT2( installedModuleUnitId mod == installedPackageConfigId pkg_conf, ppr (installedModuleUnitId mod) <+> ppr (installedPackageConfigId pkg_conf) )
modLocationCache hsc_env mod $
-- special case for GHC.Prim; we won't find it in the filesystem.
......
......@@ -1264,7 +1264,9 @@ unitIdsToCheck dflags =
where
goUnitId uid =
case splitUnitIdInsts uid of
(_, Just insts) -> uid : concatMap (goUnitId . moduleUnitId . snd) insts
(_, Just indef) ->
let insts = indefUnitIdInsts indef
in uid : concatMap (goUnitId . moduleUnitId . snd) insts
_ -> []
maybeGetIfaceDate :: DynFlags -> ModLocation -> IO (Maybe UTCTime)
......
......@@ -959,10 +959,10 @@ mi_semantic_module iface = case mi_sig_of iface of
mi_free_holes :: ModIface -> UniqDSet ModuleName
mi_free_holes iface =