Skip to content

Commit

Permalink
Fix #6835
Browse files Browse the repository at this point in the history 
Fixes the bug by accurately tracking when instantiations refer to
inplace packages, and adjusting previously non-inplace packages to be
inplace when this occurs.  See comment in ProjectPlanning.hs for more
details.

Signed-off-by: Edward Z. Yang <[email protected]>
(cherry picked from commit 823e894)
  • Loading branch information
@ezyang @fgaz
ezyang authored and fgaz committed Jun 6, 2021
1 parent fb835a6 commit 35aa1fa
Show file tree
Hide file tree
Showing 2 changed files with 110 additions and 23 deletions.
123 changes: 100 additions & 23 deletions cabal-install/src/Distribution/Client/ProjectPlanning.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -157,6 +157,7 @@ import Distribution.Version
import qualified Distribution.Compat.Graph as Graph
import Distribution.Compat.Graph(IsNode(..))

import Data.Foldable (fold)
import Text.PrettyPrint (text, hang, quotes, colon, vcat, ($$), fsep, punctuate, comma)
import qualified Text.PrettyPrint as Disp
import qualified Data.Map as Map
Expand Down Expand Up @@ -663,7 +664,9 @@ rebuildInstallPlan verbosity
defaultInstallDirs
elaboratedShared
elaboratedPlan
liftIO $ debugNoWrap verbosity (InstallPlan.showInstallPlan instantiatedPlan)
liftIO $ notice verbosity "--- Instantiated plan:"
liftIO $ noticeNoWrap verbosity (InstallPlan.showInstallPlan instantiatedPlan)
liftIO $ notice verbosity "---"
return (instantiatedPlan, elaboratedShared)
where
withRepoCtx = projectConfigWithSolverRepoContext verbosity
Expand Down Expand Up @@ -1797,6 +1800,10 @@ elaborateInstallPlan verbosity platform compiler compilerprogdb pkgConfigDB
elabSetupScriptStyle elabPkgDescription libDepGraph deps0
elabSetupPackageDBStack = buildAndRegisterDbs

elabInplaceBuildPackageDBStack = inplacePackageDbs
elabInplaceRegisterPackageDBStack = inplacePackageDbs
elabInplaceSetupPackageDBStack = inplacePackageDbs

buildAndRegisterDbs
| shouldBuildInplaceOnly pkg = inplacePackageDbs
| otherwise = storePackageDbs
Expand Down Expand Up @@ -2138,6 +2145,55 @@ getComponentId (InstallPlan.PreExisting dipkg) = IPI.installedComponentId dipkg
getComponentId (InstallPlan.Configured elab) = elabComponentId elab
getComponentId (InstallPlan.Installed elab) = elabComponentId elab

extractElabBuildStyle :: InstallPlan.GenericPlanPackage ipkg ElaboratedConfiguredPackage
-> BuildStyle
extractElabBuildStyle (InstallPlan.Configured elab) = elabBuildStyle elab
extractElabBuildStyle _ = BuildAndInstall

-- instantiateInstallPlan is responsible for filling out an InstallPlan
-- with all of the extra Configured packages that would be generated by
-- recursively instantiating the dependencies of packages.
--
-- Suppose we are compiling the following packages:
--
-- unit f where
-- signature H
--
-- unit g where
-- dependency f[H=containers:Data.Map]
--
-- At entry, we have an InstallPlan with a single plan package per
-- actual source package, e.g., only (indefinite!) f and g. The job of
-- instantiation is to turn this into three plan packages: each of the
-- packages as before, but also a new, definite package f[H=containers:Data.Map]
--
-- How do we do this? The general strategy is to iterate over every
-- package in the existing plan and recursively create new entries for
-- each of its dependencies which is an instantiated package (e.g.,
-- f[H=p:G]). This process must be recursive, as f itself may depend on
-- OTHER packages which it instantiated using its hole H.
--
-- Some subtleties:
--
-- * We have to keep track of whether or not we are instantiating with
-- inplace packages, because instantiating a non-inplace package with
-- an inplace packages makes it inplace (since it depends on
-- something in the inplace store)! The rule is that if any of the
-- modules in an instantiation are inplace, then the instantiated
-- unit itself must be inplace. There is then a bunch of faffing
-- about to keep track of BuildStyle.
--
-- * ElaboratedConfiguredPackage was never really designed for post
-- facto instantiation, so some of the steps for generating new
-- instantiations are a little fraught. For example, the act of
-- flipping a package to be inplace involves faffing about with four
-- fields, because these fields are precomputed. A good refactor
-- would be to reduce the amount of precomputation to simplify the
-- algorithm here.
--
-- * We use the state monad to cache already instantiated modules, so
-- we don't instantiate the same thing multiple times.
--
instantiateInstallPlan :: StoreDirLayout -> InstallDirs.InstallDirTemplates -> ElaboratedSharedConfig -> ElaboratedInstallPlan -> ElaboratedInstallPlan
instantiateInstallPlan storeDirLayout defaultInstallDirs elaboratedShared plan =
InstallPlan.new (IndependentGoals False)
Expand All @@ -2147,41 +2203,46 @@ instantiateInstallPlan storeDirLayout defaultInstallDirs elaboratedShared plan =

