158 lines
5.6 KiB
Haskell
158 lines
5.6 KiB
Haskell
--------------------------------------------------------------------------
|
|
-- Copyright (c) 2007-2019, ETH Zurich.
|
|
-- All rights reserved.
|
|
--
|
|
-- This file is distributed under the terms in the attached LICENSE file.
|
|
-- If you do not find this file, copies can be found by writing to:
|
|
-- ETH Zurich D-INFK, Universitaetstasse 6, CH-8092 Zurich. Attn: Systems Group.
|
|
--
|
|
-- Default architecture-specific definitions for Barrelfish
|
|
--
|
|
--------------------------------------------------------------------------
|
|
|
|
module LibDepTree where
|
|
|
|
import HakeTypes
|
|
import qualified Data.Set as S
|
|
import Data.Array (indices)
|
|
import Data.Graph
|
|
import Data.Maybe
|
|
import Data.List (sortBy)
|
|
import qualified Data.Map.Strict as Map
|
|
import qualified RuleDefs -- for libraryPath and applicationPath
|
|
|
|
|
|
type DepElMap = Map.Map DepEl [DepEl]
|
|
data LibDepTree2 = LibDepTree2Graph {
|
|
gGraph :: Graph,
|
|
gNodeFromVertex :: Vertex -> (DepEl, DepEl, [DepEl]),
|
|
gVertexFromKey :: DepEl -> Maybe Vertex
|
|
}
|
|
|
|
-- Given an [HRule], extract a LibDepTree2
|
|
ldtEmToGraph :: DepElMap -> LibDepTree2
|
|
ldtEmToGraph tree = LibDepTree2Graph graph nodeFromVertex vertexFromKey
|
|
where
|
|
(graph, nodeFromVertex, vertexFromKey) = graphFromEdges (wchild ++ wochild)
|
|
wchild = [(a,a,reverse b) | (a,b) <- Map.toList tree]
|
|
wochild = [(c,c,[]) | c <- concat [cs | (_,cs) <- Map.toList tree],
|
|
Map.notMember c tree]
|
|
|
|
ldtDepElMerge :: DepElMap -> DepElMap -> DepElMap
|
|
ldtDepElMerge = Map.unionWith (++)
|
|
|
|
ldtHRuleToDepElMap :: [String] -> HRule -> DepElMap
|
|
ldtHRuleToDepElMap archs hrule = case hrule of
|
|
(Rules rules) -> foldr ldtDepElMerge Map.empty $ map (ldtHRuleToDepElMap archs) rules
|
|
(HakeTypes.Rule rts) -> foldr ldtDepElMerge Map.empty $ map ext_rt rts
|
|
_ -> Map.empty
|
|
|
|
where
|
|
ext_rt :: RuleToken -> DepElMap
|
|
ext_rt rt = case rt of
|
|
(LDep a b) -> if elem (depElArch a) archs then Map.singleton a [b] else Map.empty
|
|
_ -> Map.empty
|
|
|
|
|
|
|
|
ldtFromJust :: Maybe a -> String -> a
|
|
ldtFromJust Nothing err = errorWithoutStackTrace ("No Graph Node for " ++ err) -- yuck
|
|
ldtFromJust (Just x) err = x
|
|
|
|
ldtDepOf :: LibDepTree2 -> DepEl -> [DepEl]
|
|
ldtDepOf gr = sortBy rtCmp . map extractDepEl . mTopSort . mVertexFromKey
|
|
where
|
|
triFst (a,_,_) = a
|
|
extractDepEl = triFst . nodeFromVertex
|
|
(graph, nodeFromVertex, vertexFromKey) = (gGraph gr, gNodeFromVertex gr, gVertexFromKey gr)
|
|
|
|
mVertexFromKey :: DepEl -> Vertex
|
|
mVertexFromKey x = ldtFromJust (vertexFromKey x) ("No node " ++ show x)
|
|
|
|
-- We move the DepMods to the front, so the --whole-archive will be
|
|
-- linked first
|
|
rtCmp :: DepEl -> DepEl -> Ordering
|
|
rtCmp (DepMod _ _) (DepLib _ _) = LT
|
|
rtCmp (DepLib _ _) (DepMod _ _) = GT
|
|
rtCmp _ _ = EQ
|
|
|
|
-- The following functions are copied from Data.Graph and extended with
|
|
-- an additional "start" vertex
|
|
postorder :: Tree a -> [a] -> [a]
|
|
postorder (Node a ts) = postorderF ts . (a :)
|
|
|
|
postorderF :: Forest a -> [a] -> [a]
|
|
postorderF ts = foldr (.) id $ map postorder ts
|
|
|
|
mPostOrd :: Vertex -> [Vertex]
|
|
mPostOrd start = postorderF (mDff) []
|
|
where
|
|
mDff = dfs graph [start]
|
|
|
|
mTopSort :: Vertex -> [Vertex]
|
|
mTopSort start = tail $ reverse $ mPostOrd start
|
|
|
|
ldtDepDfs :: LibDepTree2 -> DepEl -> Tree DepEl
|
|
ldtDepDfs ldt start = fmap extractDepEl $ head (dfs graph [fromJust $ vertexFromKey start])
|
|
where
|
|
triFst (a,_,_) = a
|
|
extractDepEl = triFst . nodeFromVertex
|
|
(graph, nodeFromVertex, vertexFromKey) = (gGraph ldt, gNodeFromVertex ldt, gVertexFromKey ldt)
|
|
|
|
ldtDriverModules :: LibDepTree2 -> [(DepEl,DepEl)]
|
|
-- concat $ map depS (indices $ gGraph t)
|
|
ldtDriverModules t = depS =<< indices (gGraph t)
|
|
where
|
|
triFst (a,_,_) = a
|
|
toNode :: Vertex -> DepEl
|
|
toNode = triFst . gNodeFromVertex t
|
|
|
|
depS :: Vertex -> [(DepEl,DepEl)]
|
|
depS = step . ldtDepDfs t . toNode
|
|
|
|
step :: Tree DepEl -> [(DepEl,DepEl)]
|
|
step (Node (DepApp arch name) cs) = [ ((DepApp arch name),x) | x <- concat $ map nm cs]
|
|
where
|
|
nm (Node (DepMod arch name) _) = [DepMod arch name]
|
|
nm _ = []
|
|
step _ = []
|
|
|
|
ldtPrettyTree :: Tree DepEl -> String
|
|
ldtPrettyTree tr = prettyPrintR tr ""
|
|
where
|
|
prettyPrintR (Node lbl cs) ind = (ind ++ (show lbl)) ++ "\n" ++
|
|
(concat $ [prettyPrintR c ("+ " ++ ind) | c <- cs])
|
|
|
|
-- Replace the Ldt tokens with In rule tokens
|
|
ldtRuleExpand :: LibDepTree2 -> HRule -> HRule
|
|
ldtRuleExpand ldt x = case x of
|
|
Rule tokens -> Rule $ concat [ldtTokenExpand ldt x | x <- tokens]
|
|
Phony s b tokens -> Phony s b $ concat [ldtTokenExpand ldt x | x <- tokens]
|
|
Rules rules -> Rules [ldtRuleExpand ldt x | x <- rules]
|
|
_ -> x -- .. that means we dont support Ldt tokens under an Include
|
|
|
|
|
|
ldtTokenExpand :: LibDepTree2 -> RuleToken -> [RuleToken]
|
|
ldtTokenExpand ldt x = case x of
|
|
Ldt tree arch app -> concat $ map toRT $ ldtDepOf ldt (DepApp arch app)
|
|
where
|
|
toRT :: DepEl -> [RuleToken]
|
|
-- XXX: I couldnt figure out where we usually prefix the architecture
|
|
toRT (DepApp xarch x) = [In tree arch $
|
|
("./" ++ arch ++ (RuleDefs.applicationPath (RuleDefs.options arch) x))]
|
|
toRT (DepLib xarch x) = [In tree arch $
|
|
("./" ++ arch ++ (RuleDefs.libraryPath (RuleDefs.options arch) x))]
|
|
toRT (DepMod xarch x) =
|
|
[Str "-Wl,--whole-archive"] ++
|
|
(toRT (DepLib xarch x)) ++
|
|
[Str "-Wl,--no-whole-archive"]
|
|
_ -> [x]
|
|
|
|
|
|
ldtDebug :: LibDepTree2 -> DepEl -> IO ()
|
|
ldtDebug ldt el = do
|
|
putStrLn $ "Deps of " ++ (show el) ++ ":"
|
|
putStrLn $ ldtPrettyTree $ ldtDepDfs ldt el
|
|
putStrLn $ show $ ldtDepOf ldt el
|
|
return ()
|