Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Avoid expensive version calculations during build plan construction #2062

Merged
merged 1 commit into from
Apr 27, 2016
Merged

Avoid expensive version calculations during build plan construction #2062

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
19 changes: 8 additions & 11 deletions src/Stack/Build/ConstructPlan.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -11,7 +11,7 @@ module Stack.Build.ConstructPlan
( constructPlan
) where

import Control.Arrow ((&&&), second)
import Control.Arrow ((&&&))
import Control.Exception.Lifted
import Control.Monad
import Control.Monad.Catch (MonadCatch)
Expand Down Expand Up @@ -43,7 +43,7 @@ import Stack.Build.Source
import Stack.BuildPlan
import Stack.Package
import Stack.PackageDump
import Stack.PackageIndex (getPackageCaches)
import Stack.PackageIndex
import Stack.Types

data PackageInfo
Expand Down Expand Up @@ -105,7 +105,7 @@ data Ctx = Ctx
, ctxEnvConfig :: !EnvConfig
, callStack :: ![PackageName]
, extraToBuild :: !(Set PackageName)
, ctxVersions :: !(Map PackageName (Set Version))
, getVersions :: !(PackageName -> Set Version)
, wanted :: !(Set PackageName)
, localNames :: !(Set PackageName)
}
Expand Down Expand Up @@ -133,18 +133,15 @@ constructPlan :: forall env m.
constructPlan mbp0 baseConfigOpts0 locals extraToBuild0 localDumpPkgs loadPackage0 sourceMap installedMap = do
let locallyRegistered = Map.fromList $ map (dpGhcPkgId &&& dpPackageIdent) localDumpPkgs
caches <- getPackageCaches
let versions =
Map.fromListWith Set.union $
map (second Set.singleton . toTuple) $
Map.keys caches
let getVersions0 name = lookupPackageVersions name caches

econfig <- asks getEnvConfig
let onWanted = void . addDep False . packageName . lpPackage
let inner = do
mapM_ onWanted $ filter lpWanted locals
mapM_ (addDep False) $ Set.toList extraToBuild0
((), m, W efinals installExes dirtyReason deps warnings) <-
liftIO $ runRWST inner (ctx econfig versions) M.empty
liftIO $ runRWST inner (ctx econfig getVersions0) M.empty
mapM_ $logWarn (warnings [])
let toEither (_, Left e) = Left e
toEither (k, Right v) = Right (k, v)
Expand Down Expand Up @@ -172,7 +169,7 @@ constructPlan mbp0 baseConfigOpts0 locals extraToBuild0 localDumpPkgs loadPackag
}
else throwM $ ConstructPlanExceptions errs (bcStackYaml $ getBuildConfig econfig)
where
ctx econfig versions = Ctx
ctx econfig getVersions0 = Ctx
{ mbp = mbp0
, baseConfigOpts = baseConfigOpts0
, loadPackage = loadPackage0
Expand All @@ -183,7 +180,7 @@ constructPlan mbp0 baseConfigOpts0 locals extraToBuild0 localDumpPkgs loadPackag
, ctxEnvConfig = econfig
, callStack = []
, extraToBuild = extraToBuild0
, ctxVersions = versions
, getVersions = getVersions0
, wanted = wantedLocalPackages locals
, localNames = Set.fromList $ map (packageName . lpPackage) locals
}
Expand Down Expand Up @@ -431,7 +428,7 @@ addPackageDeps treatAsDep package = do
deps <- forM (Map.toList deps') $ \(depname, range) -> do
eres <- addDep treatAsDep depname
let mlatestApplicable =
(latestApplicableVersion range <=< Map.lookup depname) (ctxVersions ctx)
latestApplicableVersion range (getVersions ctx depname)
case eres of
Left e ->
let bd =
Expand Down
10 changes: 7 additions & 3 deletions src/Stack/PackageIndex.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -20,6 +20,7 @@ module Stack.PackageIndex
( updateAllIndices
, getPackageCaches
, getPackageVersions
, lookupPackageVersions
) where

import qualified Codec.Archive.Tar as Tar
Expand Down Expand Up @@ -357,9 +358,12 @@ getPackageVersions
:: (MonadIO m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m, MonadCatch m)
=> PackageName
-> m (Set Version)
getPackageVersions pkgName = do
caches <- getPackageCaches
return (Set.fromList [v | PackageIdentifier n v <- Map.keys caches, n == pkgName])
getPackageVersions pkgName =
fmap (lookupPackageVersions pkgName) getPackageCaches

lookupPackageVersions :: PackageName -> Map PackageIdentifier a -> Set Version
lookupPackageVersions pkgName pkgCaches =
Set.fromList [v | PackageIdentifier n v <- Map.keys pkgCaches, n == pkgName]

-- | Load the package caches, or create the caches if necessary.
--
Expand Down