cmap = Map.fromList [ (getComponentId pkg, pkg) | pkg <- pkgs ]

instantiateUnitId :: ComponentId -> Map ModuleName Module
-> InstM DefUnitId
instantiateUnitId :: ComponentId -> Map ModuleName (Module, BuildStyle)
-> InstM (DefUnitId, BuildStyle)
instantiateUnitId cid insts = state $ \s ->
case Map.lookup uid s of
Nothing ->
-- Knot tied
-- TODO: I don't think the knot tying actually does
-- anything useful
let (r, s') = runState (instantiateComponent uid cid insts)
(Map.insert uid r s)
in (def_uid, Map.insert uid r s')
Just _ -> (def_uid, s)
in ((def_uid, extractElabBuildStyle r), Map.insert uid r s')
Just r -> ((def_uid, extractElabBuildStyle r), s)
where
def_uid = mkDefUnitId cid insts
def_uid = mkDefUnitId cid (fmap fst insts)
uid = unDefUnitId def_uid

-- No need to InplaceT; the inplace-ness is properly computed for
-- the ElaboratedPlanPackage, so that will implicitly pass it on
instantiateComponent
:: UnitId -> ComponentId -> Map ModuleName Module
:: UnitId -> ComponentId -> Map ModuleName (Module, BuildStyle)
-> InstM ElaboratedPlanPackage
instantiateComponent uid cid insts
| Just planpkg <- Map.lookup cid cmap
= case planpkg of
InstallPlan.Configured (elab0@ElaboratedConfiguredPackage
{ elabPkgOrComp = ElabComponent comp }) -> do
deps <- traverse (substUnitId insts)
(compLinkedLibDependencies comp)
deps <-
traverse (fmap fst . substUnitId insts) (compLinkedLibDependencies comp)
let build_style = fold (fmap snd insts)
let getDep (Module dep_uid _) = [dep_uid]
elab1 = elab0 {
elab1 = fixupBuildStyle build_style $ elab0 {
elabUnitId = uid,
elabComponentId = cid,
elabInstantiatedWith = insts,
elabIsCanonical = Map.null insts,
elabInstantiatedWith = fmap fst insts,
elabIsCanonical = Map.null (fmap fst insts),
elabPkgOrComp = ElabComponent comp {
compOrderLibDependencies =
(if Map.null insts then [] else [newSimpleUnitId cid]) ++
ordNub (map unDefUnitId
(deps ++ concatMap getDep (Map.elems insts)))
(deps ++ concatMap (getDep . fst) (Map.elems insts)))
}
}
elab = elab1 {
Expand All @@ -2194,26 +2255,29 @@ instantiateInstallPlan storeDirLayout defaultInstallDirs elaboratedShared plan =
_ -> return planpkg
| otherwise = error ("instantiateComponent: " ++ prettyShow cid)

substUnitId :: Map ModuleName Module -> OpenUnitId -> InstM DefUnitId
substUnitId :: Map ModuleName (Module, BuildStyle) -> OpenUnitId -> InstM (DefUnitId, BuildStyle)
substUnitId _ (DefiniteUnitId uid) =
return uid
-- This COULD actually, secretly, be an inplace package, but in
-- that case it doesn't matter as it's already been recorded
-- in the package that depends on this
return (uid, BuildAndInstall)
substUnitId subst (IndefFullUnitId cid insts) = do
insts' <- substSubst subst insts
instantiateUnitId cid insts'

-- NB: NOT composition
substSubst :: Map ModuleName Module
substSubst :: Map ModuleName (Module, BuildStyle)
-> Map ModuleName OpenModule
-> InstM (Map ModuleName Module)
-> InstM (Map ModuleName (Module, BuildStyle))
substSubst subst insts = traverse (substModule subst) insts

substModule :: Map ModuleName Module -> OpenModule -> InstM Module
substModule :: Map ModuleName (Module, BuildStyle) -> OpenModule -> InstM (Module, BuildStyle)
substModule subst (OpenModuleVar mod_name)
| Just m <- Map.lookup mod_name subst = return m
| otherwise = error "substModule: non-closing substitution"
substModule subst (OpenModule uid mod_name) = do
uid' <- substUnitId subst uid
return (Module uid' mod_name)
(uid', build_style) <- substUnitId subst uid
return (Module uid' mod_name, build_style)

indefiniteUnitId :: ComponentId -> InstM UnitId
indefiniteUnitId cid = do
Expand All @@ -2240,13 +2304,17 @@ instantiateInstallPlan storeDirLayout defaultInstallDirs elaboratedShared plan =
-- is no IndefFullUnitId in compLinkedLibDependencies that actually
-- has no holes. We couldn't specify this invariant when
-- we initially created the ElaboratedPlanPackage because
-- we have no way of actually refiying the UnitId into a
-- we have no way of actually reifying the UnitId into a
-- DefiniteUnitId (that's what substUnitId does!)
new_deps <- for (compLinkedLibDependencies elab_comp) $ \uid ->
if Set.null (openUnitIdFreeHoles uid)
then fmap DefiniteUnitId (substUnitId Map.empty uid)
then fmap (DefiniteUnitId . fst) (substUnitId Map.empty uid)
else return uid
return $ InstallPlan.Configured epkg {
-- NB: no fixupBuildStyle needed here, as if the indefinite
-- component depends on any inplace packages, it itself must
-- be indefinite! There is no substitution here, we can't
-- post facto add inplace deps
return . InstallPlan.Configured $ epkg {
elabPkgOrComp = ElabComponent elab_comp {
compLinkedLibDependencies = new_deps,
-- I think this is right: any new definite unit ids we
Expand All @@ -2262,6 +2330,15 @@ instantiateInstallPlan storeDirLayout defaultInstallDirs elaboratedShared plan =
= return planpkg
| otherwise = error ("indefiniteComponent: " ++ prettyShow cid)

fixupBuildStyle BuildAndInstall elab = elab
fixupBuildStyle _ (elab@ElaboratedConfiguredPackage { elabBuildStyle = BuildInplaceOnly }) = elab
fixupBuildStyle BuildInplaceOnly elab = elab {
elabBuildStyle = BuildInplaceOnly,
elabBuildPackageDBStack = elabInplaceBuildPackageDBStack elab,
elabRegisterPackageDBStack = elabInplaceRegisterPackageDBStack elab,
elabSetupPackageDBStack = elabInplaceSetupPackageDBStack elab
}

ready_map = execState work Map.empty

work = for_ pkgs $ \pkg ->
Expand Down
10 changes: 10 additions & 0 deletions cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -237,6 +237,10 @@ data ElaboratedConfiguredPackage
elabBuildPackageDBStack :: PackageDBStack,
elabRegisterPackageDBStack :: PackageDBStack,

elabInplaceSetupPackageDBStack :: PackageDBStack,
elabInplaceBuildPackageDBStack :: PackageDBStack,
elabInplaceRegisterPackageDBStack :: PackageDBStack,

elabPkgDescriptionOverride :: Maybe CabalFileText,

-- TODO: make per-component variants of these flags
Expand Down Expand Up @@ -744,6 +748,12 @@ data BuildStyle =

instance Binary BuildStyle
instance Structured BuildStyle
instance Semigroup BuildStyle where
BuildInplaceOnly <> _ = BuildInplaceOnly
_ <> BuildInplaceOnly = BuildInplaceOnly
_ <> _ = BuildAndInstall
instance Monoid BuildStyle where
mempty = BuildAndInstall

type CabalFileText = LBS.ByteString

Expand Down

0 comments on commit 35aa1fa

Please sign in to comment.