[Git][ghc/ghc][wip/T22010] Fix type synonyms in Dominators.hs
Jaro Reinders (@Noughtmare)
gitlab at gitlab.haskell.org
Fri Jun 23 10:02:10 UTC 2023
Jaro Reinders pushed to branch wip/T22010 at Glasgow Haskell Compiler / GHC
Commits:
82adadaa by Jaro Reinders at 2023-06-23T12:01:55+02:00
Fix type synonyms in Dominators.hs
- - - - -
1 changed file:
- compiler/GHC/CmmToAsm/CFG/Dominators.hs
Changes:
=====================================
compiler/GHC/CmmToAsm/CFG/Dominators.hs
=====================================
@@ -21,8 +21,8 @@
/Advanced Compiler Design and Implementation/, 1997.
\[3\] Brisk, Sarrafzadeh,
- /Interference Graphs for Procedures in Static Single/
- /Information Form are Interval Graphs/, 2007.
+ /Interference CGraphs for Procedures in Static Single/
+ /Information Form are Interval CGraphs/, 2007.
* Strictness
@@ -40,7 +40,7 @@ module GHC.CmmToAsm.CFG.Dominators (
,pddfs,rpddfs
,fromAdj,fromEdges
,toAdj,toEdges
- ,asTree,asGraph
+ ,asTree,asCGraph
,parents,ancestors
) where
@@ -69,27 +69,31 @@ import Data.Word
-----------------------------------------------------------------------------
-type Node = Int
-type Path = [Node]
-type Edge = (Node,Node)
-type Graph = IntMap IntSet
-type Rooted = (Word64, Word64Map Word64Set)
+-- Compacted nodes; these can be stored in contiguous arrays
+type CNode = Int
+type CGraph = IntMap IntSet
+
+type Node = Word64
+type Path = [Node]
+type Edge = (Node, Node)
+type Graph = Word64Map Word64Set
+type Rooted = (Node, Graph)
-----------------------------------------------------------------------------
-- | /Dominators/.
-- Complexity as for @idom@
-dom :: Rooted -> [(Word64, [Word64])]
+dom :: Rooted -> [(Node, Path)]
dom = ancestors . domTree
-- | /Post-dominators/.
-- Complexity as for @idom at .
-pdom :: Rooted -> [(Word64, [Word64])]
+pdom :: Rooted -> [(Node, Path)]
pdom = ancestors . pdomTree
-- | /Dominator tree/.
-- Complexity as for @idom at .
-domTree :: Rooted -> Tree Word64
+domTree :: Rooted -> Tree Node
domTree a@(r,_) =
let is = filter ((/=r).fst) (idom a)
tg = fromEdges (fmap swap is)
@@ -97,7 +101,7 @@ domTree a@(r,_) =
-- | /Post-dominator tree/.
-- Complexity as for @idom at .
-pdomTree :: Rooted -> Tree Word64
+pdomTree :: Rooted -> Tree Node
pdomTree a@(r,_) =
let is = filter ((/=r).fst) (ipdom a)
tg = fromEdges (fmap swap is)
@@ -110,49 +114,50 @@ pdomTree a@(r,_) =
-- This Complexity bound assumes /O(1)/ indexing. Since we're
-- using @IntMap@, it has an additional /lg |V|/ factor
-- somewhere in there. I'm not sure where.
-idom :: Rooted -> [(Word64,Word64)]
+idom :: Rooted -> [(Node,Node)]
idom rg = runST (evalS idomM =<< initEnv (pruneReach rg))
-- | /Immediate post-dominators/.
-- Complexity as for @idom at .
-ipdom :: Rooted -> [(Word64,Word64)]
+ipdom :: Rooted -> [(Node,Node)]
ipdom rg = runST (evalS idomM =<< initEnv (pruneReach (second predGW rg)))
-----------------------------------------------------------------------------
-- | /Post-dominated depth-first search/.
-pddfs :: Rooted -> [Word64]
+pddfs :: Rooted -> [Node]
pddfs = reverse . rpddfs
-- | /Reverse post-dominated depth-first search/.
-rpddfs :: Rooted -> [Word64]
+rpddfs :: Rooted -> [Node]
rpddfs = concat . levels . pdomTree
-----------------------------------------------------------------------------
type Dom s a = S s (Env s) a
+type NodeSet = Word64Set
type NodeMap a = Word64Map a
data Env s = Env
- {succE :: !Graph
- ,predE :: !Graph
- ,bucketE :: !Graph
+ {succE :: !CGraph
+ ,predE :: !CGraph
+ ,bucketE :: !CGraph
,dfsE :: {-# UNPACK #-}!Int
- ,zeroE :: {-# UNPACK #-}!Node
- ,rootE :: {-# UNPACK #-}!Node
- ,labelE :: {-# UNPACK #-}!(Arr s Node)
- ,parentE :: {-# UNPACK #-}!(Arr s Node)
- ,ancestorE :: {-# UNPACK #-}!(Arr s Node)
- ,childE :: {-# UNPACK #-}!(Arr s Node)
- ,ndfsE :: {-# UNPACK #-}!(Arr s Node)
+ ,zeroE :: {-# UNPACK #-}!CNode
+ ,rootE :: {-# UNPACK #-}!CNode
+ ,labelE :: {-# UNPACK #-}!(Arr s CNode)
+ ,parentE :: {-# UNPACK #-}!(Arr s CNode)
+ ,ancestorE :: {-# UNPACK #-}!(Arr s CNode)
+ ,childE :: {-# UNPACK #-}!(Arr s CNode)
+ ,ndfsE :: {-# UNPACK #-}!(Arr s CNode)
,dfnE :: {-# UNPACK #-}!(Arr s Int)
,sdnoE :: {-# UNPACK #-}!(Arr s Int)
,sizeE :: {-# UNPACK #-}!(Arr s Int)
- ,domE :: {-# UNPACK #-}!(Arr s Node)
- ,rnE :: {-# UNPACK #-}!(Arr s Word64)}
+ ,domE :: {-# UNPACK #-}!(Arr s CNode)
+ ,rnE :: {-# UNPACK #-}!(Arr s Node)}
-----------------------------------------------------------------------------
-idomM :: Dom s [(Word64,Word64)]
+idomM :: Dom s [(Node,Node)]
idomM = do
dfsDom =<< rootM
n <- gets dfsE
@@ -192,7 +197,7 @@ idomM = do
-----------------------------------------------------------------------------
-eval :: Node -> Dom s Node
+eval :: CNode -> Dom s CNode
eval v = do
n0 <- zeroM
a <- ancestorM v
@@ -209,7 +214,7 @@ eval v = do
True-> return l
False-> return la
-compress :: Node -> Dom s ()
+compress :: CNode -> Dom s ()
compress v = do
n0 <- zeroM
a <- ancestorM v
@@ -228,7 +233,7 @@ compress v = do
-----------------------------------------------------------------------------
-link :: Node -> Node -> Dom s ()
+link :: CNode -> CNode -> Dom s ()
link v w = do
n0 <- zeroM
lw <- labelM w
@@ -272,7 +277,7 @@ link v w = do
-----------------------------------------------------------------------------
-dfsDom :: Node -> Dom s ()
+dfsDom :: CNode -> Dom s ()
dfsDom i = do
_ <- go i
n0 <- zeroM
@@ -297,7 +302,7 @@ dfsDom i = do
initEnv :: Rooted -> ST s (Env s)
initEnv (r0,g0) = do
- -- Graph renumbered to indices from 1 to |V|
+ -- CGraph renumbered to indices from 1 to |V|
let (g,rnmap) = renum 1 g0
pred = predG g -- reverse graph
root = rnmap WM.! r0 -- renamed root
@@ -351,7 +356,7 @@ initEnv (r0,g0) = do
,bucketE = bucket
,domE = doms})
-fromEnv :: Dom s [(Word64,Word64)]
+fromEnv :: Dom s [(Node,Node)]
fromEnv = do
dom <- gets domE
rn <- gets rnE
@@ -365,33 +370,33 @@ fromEnv = do
-----------------------------------------------------------------------------
-zeroM :: Dom s Node
+zeroM :: Dom s CNode
zeroM = gets zeroE
-domM :: Node -> Dom s Node
+domM :: CNode -> Dom s CNode
domM = fetch domE
-rootM :: Dom s Node
+rootM :: Dom s CNode
rootM = gets rootE
-succsM :: Node -> Dom s [Node]
+succsM :: CNode -> Dom s [CNode]
succsM i = gets (IS.toList . (! i) . succE)
-predsM :: Node -> Dom s [Node]
+predsM :: CNode -> Dom s [CNode]
predsM i = gets (IS.toList . (! i) . predE)
-bucketM :: Node -> Dom s [Node]
+bucketM :: CNode -> Dom s [CNode]
bucketM i = gets (IS.toList . (! i) . bucketE)
-sizeM :: Node -> Dom s Int
+sizeM :: CNode -> Dom s Int
sizeM = fetch sizeE
-sdnoM :: Node -> Dom s Int
+sdnoM :: CNode -> Dom s Int
sdnoM = fetch sdnoE
--- dfnM :: Node -> Dom s Int
+-- dfnM :: CNode -> Dom s Int
-- dfnM = fetch dfnE
-ndfsM :: Int -> Dom s Node
+ndfsM :: Int -> Dom s CNode
ndfsM = fetch ndfsE
-childM :: Node -> Dom s Node
+childM :: CNode -> Dom s CNode
childM = fetch childE
-ancestorM :: Node -> Dom s Node
+ancestorM :: CNode -> Dom s CNode
ancestorM = fetch ancestorE
-parentM :: Node -> Dom s Node
+parentM :: CNode -> Dom s CNode
parentM = fetch parentE
-labelM :: Node -> Dom s Node
+labelM :: CNode -> Dom s CNode
labelM = fetch labelE
nextM :: Dom s Int
nextM = do
@@ -426,7 +431,7 @@ new n = unsafeNewArray_ (0,n-1)
newI :: Int -> ST s (Arr s Int)
newI = new
-newW :: Int -> ST s (Arr s Word64)
+newW :: Int -> ST s (Arr s Node)
newW = new
writes :: (MArray (A s) a (ST s))
@@ -437,19 +442,19 @@ writes a xs = forM_ xs (\(i,x) -> (a.=x) i)
(!) :: Monoid a => IntMap a -> Int -> a
(!) g n = maybe mempty id (IM.lookup n g)
-fromAdj :: [(Word64, [Word64])] -> Word64Map Word64Set
+fromAdj :: [(Node, [Node])] -> Graph
fromAdj = WM.fromList . fmap (second WS.fromList)
-fromEdges :: [(Word64,Word64)] -> Word64Map Word64Set
+fromEdges :: [(Node,Node)] -> Graph
fromEdges = collectW WS.union fst (WS.singleton . snd)
toAdj :: Graph -> [(Node, [Node])]
-toAdj = fmap (second IS.toList) . IM.toList
+toAdj = fmap (second WS.toList) . WM.toList
toEdges :: Graph -> [Edge]
toEdges = concatMap (uncurry (fmap . (,))) . toAdj
-predG :: Graph -> Graph
+predG :: CGraph -> CGraph
predG g = IM.unionWith IS.union (go g) g0
where g0 = fmap (const mempty) g
go = flip IM.foldrWithKey mempty (\i a m ->
@@ -458,7 +463,7 @@ predG g = IM.unionWith IS.union (go g) g0
m
(IS.toList a))
-predGW :: Word64Map Word64Set -> Word64Map Word64Set
+predGW :: Graph -> Graph
predGW g = WM.unionWith WS.union (go g) g0
where g0 = fmap (const mempty) g
go = flip WM.foldrWithKey mempty (\i a m ->
@@ -492,26 +497,26 @@ ancestors = go []
in p acc' xs ++ concatMap (go acc') xs
p is = fmap (flip (,) is . rootLabel)
-asGraph :: Tree Word64 -> Rooted
-asGraph t@(Node a _) = let g = go t in (a, fromAdj g)
+asCGraph :: Tree Node -> Rooted
+asCGraph t@(Node a _) = let g = go t in (a, fromAdj g)
where go (Node a ts) = let as = (fst . unzip . fmap tip) ts
in (a, as) : concatMap go ts
-asTree :: Rooted -> Tree Word64
+asTree :: Rooted -> Tree Node
asTree (r,g) = let go a = Node a (fmap go ((WS.toList . f) a))
f = (g !)
in go r
where (!) g n = maybe mempty id (WM.lookup n g)
-reachable :: (Word64 -> Word64Set) -> (Word64 -> Word64Set)
+reachable :: (Node -> NodeSet) -> (Node -> NodeSet)
reachable f a = go (WS.singleton a) a
where go seen a = let s = f a
as = WS.toList (s `WS.difference` seen)
in foldl' go (s `WS.union` seen) as
collectW :: (c -> c -> c)
- -> (a -> Word64) -> (a -> c) -> [a] -> Word64Map c
+ -> (a -> Node) -> (a -> c) -> [a] -> Word64Map c
collectW (<>) f g
= foldl' (\m a -> WM.insertWith (<>)
(f a)
@@ -522,7 +527,7 @@ collectW (<>) f g
-- Gives nodes sequential names starting at n.
-- Returns the new graph and a mapping.
-- (renamed, old -> new)
-renum :: Node -> Word64Map Word64Set -> (Graph, NodeMap Node)
+renum :: Int -> Graph -> (CGraph, NodeMap CNode)
renum from = (\(_,m,g)->(g,m))
. WM.foldrWithKey
(\i ss (!n,!env,!new)->
@@ -535,9 +540,9 @@ renum from = (\(_,m,g)->(g,m))
new2 = IM.insertWith IS.union j ss2 new
in (n3,env3,new2)) (from,mempty,mempty)
where go :: Int
- -> NodeMap Node
- -> Word64
- -> (Node,Int,NodeMap Node)
+ -> NodeMap CNode
+ -> Node
+ -> (CNode,Int,NodeMap CNode)
go !n !env i =
case WM.lookup i env of
Just j -> (j,n,env)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/82adadaaa03fdcbb3bfb8f281f47573c2741790d
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/82adadaaa03fdcbb3bfb8f281f47573c2741790d
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230623/a1bb8bb7/attachment-0001.html>
More information about the ghc-commits
mailing list