module GHC.ParMake.BuildPlan
(new, ready, building, completed, size
, numCompleted, markCompleted
, markReadyAsBuilding, numBuilding, hasBuilding
, BuildPlan, Target, TargetId
, targetId, allDepends, source, object, objects)
where
import qualified Data.Array as Array
import qualified Data.Graph as Graph
import qualified Data.IntMap as IntMap
import qualified Data.IntSet as IntSet
import Data.Array ((!))
import Data.Graph (Graph)
import Data.Function (on)
import Data.IntMap (IntMap)
import Data.IntSet (IntSet)
import Data.List (find, sortBy)
import Data.Maybe (fromMaybe, mapMaybe)
import Data.Ord (comparing)
import System.FilePath (replaceExtension, takeExtension)
import GHC.ParMake.Types (Dep(..))
type TargetId = FilePath
type ExternalDep = FilePath
data Target = Target
{ targetId :: TargetId
, targetSource :: FilePath
, targetDeps :: [TargetId]
, targetExternalDeps :: [ExternalDep]
}
deriving (Show)
instance Eq Target where
(==) = (==) `on` targetId
depends :: Target -> [TargetId]
depends = targetDeps
externalDepends :: Target -> [TargetId]
externalDepends = targetExternalDeps
allDepends :: Target -> [TargetId]
allDepends t = depends t ++ externalDepends t
source :: Target -> FilePath
source = targetSource
object :: Target -> Maybe FilePath
object (Target tId _ _ _) = case takeExtension tId
of ".o-boot" -> Nothing
_ -> Just tId
objects :: BuildPlan -> [FilePath]
objects = mapMaybe object . completed
sourceExts, interfaceExts, objExts :: [String]
sourceExts = [".hs", ".lhs", ".hs-boot", ".lhs-boot"]
interfaceExts = [".hi", ".hi-boot"]
objExts = [".o", ".o-boot"]
data BuildPlan = BuildPlan {
planGraph :: Graph,
planGraphRev :: Graph,
planVertexOf :: TargetId -> Maybe Graph.Vertex,
planTargetOf :: Graph.Vertex -> Target,
planNumDeps :: IntMap Int,
planReady :: IntSet,
planBuilding :: IntSet
}
instance Show BuildPlan where
show p = "BuildPlan {\n planGraph = "
++ show (planGraph p)
++ ",\n"
++ " planTargetIdOf = " ++ show numberedTargetIds ++ ",\n"
++ " planTargets = " ++ show targets ++ ",\n"
++ " planNumDeps = " ++ show (planNumDeps p) ++ ",\n"
++ " planReady = " ++ show (planReady p) ++ ",\n"
++ " planBuilding = " ++ show (planBuilding p)
++ "\n}"
where
targets = map (planTargetOf p)[0..topBound]
targetIds = map targetId targets
numberedTargetIds = (zip [(0::Int)..] targetIds)
topBound = snd . Array.bounds . planGraph $ p
new :: [Dep] -> BuildPlan
new deps = BuildPlan graph graphRev targetIdToVertex vertexToTargetId
numDepsMap readySet buildingSet
where
targetIdToVertex = binarySearch 0 topBound
vertexToTargetId v = targetTable ! v
graph = Array.listArray bounds
[ [ v | Just v <- map targetIdToVertex
. map interfaceToObj $ depends target]
| target <- targets ]
where
interfaceToObj tId =
case takeExtension tId of
".hi" -> replaceExtension tId ".o"
".hi-boot" -> replaceExtension tId ".o-boot"
_ -> tId
graphRev = Graph.transposeG graph
numDepsMap = IntMap.fromList . map (\(n,t) -> (n, countNumDeps t))
. zip [0..] $ targets
where
countNumDeps t = case length (depends t) of
n | n > 0 -> n 1
_ -> error $ "GHC.ParMake.BuildPlan.countNumDeps: "
++ "BUG: A target should never have 0 dependencies"
readySet = IntSet.fromList . map fst . filter hasSingleSourceDep
. zip [0..] $ targets
where hasSingleSourceDep (_,t) = case depends t of
[] -> error $ "GHC.ParMake.BuildPlan.hasSingleSourceDep: "
++ "BUG: A target should never have 0 dependencies"
[d] -> (takeExtension d) `elem` sourceExts
_ -> False
buildingSet = IntSet.empty
targetTable = Array.listArray bounds targets
targetIdTable = Array.listArray bounds (map targetId targets)
targets = sortBy (comparing targetId) (depsToTargets deps)
topBound = length targets 1
bounds = (0, topBound)
binarySearch a b key
| a > b = Nothing
| otherwise = case compare key (targetIdTable ! mid) of
LT -> binarySearch a (mid1) key
EQ -> Just mid
GT -> binarySearch (mid+1) b key
where mid = (a + b) `div` 2
depsToTargets :: [Dep] -> [Target]
depsToTargets = map mkModuleTarget
where
mkModuleTarget (Dep t intDeps extDeps)
| badExtension = error $ "GHC.ParMake.BuildPlan.depsToTargets: "
++ "target must end with " ++ show objExts
| not depsOK = error $ "GHC.ParMake.BuildPlan.depsToTargets: "
++ "dependencies are invalid: " ++ show intDeps
| otherwise = Target t tSrc intDeps extDeps
where
tSrc = fromMaybe (error "No source file in dependencies!")
$ find ((`elem` sourceExts). takeExtension) intDeps
badExtension = takeExtension t `notElem` objExts
depsOK = length intDeps == 1
|| or [ takeExtension d `elem` interfaceExts | d <- intDeps ]
size :: BuildPlan -> Int
size = (+) 1 . snd . Array.bounds . planGraphRev
verticesToTargets :: BuildPlan -> IntSet -> [Target]
verticesToTargets plan vertices =
map (planTargetOf plan) (IntSet.toList vertices)
ready :: BuildPlan -> [Target]
ready p = verticesToTargets p $ planReady p
building :: BuildPlan -> [Target]
building p = verticesToTargets p $ planBuilding p
completed :: BuildPlan -> [Target]
completed plan = map (planTargetOf plan) keysCompleted
where
keysCompleted = IntMap.foldWithKey f [] (planNumDeps plan)
bldng = planBuilding plan
rdy = planReady plan
f key n ks = if n == 0
&& (not $ key `IntSet.member` bldng)
&& (not $ key `IntSet.member` rdy)
then key:ks else ks
numCompleted :: BuildPlan -> Int
numCompleted plan = IntMap.fold f 0 (planNumDeps plan)
where
f n total = if n == 0 then total + 1 else total
markReadyAsBuilding :: BuildPlan -> BuildPlan
markReadyAsBuilding plan = plan {
planReady = IntSet.empty,
planBuilding = planBuilding plan `IntSet.union` planReady plan
}
numBuilding :: BuildPlan -> Int
numBuilding = IntSet.size . planBuilding
hasBuilding :: BuildPlan -> Bool
hasBuilding = not . IntSet.null . planBuilding
markCompleted :: BuildPlan -> Target -> BuildPlan
markCompleted plan target
| vertex `IntSet.notMember` planBuilding plan =
error $ "GHC.ParMake.BuildPlan.markCompleted: "
++ "BUG: vertex not in planBuilding"
| otherwise = newPlan
where
vertex = fromMaybe
(error $ "Target '" ++ targetId target ++ "' not in the graph!")
(planVertexOf plan (targetId target))
newBuilding = planBuilding plan `IntSet.difference` IntSet.singleton vertex
deps = planGraphRev plan ! vertex
(newReady, newNumDeps) = foldr updateNumDeps
(planReady plan, planNumDeps plan) deps
updateNumDeps curVertex (rdy, numDeps)
| oldDepsCount <= 0 = error $ "GHC.ParMake.BuildPlan.updateNumDeps: "
++ "BUG: oldDepsCount is " ++ show oldDepsCount
| otherwise = (ready', numDeps')
where
oldDepsCount = numDeps IntMap.! curVertex
newDepsCount = oldDepsCount 1
ready' = if newDepsCount == 0
then rdy `IntSet.union` IntSet.singleton curVertex
else rdy
numDeps' = IntMap.insert curVertex newDepsCount numDeps
newPlan = plan {
planBuilding = newBuilding,
planReady = newReady,
planNumDeps = newNumDeps
}