[Git][ghc/ghc][wip/T22010] Convert dominators to Word64
Jaro Reinders (@Noughtmare)
gitlab at gitlab.haskell.org
Fri Jun 2 15:24:01 UTC 2023
Jaro Reinders pushed to branch wip/T22010 at Glasgow Haskell Compiler / GHC
Commits:
426bb3ad by Jaro Reinders at 2023-06-02T17:23:48+02:00
Convert dominators to Word64
- - - - -
3 changed files:
- compiler/GHC/Cmm/Dominators.hs
- compiler/GHC/CmmToAsm/CFG.hs
- compiler/GHC/CmmToAsm/CFG/Dominators.hs
Changes:
=====================================
compiler/GHC/Cmm/Dominators.hs
=====================================
@@ -28,6 +28,7 @@ import qualified Data.Tree as Tree
import qualified Data.IntMap.Strict as IM
import qualified Data.IntSet as IS
+import Data.Word
import qualified GHC.CmmToAsm.CFG.Dominators as LT
@@ -41,6 +42,10 @@ import GHC.Cmm
import GHC.Utils.Outputable( Outputable(..), text, int, hcat, (<+>))
import GHC.Utils.Misc
import GHC.Utils.Panic
+import GHC.Data.Word64Map (Word64Map)
+import GHC.Data.Word64Set (Word64Set)
+import qualified GHC.Data.Word64Map as WM
+import qualified GHC.Data.Word64Set as WS
-- | =Dominator sets
@@ -132,30 +137,31 @@ graphWithDominators :: forall node .
graphWithDominators g = GraphWithDominators (reachable rpblocks g) dmap rpmap
where rpblocks = revPostorderFrom (graphMap g) (g_entry g)
rplabels' = map entryLabel rpblocks
- rplabels :: Array Int Label
+ rplabels :: Array Word64 Label
rplabels = listArray bounds rplabels'
rpmap :: LabelMap RPNum
rpmap = mapFromList $ zipWith kvpair rpblocks [0..]
where kvpair block i = (entryLabel block, RPNum i)
- labelIndex :: Label -> Int
+ labelIndex :: Label -> Word64
labelIndex = flip findLabelIn imap
- where imap :: LabelMap Int
+ where imap :: LabelMap Word64
imap = mapFromList $ zip rplabels' [0..]
blockIndex = labelIndex . entryLabel
- bounds = (0, length rpblocks - 1)
+ bounds :: (Word64, Word64)
+ bounds = (0, fromIntegral (length rpblocks - 1))
- ltGraph :: [Block node C C] -> LT.Graph
- ltGraph [] = IM.empty
+ ltGraph :: [Block node C C] -> Word64Map Word64Set
+ ltGraph [] = WM.empty
ltGraph (block:blocks) =
- IM.insert
+ WM.insert
(blockIndex block)
- (IS.fromList $ map labelIndex $ successors block)
+ (WS.fromList $ map labelIndex $ successors block)
(ltGraph blocks)
- idom_array :: Array Int LT.Node
+ idom_array :: Array Word64 Word64
idom_array = array bounds $ LT.idom (0, ltGraph rpblocks)
domSet 0 = EntryNode
=====================================
compiler/GHC/CmmToAsm/CFG.hs
=====================================
@@ -858,7 +858,7 @@ loopInfo cfg root = LoopInfo { liBackEdges = backEdges
rooted = ( fromBlockId root
, toWord64Map $ fmap toWord64Set graph) :: (Word64, Word64Map Word64Set)
-- FIXME: Convert domTree to use Word64Map/Set too.
- tree = fmap toBlockId $ undefined Dom.domTree rooted :: Tree BlockId
+ tree = fmap toBlockId $ Dom.domTree rooted :: Tree BlockId
-- Map from Nodes to their dominators
domMap :: LabelMap LabelSet
=====================================
compiler/GHC/CmmToAsm/CFG/Dominators.hs
=====================================
@@ -61,6 +61,11 @@ import Data.Array.ST
import Data.Array.Base
(unsafeNewArray_
,unsafeWrite,unsafeRead)
+import GHC.Data.Word64Set (Word64Set)
+import qualified GHC.Data.Word64Set as WS
+import GHC.Data.Word64Map (Word64Map)
+import qualified GHC.Data.Word64Map as WM
+import Data.Word
-----------------------------------------------------------------------------
@@ -68,23 +73,23 @@ type Node = Int
type Path = [Node]
type Edge = (Node,Node)
type Graph = IntMap IntSet
-type Rooted = (Node, Graph)
+type Rooted = (Word64, Word64Map Word64Set)
-----------------------------------------------------------------------------
-- | /Dominators/.
-- Complexity as for @idom@
-dom :: Rooted -> [(Node, Path)]
+dom :: Rooted -> [(Word64, [Word64])]
dom = ancestors . domTree
-- | /Post-dominators/.
-- Complexity as for @idom at .
-pdom :: Rooted -> [(Node, Path)]
+pdom :: Rooted -> [(Word64, [Word64])]
pdom = ancestors . pdomTree
-- | /Dominator tree/.
-- Complexity as for @idom at .
-domTree :: Rooted -> Tree Node
+domTree :: Rooted -> Tree Word64
domTree a@(r,_) =
let is = filter ((/=r).fst) (idom a)
tg = fromEdges (fmap swap is)
@@ -92,7 +97,7 @@ domTree a@(r,_) =
-- | /Post-dominator tree/.
-- Complexity as for @idom at .
-pdomTree :: Rooted -> Tree Node
+pdomTree :: Rooted -> Tree Word64
pdomTree a@(r,_) =
let is = filter ((/=r).fst) (ipdom a)
tg = fromEdges (fmap swap is)
@@ -105,29 +110,29 @@ 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 -> [(Node,Node)]
+idom :: Rooted -> [(Word64,Word64)]
idom rg = runST (evalS idomM =<< initEnv (pruneReach rg))
-- | /Immediate post-dominators/.
-- Complexity as for @idom at .
-ipdom :: Rooted -> [(Node,Node)]
-ipdom rg = runST (evalS idomM =<< initEnv (pruneReach (second predG rg)))
+ipdom :: Rooted -> [(Word64,Word64)]
+ipdom rg = runST (evalS idomM =<< initEnv (pruneReach (second predGW rg)))
-----------------------------------------------------------------------------
-- | /Post-dominated depth-first search/.
-pddfs :: Rooted -> [Node]
+pddfs :: Rooted -> [Word64]
pddfs = reverse . rpddfs
-- | /Reverse post-dominated depth-first search/.
-rpddfs :: Rooted -> [Node]
+rpddfs :: Rooted -> [Word64]
rpddfs = concat . levels . pdomTree
-----------------------------------------------------------------------------
type Dom s a = S s (Env s) a
type NodeSet = IntSet
-type NodeMap a = IntMap a
+type NodeMap a = Word64Map a
data Env s = Env
{succE :: !Graph
,predE :: !Graph
@@ -144,11 +149,11 @@ data Env s = Env
,sdnoE :: {-# UNPACK #-}!(Arr s Int)
,sizeE :: {-# UNPACK #-}!(Arr s Int)
,domE :: {-# UNPACK #-}!(Arr s Node)
- ,rnE :: {-# UNPACK #-}!(Arr s Node)}
+ ,rnE :: {-# UNPACK #-}!(Arr s Word64)}
-----------------------------------------------------------------------------
-idomM :: Dom s [(Node,Node)]
+idomM :: Dom s [(Word64,Word64)]
idomM = do
dfsDom =<< rootM
n <- gets dfsE
@@ -296,7 +301,7 @@ initEnv (r0,g0) = do
-- Graph renumbered to indices from 1 to |V|
let (g,rnmap) = renum 1 g0
pred = predG g -- reverse graph
- root = rnmap IM.! r0 -- renamed root
+ root = rnmap WM.! r0 -- renamed root
n = IM.size g
ns = [0..n]
m = n+1
@@ -304,9 +309,9 @@ initEnv (r0,g0) = do
let bucket = IM.fromList
(zip ns (repeat mempty))
- rna <- newI m
+ rna <- newW m
writes rna (fmap swap
- (IM.toList rnmap))
+ (WM.toList rnmap))
doms <- newI m
sdno <- newI m
@@ -347,7 +352,7 @@ initEnv (r0,g0) = do
,bucketE = bucket
,domE = doms})
-fromEnv :: Dom s [(Node,Node)]
+fromEnv :: Dom s [(Word64,Word64)]
fromEnv = do
dom <- gets domE
rn <- gets rnE
@@ -422,6 +427,9 @@ new n = unsafeNewArray_ (0,n-1)
newI :: Int -> ST s (Arr s Int)
newI = new
+newW :: Int -> ST s (Arr s Word64)
+newW = new
+
writes :: (MArray (A s) a (ST s))
=> Arr s a -> [(Int,a)] -> ST s ()
writes a xs = forM_ xs (\(i,x) -> (a.=x) i)
@@ -430,11 +438,11 @@ 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 :: [(Node, [Node])] -> Graph
-fromAdj = IM.fromList . fmap (second IS.fromList)
+fromAdj :: [(Word64, [Word64])] -> Word64Map Word64Set
+fromAdj = WM.fromList . fmap (second WS.fromList)
-fromEdges :: [Edge] -> Graph
-fromEdges = collectI IS.union fst (IS.singleton . snd)
+fromEdges :: [(Word64,Word64)] -> Word64Map Word64Set
+fromEdges = collectW WS.union fst (WS.singleton . snd)
toAdj :: Graph -> [(Node, [Node])]
toAdj = fmap (second IS.toList) . IM.toList
@@ -451,15 +459,24 @@ predG g = IM.unionWith IS.union (go g) g0
m
(IS.toList a))
+predGW :: Word64Map Word64Set -> Word64Map Word64Set
+predGW g = WM.unionWith WS.union (go g) g0
+ where g0 = fmap (const mempty) g
+ go = flip WM.foldrWithKey mempty (\i a m ->
+ foldl' (\m p -> WM.insertWith mappend p
+ (WS.singleton i) m)
+ m
+ (WS.toList a))
+
pruneReach :: Rooted -> Rooted
pruneReach (r,g) = (r,g2)
where is = reachable
(maybe mempty id
- . flip IM.lookup g) $ r
- g2 = IM.fromList
- . fmap (second (IS.filter (`IS.member`is)))
- . filter ((`IS.member`is) . fst)
- . IM.toList $ g
+ . flip WM.lookup g) $ r
+ g2 = WM.fromList
+ . fmap (second (WS.filter (`WS.member`is)))
+ . filter ((`WS.member`is) . fst)
+ . WM.toList $ g
tip :: Tree a -> (a, [Tree a])
tip (Node a ts) = (a, ts)
@@ -476,21 +493,21 @@ ancestors = go []
in p acc' xs ++ concatMap (go acc') xs
p is = fmap (flip (,) is . rootLabel)
-asGraph :: Tree Node -> Rooted
+asGraph :: Tree Word64 -> Rooted
asGraph 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 Node
-asTree (r,g) = let go a = Node a (fmap go ((IS.toList . f) a))
- f = (g !)
+asTree :: Rooted -> Tree Word64
+asTree (r,g) = let go a = Node a (fmap go ((WS.toList . f) a))
+ f = (g WM.!)
in go r
-reachable :: (Node -> NodeSet) -> (Node -> NodeSet)
-reachable f a = go (IS.singleton a) a
+reachable :: (Word64 -> Word64Set) -> (Word64 -> Word64Set)
+reachable f a = go (WS.singleton a) a
where go seen a = let s = f a
- as = IS.toList (s `IS.difference` seen)
- in foldl' go (s `IS.union` seen) as
+ as = WS.toList (s `WS.difference` seen)
+ in foldl' go (s `WS.union` seen) as
collectI :: (c -> c -> c)
-> (a -> Int) -> (a -> c) -> [a] -> IntMap c
@@ -499,17 +516,24 @@ collectI (<>) f g
(f a)
(g a) m) mempty
+collectW :: (c -> c -> c)
+ -> (a -> Word64) -> (a -> c) -> [a] -> Word64Map c
+collectW (<>) f g
+ = foldl' (\m a -> WM.insertWith (<>)
+ (f a)
+ (g a) m) mempty
+
-- | renum n g: Rename all nodes
--
-- Gives nodes sequential names starting at n.
-- Returns the new graph and a mapping.
-- (renamed, old -> new)
-renum :: Int -> Graph -> (Graph, NodeMap Node)
+renum :: Node -> Word64Map Word64Set -> (Graph, NodeMap Node)
renum from = (\(_,m,g)->(g,m))
- . IM.foldrWithKey
+ . WM.foldrWithKey
(\i ss (!n,!env,!new)->
let (j,n2,env2) = go n env i
- (n3,env3,ss2) = IS.fold
+ (n3,env3,ss2) = WS.fold
(\k (!n,!env,!new)->
case go n env k of
(l,n2,env2)-> (n2,env2,l `IS.insert` new))
@@ -518,12 +542,12 @@ renum from = (\(_,m,g)->(g,m))
in (n3,env3,new2)) (from,mempty,mempty)
where go :: Int
-> NodeMap Node
- -> Node
+ -> Word64
-> (Node,Int,NodeMap Node)
go !n !env i =
- case IM.lookup i env of
+ case WM.lookup i env of
Just j -> (j,n,env)
- Nothing -> (n,n+1,IM.insert i n env)
+ Nothing -> (n,n+1,WM.insert i n env)
-----------------------------------------------------------------------------
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/426bb3ad0fac1f31bd5950b7276f7d02ff6e7618
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/426bb3ad0fac1f31bd5950b7276f7d02ff6e7618
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/20230602/90b846f5/attachment-0001.html>
More information about the ghc-commits
mailing list