Commit bd3040bd authored by Edward Z. Yang's avatar Edward Z. Yang
Browse files

Add a new 'DefUnitId' type with invariant.



The DefUnitId invariant says that the UnitId in a DefUnitId
must in fact be a definite package (either with no holes, or
fully instantiated.)  This is in constrast to a UnitId,
which can also identify an indefinite unit identifier.

Signed-off-by: default avatarEdward Z. Yang <ezyang@cs.stanford.edu>
parent 2e42ca27
......@@ -3,6 +3,7 @@
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-- | This module defines the core data types for Backpack. For more
-- details, see:
......@@ -14,6 +15,12 @@ module Distribution.Backpack (
OpenUnitId(..),
openUnitIdComponentId,
openUnitIdFreeHoles,
mkOpenUnitId,
-- * DefUnitId
DefUnitId,
unDefUnitId,
mkDefUnitId,
-- * OpenModule
OpenModule(..),
......@@ -85,7 +92,7 @@ data OpenUnitId
-- been compiled and abbreviated as a hash. The embedded 'UnitId'
-- MUST NOT be for an indefinite component; an 'OpenUnitId'
-- is guaranteed not to have any holes.
| DefiniteUnitId UnitId
| DefiniteUnitId DefUnitId
deriving (Generic, Read, Show, Eq, Ord, Typeable, Data)
-- TODO: cache holes?
......@@ -113,13 +120,29 @@ instance Text OpenUnitId where
-- | Get the 'ComponentId' of an 'OpenUnitId'.
openUnitIdComponentId :: OpenUnitId -> ComponentId
openUnitIdComponentId (IndefFullUnitId cid _) = cid
openUnitIdComponentId (DefiniteUnitId uid) = unitIdComponentId uid
openUnitIdComponentId (DefiniteUnitId (DefUnitId uid)) = unitIdComponentId uid
-- | Get the set of holes ('ModuleVar') embedded in a 'UnitId'.
openUnitIdFreeHoles :: OpenUnitId -> Set ModuleName
openUnitIdFreeHoles (IndefFullUnitId _ insts) = openModuleSubstFreeHoles insts
openUnitIdFreeHoles _ = Set.empty
-- | Safe constructor from a UnitId. The only way to do this safely
-- is if the instantiation is provided.
mkOpenUnitId :: UnitId -> OpenModuleSubst -> OpenUnitId
mkOpenUnitId uid insts =
if Set.null (openModuleSubstFreeHoles insts)
then DefiniteUnitId (DefUnitId uid) -- invariant holds!
else IndefFullUnitId (unitIdComponentId uid) insts
-----------------------------------------------------------------------
-- DefUnitId
-- | Create a 'DefUnitId' from a 'ComponentId' and an instantiation
-- with no holes.
mkDefUnitId :: ComponentId -> Map ModuleName Module -> DefUnitId
mkDefUnitId cid insts = DefUnitId (UnitId cid (hashModuleSubst insts)) -- impose invariant!
-----------------------------------------------------------------------
-- OpenModule
......@@ -208,7 +231,7 @@ openModuleSubstFreeHoles insts = Set.unions (map openModuleFreeHoles (Map.elems
-- 'IndefFullUnitId' be compiled; instead, we just depend on the
-- installed indefinite unit installed at the 'ComponentId'.
abstractUnitId :: OpenUnitId -> UnitId
abstractUnitId (DefiniteUnitId uid) = uid
abstractUnitId (DefiniteUnitId (DefUnitId uid)) = uid
abstractUnitId (IndefFullUnitId cid _) = newSimpleUnitId cid
-- | Take a module substitution and hash it into a string suitable for
......
......@@ -93,11 +93,12 @@ configureComponentLocalBuildInfos
let shape_pkg_map = Map.fromList
[ (pc_cid pkg, (pc_open_uid pkg, pc_shape pkg))
| pkg <- prePkgDeps]
uid_lookup uid
uid_lookup def_uid
| Just pkg <- PackageIndex.lookupUnitId installedPackageSet uid
= FullUnitId (Installed.installedComponentId pkg)
(Map.fromList (Installed.instantiatedWith pkg))
| otherwise = error ("uid_lookup: " ++ display uid)
where uid = unDefUnitId def_uid
graph2 <- toLinkedComponents verbosity uid_lookup
(package pkg_descr) shape_pkg_map graph1
......@@ -111,7 +112,7 @@ configureComponentLocalBuildInfos
[ (Installed.installedComponentId pkg, Installed.sourcePackageId pkg)
| (_, Module uid _) <- instantiate_with
, Just pkg <- [PackageIndex.lookupUnitId
installedPackageSet uid] ] ++
installedPackageSet (unDefUnitId uid)] ] ++
[ (lc_cid lc, lc_pkgid lc)
| lc <- graph2 ]
subst = Map.fromList instantiate_with
......@@ -243,7 +244,7 @@ mkLinkedComponentsLocalBuildInfo comp rcs = map go rcs
case rc_component rc of
CLib _ ->
let convModuleExport (modname', (Module uid modname))
| this_uid == uid
| this_uid == unDefUnitId uid
, modname' == modname
= Installed.ExposedModule modname' Nothing
| otherwise
......@@ -279,7 +280,7 @@ mkLinkedComponentsLocalBuildInfo comp rcs = map go rcs
componentIsIndefinite_ = is_indefinite,
componentLocalName = cname,
componentInternalDeps = internal_deps,
componentExeDeps = rc_internal_build_tools rc,
componentExeDeps = map unDefUnitId (rc_internal_build_tools rc),
componentIncludes = includes,
componentExposedModules = exports,
componentIsPublic = rc_public rc,
......@@ -291,7 +292,7 @@ mkLinkedComponentsLocalBuildInfo comp rcs = map go rcs
componentUnitId = this_uid,
componentLocalName = cname,
componentPackageDeps = cpds,
componentExeDeps = rc_internal_build_tools rc,
componentExeDeps = map unDefUnitId $ rc_internal_build_tools rc,
componentInternalDeps = internal_deps,
componentIncludes = includes
}
......@@ -300,7 +301,7 @@ mkLinkedComponentsLocalBuildInfo comp rcs = map go rcs
componentUnitId = this_uid,
componentLocalName = cname,
componentPackageDeps = cpds,
componentExeDeps = rc_internal_build_tools rc,
componentExeDeps = map unDefUnitId $ rc_internal_build_tools rc,
componentInternalDeps = internal_deps,
componentIncludes = includes
}
......@@ -309,7 +310,7 @@ mkLinkedComponentsLocalBuildInfo comp rcs = map go rcs
componentUnitId = this_uid,
componentLocalName = cname,
componentPackageDeps = cpds,
componentExeDeps = rc_internal_build_tools rc,
componentExeDeps = map unDefUnitId $ rc_internal_build_tools rc,
componentInternalDeps = internal_deps,
componentIncludes = includes
}
......@@ -330,6 +331,6 @@ mkLinkedComponentsLocalBuildInfo comp rcs = map go rcs
map (\(x,y) -> (DefiniteUnitId x,y)) (instc_includes instc)
internal_deps =
filter isInternal (nodeNeighbors rc)
++ rc_internal_build_tools rc
++ map unDefUnitId (rc_internal_build_tools rc)
......@@ -14,7 +14,7 @@ import Distribution.Compat.Prelude
data FullUnitId = FullUnitId ComponentId OpenModuleSubst
deriving (Show, Generic)
type FullDb = UnitId -> FullUnitId
type FullDb = DefUnitId -> FullUnitId
expandOpenUnitId :: FullDb -> OpenUnitId -> FullUnitId
expandOpenUnitId _db (IndefFullUnitId cid subst)
......@@ -22,5 +22,5 @@ expandOpenUnitId _db (IndefFullUnitId cid subst)
expandOpenUnitId db (DefiniteUnitId uid)
= expandUnitId db uid
expandUnitId :: FullDb -> UnitId -> FullUnitId
expandUnitId :: FullDb -> DefUnitId -> FullUnitId
expandUnitId db uid = db uid
......@@ -6,6 +6,7 @@ module Distribution.Backpack.MixLink (
import Prelude ()
import Distribution.Compat.Prelude hiding (mod)
import Distribution.Backpack
import Distribution.Backpack.UnifyM
import Distribution.Backpack.FullUnitId
......@@ -95,7 +96,7 @@ unifyUnitId uid1_u uid2_u
unifyThunkWith :: ComponentId
-> Map ModuleName (ModuleU s)
-> UnitIdU s
-> UnitId
-> DefUnitId
-> UnitIdU s
-> UnifyM s ()
unifyThunkWith cid1 insts1 uid1_u uid2 uid2_u = do
......
......@@ -49,7 +49,7 @@ data InstantiatedComponent
= InstantiatedComponent {
instc_insts :: [(ModuleName, Module)],
instc_provides :: Map ModuleName Module,
instc_includes :: [(UnitId, ModuleRenaming)]
instc_includes :: [(DefUnitId, ModuleRenaming)]
}
data IndefiniteComponent
......@@ -66,7 +66,7 @@ data ReadyComponent
rc_component :: Component,
-- build-tools don't participate in mix-in linking.
-- (but what if they cold?)
rc_internal_build_tools :: [UnitId],
rc_internal_build_tools :: [DefUnitId],
rc_public :: Bool,
-- PackageId here is a bit dodgy, but its just for
-- BC so it shouldn't matter.
......@@ -168,21 +168,22 @@ toReadyComponents pid_map subst0 comps
cmap = Map.fromList [ (lc_cid lc, lc) | lc <- comps ]
instantiateUnitId :: ComponentId -> Map ModuleName Module
-> InstM UnitId
-> InstM DefUnitId
instantiateUnitId cid insts = InstM $ \s ->
case Map.lookup uid s of
Nothing ->
-- Knot tied
let (r, s') = runInstM (instantiateComponent uid cid insts)
(Map.insert uid r s)
in (uid, Map.insert uid r s')
Just _ -> (uid, s)
in (def_uid, Map.insert uid r s')
Just _ -> (def_uid, s)
where
-- The hashModuleSubst here indicates that we assume
-- The mkDefUnitId here indicates that we assume
-- that Cabal handles unit id hash allocation.
-- Good thing about hashing here: map is only on string.
-- Bad thing: have to repeatedly hash.
uid = UnitId cid (hashModuleSubst insts)
def_uid = mkDefUnitId cid insts
uid = unDefUnitId def_uid
instantiateComponent
:: UnitId -> ComponentId -> Map ModuleName Module
......@@ -197,8 +198,10 @@ toReadyComponents pid_map subst0 comps
x' <- substUnitId insts x
return (x', y)
build_tools <- mapM (substUnitId insts) (lc_internal_build_tools lc)
let getDep (Module dep_uid _)
| Just pid <- Map.lookup (unitIdComponentId dep_uid) pid_map
let getDep (Module dep_def_uid _)
| let dep_uid = unDefUnitId dep_def_uid
, Just pid <- Map.lookup (unitIdComponentId dep_uid) pid_map
-- Lose DefUnitId invariant for rc_depends
= [(dep_uid, pid)]
getDep _ = []
instc = InstantiatedComponent {
......@@ -216,12 +219,13 @@ toReadyComponents pid_map subst0 comps
-- NB: don't put the dep on the indef
-- package here, since we DO NOT want
-- to put it in 'depends' in the IPI
deps ++ concatMap getDep (Map.elems insts),
map (\(x,y) -> (unDefUnitId x, y)) deps ++
concatMap getDep (Map.elems insts),
rc_i = Right instc
}
| otherwise = return Nothing
substUnitId :: Map ModuleName Module -> OpenUnitId -> InstM UnitId
substUnitId :: Map ModuleName Module -> OpenUnitId -> InstM DefUnitId
substUnitId _ (DefiniteUnitId uid) =
return uid
substUnitId subst (IndefFullUnitId cid insts) = do
......@@ -279,5 +283,5 @@ toReadyComponents pid_map subst0 comps
| otherwise
= forM_ (Map.elems cmap) $ \lc ->
if null (lc_insts lc)
then instantiateUnitId (lc_cid lc) Map.empty
else indefiniteUnitId (lc_cid lc)
then instantiateUnitId (lc_cid lc) Map.empty >> return ()
else indefiniteUnitId (lc_cid lc) >> return ()
......@@ -181,7 +181,7 @@ data ModuleU' s
-- | Contents of a mutable 'UnitIdU' reference.
data UnitIdU' s
= UnitIdU UnitIdUnique ComponentId (Map ModuleName (ModuleU s))
| UnitIdThunkU UnitId
| UnitIdThunkU DefUnitId
-- | A mutable version of 'Module' which can be imperatively unified.
type ModuleU s = UnionFind.Point s (ModuleU' s)
......
......@@ -132,11 +132,8 @@ indefinite ipi =
-- For indefinite libraries, however, you will correctly get
-- an @OpenUnitId@ with the appropriate 'OpenModuleSubst'.
installedOpenUnitId :: InstalledPackageInfo -> OpenUnitId
installedOpenUnitId ipi =
if indefinite ipi
then IndefFullUnitId (installedComponentId ipi)
(Map.fromList (instantiatedWith ipi))
else DefiniteUnitId (installedUnitId ipi)
installedOpenUnitId ipi
= mkOpenUnitId (installedUnitId ipi) (Map.fromList (instantiatedWith ipi))
-- | Returns the set of module names which need to be filled for
-- an indefinite package, or the empty set if the package is definite.
......
......@@ -25,6 +25,7 @@ module Distribution.Package (
-- * Package keys/installed package IDs (used for linker symbols)
ComponentId, unComponentId, mkComponentId,
UnitId(..),
DefUnitId(..),
mkUnitId,
newSimpleUnitId,
mkLegacyUnitId,
......@@ -145,7 +146,7 @@ instance NFData PackageIdentifier where
-- module identities, e.g., when writing out reexported modules in
-- the 'InstalledPackageInfo'.
data Module =
Module UnitId ModuleName
Module DefUnitId ModuleName
deriving (Generic, Read, Show, Eq, Ord, Typeable, Data)
instance Binary Module
......@@ -268,6 +269,12 @@ instance Text UnitId where
return (UnitId cid (Just hash))
parseSimpleUnitId = fmap newSimpleUnitId parse
-- | A 'UnitId' for a definite package. The 'DefUnitId' invariant says
-- that a 'UnitId' identified this way is definite; i.e., it has no
-- unfilled holes.
newtype DefUnitId = DefUnitId { unDefUnitId :: UnitId }
deriving (Generic, Read, Show, Eq, Ord, Typeable, Data, Binary, NFData, Text)
-- | Create a unit identity with no associated hash directly
-- from a 'ComponentId'.
newSimpleUnitId :: ComponentId -> UnitId
......
......@@ -474,7 +474,11 @@ testSuiteLibV09AsLibAndExe pkg_descr
componentExeDeps = [],
componentLocalName = CExeName (stubName test),
componentPackageDeps = deps,
componentIncludes = zip (map (DefiniteUnitId . fst) deps) (repeat defaultRenaming)
-- Assert DefUnitId invariant!
-- Executable can't be indefinite, so dependencies must
-- be definite packages.
componentIncludes = zip (map (DefiniteUnitId . DefUnitId . fst) deps)
(repeat defaultRenaming)
}
testSuiteLibV09AsLibAndExe _ TestSuite{} _ _ _ _ = error "testSuiteLibV09AsLibAndExe: wrong kind"
......
......@@ -1131,7 +1131,11 @@ elaborateInstallPlan verbosity platform compiler compilerprogdb pkgConfigDB
ElaboratedConfiguredPackage)
buildComponent (cc_map, lc_map, exe_map) comp = do
infoProgress $ dispConfiguredComponent cc
let lookup_uid (UnitId sub_cid Nothing) = FullUnitId sub_cid Map.empty
let -- Use of invariant: DefUnitId indicates that if
-- there is no hash, it must have an empty
-- instnatiation.
lookup_uid (DefUnitId (UnitId sub_cid Nothing))
= FullUnitId sub_cid Map.empty
-- TODO: This case CAN happen if we have pre-existing
-- instantiated things. Fix eventually.
lookup_uid uid = error ("lookup_uid: " ++ display uid)
......@@ -1692,21 +1696,18 @@ instantiateInstallPlan plan =
cmap = Map.fromList [ (unitIdComponentId (nodeKey pkg), pkg) | pkg <- pkgs ]
instantiateUnitId :: ComponentId -> Map ModuleName Module
-> InstM UnitId
-> InstM DefUnitId
instantiateUnitId cid insts = state $ \s ->
case Map.lookup uid s of
Nothing ->
-- Knot tied
let (r, s') = runState (instantiateComponent uid cid insts)
(Map.insert uid r s)
in (uid, Map.insert uid r s')
Just _ -> (uid, s)
in (def_uid, Map.insert uid r s')
Just _ -> (def_uid, s)
where
-- The hashModuleSubst here indicates that we assume
-- that Cabal handles unit id hash allocation.
-- Good thing about hashing here: map is only on string.
-- Bad thing: have to repeatedly hash.
uid = UnitId cid (hashModuleSubst insts)
def_uid = mkDefUnitId cid insts
uid = unDefUnitId def_uid
instantiateComponent
:: UnitId -> ComponentId -> Map ModuleName Module
......@@ -1725,13 +1726,14 @@ instantiateInstallPlan plan =
elabPkgOrComp = ElabComponent comp {
compNonSetupDependencies =
(if Map.null insts then [] else [newSimpleUnitId cid]) ++
ordNub (deps ++ concatMap getDep (Map.elems insts))
ordNub (map unDefUnitId
(deps ++ concatMap getDep (Map.elems insts)))
}
}
_ -> return planpkg
| otherwise = error ("instantiateComponent: " ++ display cid)
substUnitId :: Map ModuleName Module -> OpenUnitId -> InstM UnitId
substUnitId :: Map ModuleName Module -> OpenUnitId -> InstM DefUnitId
substUnitId _ (DefiniteUnitId uid) =
return uid
substUnitId subst (IndefFullUnitId cid insts) = do
......@@ -1780,7 +1782,9 @@ instantiateInstallPlan plan =
InstallPlan.Configured elab
| not (Map.null (elabLinkedInstantiatedWith elab))
-> indefiniteUnitId (unitIdComponentId (nodeKey elab))
>> return ()
_ -> instantiateUnitId (unitIdComponentId (nodeKey pkg)) Map.empty
>> return ()
---------------------------
-- Build targets
......
......@@ -32,7 +32,7 @@ import Distribution.Version
, withinRange )
import qualified Distribution.Backpack as Backpack
import Distribution.Package
( newSimpleUnitId, ComponentId, PackageId, mkPackageName
( newSimpleUnitId, DefUnitId(..), ComponentId, PackageId, mkPackageName
, PackageIdentifier(..), packageVersion, packageName, Dependency(..) )
import Distribution.PackageDescription
( GenericPackageDescription(packageDescription)
......@@ -819,7 +819,8 @@ getExternalSetupMethod verbosity options pkg bt = do
then []
else cabalDep
addRenaming (ipid, _) =
(Backpack.DefiniteUnitId (newSimpleUnitId ipid), defaultRenaming)
-- Assert 'DefUnitId' invariant
(Backpack.DefiniteUnitId (DefUnitId (newSimpleUnitId ipid)), defaultRenaming)
cppMacrosFile = setupDir </> "setup_macros.h"
ghcOptions = mempty {
-- Respect -v0, but don't crank up verbosity on GHC if
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment