{-# LANGUAGE GADTs, BangPatterns, ScopedTypeVariables #-}
module GHC.Cmm.CommonBlockElim
( elimCommonBlocks
)
where
import GHC.Prelude hiding (iterate, succ, unzip, zip)
import GHC.Cmm.BlockId
import GHC.Cmm
import GHC.Cmm.Utils
import GHC.Cmm.Switch (eqSwitchTargetWith)
import GHC.Cmm.ContFlowOpt
import GHC.Cmm.Dataflow.Block
import GHC.Cmm.Dataflow.Graph
import GHC.Cmm.Dataflow.Label
import GHC.Cmm.Dataflow.Collections
import Data.Maybe (mapMaybe)
import qualified Data.List as List
import Data.Word
import qualified Data.Map as M
import GHC.Utils.Outputable
import GHC.Utils.Panic
import qualified GHC.Data.TrieMap as TM
import GHC.Types.Unique.FM
import GHC.Types.Unique
import Control.Arrow (first, second)
elimCommonBlocks :: CmmGraph -> CmmGraph
elimCommonBlocks :: CmmGraph -> CmmGraph
elimCommonBlocks CmmGraph
g = LabelMap BlockId -> CmmGraph -> CmmGraph
replaceLabels LabelMap BlockId
env (CmmGraph -> CmmGraph) -> CmmGraph -> CmmGraph
forall a b. (a -> b) -> a -> b
$ LabelMap BlockId -> CmmGraph -> CmmGraph
copyTicks LabelMap BlockId
env CmmGraph
g
where
env :: LabelMap BlockId
env = LabelMap BlockId -> [[(Key, DistinctBlocks)]] -> LabelMap BlockId
iterate LabelMap BlockId
forall (map :: * -> *) a. IsMap map => map a
mapEmpty [[(Key, DistinctBlocks)]]
blocks_with_key
groups :: [DistinctBlocks]
groups = (CmmBlock -> Int) -> DistinctBlocks -> [DistinctBlocks]
forall a. (a -> Int) -> [a] -> [[a]]
groupByInt CmmBlock -> Int
hash_block (CmmGraph -> DistinctBlocks
toBlockList CmmGraph
g) :: [[CmmBlock]]
blocks_with_key :: [[(Key, DistinctBlocks)]]
blocks_with_key = [ [ (CmmBlock -> Key
forall (thing :: Extensibility -> Extensibility -> *)
(e :: Extensibility).
NonLocal thing =>
thing e C -> Key
successors CmmBlock
b, [CmmBlock
b]) | CmmBlock
b <- DistinctBlocks
bs] | DistinctBlocks
bs <- [DistinctBlocks]
groups]
type DistinctBlocks = [CmmBlock]
type Key = [Label]
type Subst = LabelMap BlockId
iterate :: Subst -> [[(Key, DistinctBlocks)]] -> Subst
iterate :: LabelMap BlockId -> [[(Key, DistinctBlocks)]] -> LabelMap BlockId
iterate LabelMap BlockId
subst [[(Key, DistinctBlocks)]]
blocks
| LabelMap BlockId -> Bool
forall (map :: * -> *) a. IsMap map => map a -> Bool
mapNull LabelMap BlockId
new_substs = LabelMap BlockId
subst
| Bool
otherwise = LabelMap BlockId -> [[(Key, DistinctBlocks)]] -> LabelMap BlockId
iterate LabelMap BlockId
subst' [[(Key, DistinctBlocks)]]
updated_blocks
where
grouped_blocks :: [[(Key, [DistinctBlocks])]]
grouped_blocks :: [[(Key, [DistinctBlocks])]]
grouped_blocks = ([(Key, DistinctBlocks)] -> [(Key, [DistinctBlocks])])
-> [[(Key, DistinctBlocks)]] -> [[(Key, [DistinctBlocks])]]
forall a b. (a -> b) -> [a] -> [b]
map [(Key, DistinctBlocks)] -> [(Key, [DistinctBlocks])]
groupByLabel [[(Key, DistinctBlocks)]]
blocks
merged_blocks :: [[(Key, DistinctBlocks)]]
(LabelMap BlockId
new_substs, [[(Key, DistinctBlocks)]]
merged_blocks) = (LabelMap BlockId
-> [(Key, [DistinctBlocks])]
-> (LabelMap BlockId, [(Key, DistinctBlocks)]))
-> LabelMap BlockId
-> [[(Key, [DistinctBlocks])]]
-> (LabelMap BlockId, [[(Key, DistinctBlocks)]])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
List.mapAccumL ((LabelMap BlockId
-> (Key, [DistinctBlocks])
-> (LabelMap BlockId, (Key, DistinctBlocks)))
-> LabelMap BlockId
-> [(Key, [DistinctBlocks])]
-> (LabelMap BlockId, [(Key, DistinctBlocks)])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
List.mapAccumL LabelMap BlockId
-> (Key, [DistinctBlocks])
-> (LabelMap BlockId, (Key, DistinctBlocks))
go) LabelMap BlockId
forall (map :: * -> *) a. IsMap map => map a
mapEmpty [[(Key, [DistinctBlocks])]]
grouped_blocks
where
go :: LabelMap BlockId
-> (Key, [DistinctBlocks])
-> (LabelMap BlockId, (Key, DistinctBlocks))
go !LabelMap BlockId
new_subst1 (Key
k,[DistinctBlocks]
dbs) = (LabelMap BlockId
new_subst1 LabelMap BlockId -> LabelMap BlockId -> LabelMap BlockId
forall (map :: * -> *) a. IsMap map => map a -> map a -> map a
`mapUnion` LabelMap BlockId
new_subst2, (Key
k,DistinctBlocks
db))
where
(LabelMap BlockId
new_subst2, DistinctBlocks
db) = LabelMap BlockId
-> [DistinctBlocks] -> (LabelMap BlockId, DistinctBlocks)
mergeBlockList LabelMap BlockId
subst [DistinctBlocks]
dbs
subst' :: LabelMap BlockId
subst' = LabelMap BlockId
subst LabelMap BlockId -> LabelMap BlockId -> LabelMap BlockId
forall (map :: * -> *) a. IsMap map => map a -> map a -> map a
`mapUnion` LabelMap BlockId
new_substs
updated_blocks :: [[(Key, DistinctBlocks)]]
updated_blocks = ([(Key, DistinctBlocks)] -> [(Key, DistinctBlocks)])
-> [[(Key, DistinctBlocks)]] -> [[(Key, DistinctBlocks)]]
forall a b. (a -> b) -> [a] -> [b]
map (((Key, DistinctBlocks) -> (Key, DistinctBlocks))
-> [(Key, DistinctBlocks)] -> [(Key, DistinctBlocks)]
forall a b. (a -> b) -> [a] -> [b]
map ((Key -> Key) -> (Key, DistinctBlocks) -> (Key, DistinctBlocks)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ((BlockId -> BlockId) -> Key -> Key
forall a b. (a -> b) -> [a] -> [b]
map (LabelMap BlockId -> BlockId -> BlockId
lookupBid LabelMap BlockId
subst')))) [[(Key, DistinctBlocks)]]
merged_blocks
mergeBlocks :: Subst -> DistinctBlocks -> DistinctBlocks -> (Subst, DistinctBlocks)
mergeBlocks :: LabelMap BlockId
-> DistinctBlocks
-> DistinctBlocks
-> (LabelMap BlockId, DistinctBlocks)
mergeBlocks LabelMap BlockId
subst DistinctBlocks
existing DistinctBlocks
new = DistinctBlocks -> (LabelMap BlockId, DistinctBlocks)
go DistinctBlocks
new
where
go :: DistinctBlocks -> (LabelMap BlockId, DistinctBlocks)
go [] = (LabelMap BlockId
forall (map :: * -> *) a. IsMap map => map a
mapEmpty, DistinctBlocks
existing)
go (CmmBlock
b:DistinctBlocks
bs) = case (CmmBlock -> Bool) -> DistinctBlocks -> Maybe CmmBlock
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find ((BlockId -> BlockId -> Bool) -> CmmBlock -> CmmBlock -> Bool
eqBlockBodyWith (LabelMap BlockId -> BlockId -> BlockId -> Bool
eqBid LabelMap BlockId
subst) CmmBlock
b) DistinctBlocks
existing of
Just CmmBlock
b' -> (LabelMap BlockId -> LabelMap BlockId)
-> (LabelMap BlockId, DistinctBlocks)
-> (LabelMap BlockId, DistinctBlocks)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (KeyOf LabelMap -> BlockId -> LabelMap BlockId -> LabelMap BlockId
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert (CmmBlock -> BlockId
forall (thing :: Extensibility -> Extensibility -> *)
(x :: Extensibility).
NonLocal thing =>
thing C x -> BlockId
entryLabel CmmBlock
b) (CmmBlock -> BlockId
forall (thing :: Extensibility -> Extensibility -> *)
(x :: Extensibility).
NonLocal thing =>
thing C x -> BlockId
entryLabel CmmBlock
b')) ((LabelMap BlockId, DistinctBlocks)
-> (LabelMap BlockId, DistinctBlocks))
-> (LabelMap BlockId, DistinctBlocks)
-> (LabelMap BlockId, DistinctBlocks)
forall a b. (a -> b) -> a -> b
$ DistinctBlocks -> (LabelMap BlockId, DistinctBlocks)
go DistinctBlocks
bs
Maybe CmmBlock
Nothing -> (DistinctBlocks -> DistinctBlocks)
-> (LabelMap BlockId, DistinctBlocks)
-> (LabelMap BlockId, DistinctBlocks)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (CmmBlock
bCmmBlock -> DistinctBlocks -> DistinctBlocks
forall a. a -> [a] -> [a]
:) ((LabelMap BlockId, DistinctBlocks)
-> (LabelMap BlockId, DistinctBlocks))
-> (LabelMap BlockId, DistinctBlocks)
-> (LabelMap BlockId, DistinctBlocks)
forall a b. (a -> b) -> a -> b
$ DistinctBlocks -> (LabelMap BlockId, DistinctBlocks)
go DistinctBlocks
bs
mergeBlockList :: Subst -> [DistinctBlocks] -> (Subst, DistinctBlocks)
mergeBlockList :: LabelMap BlockId
-> [DistinctBlocks] -> (LabelMap BlockId, DistinctBlocks)
mergeBlockList LabelMap BlockId
_ [] = String -> SDoc -> (LabelMap BlockId, DistinctBlocks)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"mergeBlockList" SDoc
empty
mergeBlockList LabelMap BlockId
subst (DistinctBlocks
b:[DistinctBlocks]
bs) = LabelMap BlockId
-> DistinctBlocks
-> [DistinctBlocks]
-> (LabelMap BlockId, DistinctBlocks)
go LabelMap BlockId
forall (map :: * -> *) a. IsMap map => map a
mapEmpty DistinctBlocks
b [DistinctBlocks]
bs
where
go :: LabelMap BlockId
-> DistinctBlocks
-> [DistinctBlocks]
-> (LabelMap BlockId, DistinctBlocks)
go !LabelMap BlockId
new_subst1 DistinctBlocks
b [] = (LabelMap BlockId
new_subst1, DistinctBlocks
b)
go !LabelMap BlockId
new_subst1 DistinctBlocks
b1 (DistinctBlocks
b2:[DistinctBlocks]
bs) = LabelMap BlockId
-> DistinctBlocks
-> [DistinctBlocks]
-> (LabelMap BlockId, DistinctBlocks)
go LabelMap BlockId
new_subst DistinctBlocks
b [DistinctBlocks]
bs
where
(LabelMap BlockId
new_subst2, DistinctBlocks
b) = LabelMap BlockId
-> DistinctBlocks
-> DistinctBlocks
-> (LabelMap BlockId, DistinctBlocks)
mergeBlocks LabelMap BlockId
subst DistinctBlocks
b1 DistinctBlocks
b2
new_subst :: LabelMap BlockId
new_subst = LabelMap BlockId
new_subst1 LabelMap BlockId -> LabelMap BlockId -> LabelMap BlockId
forall (map :: * -> *) a. IsMap map => map a -> map a -> map a
`mapUnion` LabelMap BlockId
new_subst2
type HashCode = Int
hash_block :: CmmBlock -> HashCode
hash_block :: CmmBlock -> Int
hash_block CmmBlock
block =
Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral ((CmmNode C O -> Word32 -> Word32, CmmNode O O -> Word32 -> Word32,
CmmNode O C -> Word32 -> Word32)
-> forall (e :: Extensibility) (x :: Extensibility).
Block CmmNode e x
-> IndexedCO x Word32 Word32 -> IndexedCO e Word32 Word32
forall (n :: Extensibility -> Extensibility -> *) a b c.
(n C O -> b -> c, n O O -> b -> b, n O C -> a -> b)
-> forall (e :: Extensibility) (x :: Extensibility).
Block n e x -> IndexedCO x a b -> IndexedCO e c b
foldBlockNodesB3 (CmmNode C O -> Word32 -> Word32
forall {p} {p}. p -> p -> p
hash_fst, CmmNode O O -> Word32 -> Word32
forall {x :: Extensibility}. CmmNode O x -> Word32 -> Word32
hash_mid, CmmNode O C -> Word32 -> Word32
forall {x :: Extensibility}. CmmNode O x -> Word32 -> Word32
hash_lst) CmmBlock
block (Word32
0 :: Word32) Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. (Word32
0x7fffffff :: Word32))
where hash_fst :: p -> p -> p
hash_fst p
_ p
h = p
h
hash_mid :: CmmNode O x -> Word32 -> Word32
hash_mid CmmNode O x
m Word32
h = CmmNode O x -> Word32
forall (x :: Extensibility). CmmNode O x -> Word32
hash_node CmmNode O x
m Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
h Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftL` Int
1
hash_lst :: CmmNode O x -> Word32 -> Word32
hash_lst CmmNode O x
m Word32
h = CmmNode O x -> Word32
forall (x :: Extensibility). CmmNode O x -> Word32
hash_node CmmNode O x
m Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
h Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftL` Int
1
hash_node :: CmmNode O x -> Word32
hash_node :: forall (x :: Extensibility). CmmNode O x -> Word32
hash_node CmmNode O x
n | CmmNode O x -> Bool
forall (x :: Extensibility). CmmNode O x -> Bool
dont_care CmmNode O x
n = Word32
0
hash_node (CmmAssign CmmReg
r CmmExpr
e) = CmmReg -> Word32
hash_reg CmmReg
r Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ CmmExpr -> Word32
hash_e CmmExpr
e
hash_node (CmmStore CmmExpr
e CmmExpr
e') = CmmExpr -> Word32
hash_e CmmExpr
e Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ CmmExpr -> Word32
hash_e CmmExpr
e'
hash_node (CmmUnsafeForeignCall ForeignTarget
t [LocalReg]
_ [CmmExpr]
as) = ForeignTarget -> Word32
hash_tgt ForeignTarget
t Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ (CmmExpr -> Word32) -> [CmmExpr] -> Word32
forall {t :: * -> *} {t}.
Foldable t =>
(t -> Word32) -> t t -> Word32
hash_list CmmExpr -> Word32
hash_e [CmmExpr]
as
hash_node (CmmBranch BlockId
_) = Word32
23
hash_node (CmmCondBranch CmmExpr
p BlockId
_ BlockId
_ Maybe Bool
_) = CmmExpr -> Word32
hash_e CmmExpr
p
hash_node (CmmCall CmmExpr
e Maybe BlockId
_ [GlobalReg]
_ Int
_ Int
_ Int
_) = CmmExpr -> Word32
hash_e CmmExpr
e
hash_node (CmmForeignCall ForeignTarget
t [LocalReg]
_ [CmmExpr]
_ BlockId
_ Int
_ Int
_ Bool
_) = ForeignTarget -> Word32
hash_tgt ForeignTarget
t
hash_node (CmmSwitch CmmExpr
e SwitchTargets
_) = CmmExpr -> Word32
hash_e CmmExpr
e
hash_node CmmNode O x
_ = String -> Word32
forall a. HasCallStack => String -> a
error String
"hash_node: unknown Cmm node!"
hash_reg :: CmmReg -> Word32
hash_reg :: CmmReg -> Word32
hash_reg (CmmLocal LocalReg
localReg) = LocalReg -> Word32
forall a. Uniquable a => a -> Word32
hash_unique LocalReg
localReg
hash_reg (CmmGlobal GlobalReg
_) = Word32
19
hash_e :: CmmExpr -> Word32
hash_e :: CmmExpr -> Word32
hash_e (CmmLit CmmLit
l) = CmmLit -> Word32
hash_lit CmmLit
l
hash_e (CmmLoad CmmExpr
e CmmType
_) = Word32
67 Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ CmmExpr -> Word32
hash_e CmmExpr
e
hash_e (CmmReg CmmReg
r) = CmmReg -> Word32
hash_reg CmmReg
r
hash_e (CmmMachOp MachOp
_ [CmmExpr]
es) = (CmmExpr -> Word32) -> [CmmExpr] -> Word32
forall {t :: * -> *} {t}.
Foldable t =>
(t -> Word32) -> t t -> Word32
hash_list CmmExpr -> Word32
hash_e [CmmExpr]
es
hash_e (CmmRegOff CmmReg
r Int
i) = CmmReg -> Word32
hash_reg CmmReg
r Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Int -> Word32
cvt Int
i
hash_e (CmmStackSlot Area
_ Int
_) = Word32
13
hash_lit :: CmmLit -> Word32
hash_lit :: CmmLit -> Word32
hash_lit (CmmInt Integer
i Width
_) = Integer -> Word32
forall a. Num a => Integer -> a
fromInteger Integer
i
hash_lit (CmmFloat Rational
r Width
_) = Rational -> Word32
forall a b. (RealFrac a, Integral b) => a -> b
truncate Rational
r
hash_lit (CmmVec [CmmLit]
ls) = (CmmLit -> Word32) -> [CmmLit] -> Word32
forall {t :: * -> *} {t}.
Foldable t =>
(t -> Word32) -> t t -> Word32
hash_list CmmLit -> Word32
hash_lit [CmmLit]
ls
hash_lit (CmmLabel CLabel
_) = Word32
119
hash_lit (CmmLabelOff CLabel
_ Int
i) = Int -> Word32
cvt (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$ Int
199 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i
hash_lit (CmmLabelDiffOff CLabel
_ CLabel
_ Int
i Width
_) = Int -> Word32
cvt (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$ Int
299 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i
hash_lit (CmmBlock BlockId
_) = Word32
191
hash_lit (CmmLit
CmmHighStackMark) = Int -> Word32
cvt Int
313
hash_tgt :: ForeignTarget -> Word32
hash_tgt (ForeignTarget CmmExpr
e ForeignConvention
_) = CmmExpr -> Word32
hash_e CmmExpr
e
hash_tgt (PrimTarget CallishMachOp
_) = Word32
31
hash_list :: (t -> Word32) -> t t -> Word32
hash_list t -> Word32
f = (Word32 -> t -> Word32) -> Word32 -> t t -> Word32
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Word32
z t
x -> t -> Word32
f t
x Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
z) (Word32
0::Word32)
cvt :: Int -> Word32
cvt = Integer -> Word32
forall a. Num a => Integer -> a
fromInteger (Integer -> Word32) -> (Int -> Integer) -> Int -> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Integer
forall a. Integral a => a -> Integer
toInteger
hash_unique :: Uniquable a => a -> Word32
hash_unique :: forall a. Uniquable a => a -> Word32
hash_unique = Int -> Word32
cvt (Int -> Word32) -> (a -> Int) -> a -> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Unique -> Int
getKey (Unique -> Int) -> (a -> Unique) -> a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Unique
forall a. Uniquable a => a -> Unique
getUnique
dont_care :: CmmNode O x -> Bool
dont_care :: forall (x :: Extensibility). CmmNode O x -> Bool
dont_care CmmComment {} = Bool
True
dont_care CmmTick {} = Bool
True
dont_care CmmUnwind {} = Bool
True
dont_care CmmNode O x
_other = Bool
False
eqBid :: LabelMap BlockId -> BlockId -> BlockId -> Bool
eqBid :: LabelMap BlockId -> BlockId -> BlockId -> Bool
eqBid LabelMap BlockId
subst BlockId
bid BlockId
bid' = LabelMap BlockId -> BlockId -> BlockId
lookupBid LabelMap BlockId
subst BlockId
bid BlockId -> BlockId -> Bool
forall a. Eq a => a -> a -> Bool
== LabelMap BlockId -> BlockId -> BlockId
lookupBid LabelMap BlockId
subst BlockId
bid'
lookupBid :: LabelMap BlockId -> BlockId -> BlockId
lookupBid :: LabelMap BlockId -> BlockId -> BlockId
lookupBid LabelMap BlockId
subst BlockId
bid = case KeyOf LabelMap -> LabelMap BlockId -> Maybe BlockId
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
BlockId
bid LabelMap BlockId
subst of
Just BlockId
bid -> LabelMap BlockId -> BlockId -> BlockId
lookupBid LabelMap BlockId
subst BlockId
bid
Maybe BlockId
Nothing -> BlockId
bid
eqMiddleWith :: (BlockId -> BlockId -> Bool)
-> CmmNode O O -> CmmNode O O -> Bool
eqMiddleWith :: (BlockId -> BlockId -> Bool) -> CmmNode O O -> CmmNode O O -> Bool
eqMiddleWith BlockId -> BlockId -> Bool
eqBid (CmmAssign CmmReg
r1 CmmExpr
e1) (CmmAssign CmmReg
r2 CmmExpr
e2)
= CmmReg
r1 CmmReg -> CmmReg -> Bool
forall a. Eq a => a -> a -> Bool
== CmmReg
r2 Bool -> Bool -> Bool
&& (BlockId -> BlockId -> Bool) -> CmmExpr -> CmmExpr -> Bool
eqExprWith BlockId -> BlockId -> Bool
eqBid CmmExpr
e1 CmmExpr
e2
eqMiddleWith BlockId -> BlockId -> Bool
eqBid (CmmStore CmmExpr
l1 CmmExpr
r1) (CmmStore CmmExpr
l2 CmmExpr
r2)
= (BlockId -> BlockId -> Bool) -> CmmExpr -> CmmExpr -> Bool
eqExprWith BlockId -> BlockId -> Bool
eqBid CmmExpr
l1 CmmExpr
l2 Bool -> Bool -> Bool
&& (BlockId -> BlockId -> Bool) -> CmmExpr -> CmmExpr -> Bool
eqExprWith BlockId -> BlockId -> Bool
eqBid CmmExpr
r1 CmmExpr
r2
eqMiddleWith BlockId -> BlockId -> Bool
eqBid (CmmUnsafeForeignCall ForeignTarget
t1 [LocalReg]
r1 [CmmExpr]
a1)
(CmmUnsafeForeignCall ForeignTarget
t2 [LocalReg]
r2 [CmmExpr]
a2)
= ForeignTarget
t1 ForeignTarget -> ForeignTarget -> Bool
forall a. Eq a => a -> a -> Bool
== ForeignTarget
t2 Bool -> Bool -> Bool
&& [LocalReg]
r1 [LocalReg] -> [LocalReg] -> Bool
forall a. Eq a => a -> a -> Bool
== [LocalReg]
r2 Bool -> Bool -> Bool
&& (CmmExpr -> CmmExpr -> Bool) -> [CmmExpr] -> [CmmExpr] -> Bool
forall a b. (a -> b -> Bool) -> [a] -> [b] -> Bool
eqListWith ((BlockId -> BlockId -> Bool) -> CmmExpr -> CmmExpr -> Bool
eqExprWith BlockId -> BlockId -> Bool
eqBid) [CmmExpr]
a1 [CmmExpr]
a2
eqMiddleWith BlockId -> BlockId -> Bool
_ CmmNode O O
_ CmmNode O O
_ = Bool
False
eqExprWith :: (BlockId -> BlockId -> Bool)
-> CmmExpr -> CmmExpr -> Bool
eqExprWith :: (BlockId -> BlockId -> Bool) -> CmmExpr -> CmmExpr -> Bool
eqExprWith BlockId -> BlockId -> Bool
eqBid = CmmExpr -> CmmExpr -> Bool
eq
where
CmmLit CmmLit
l1 eq :: CmmExpr -> CmmExpr -> Bool
`eq` CmmLit CmmLit
l2 = CmmLit -> CmmLit -> Bool
eqLit CmmLit
l1 CmmLit
l2
CmmLoad CmmExpr
e1 CmmType
_ `eq` CmmLoad CmmExpr
e2 CmmType
_ = CmmExpr
e1 CmmExpr -> CmmExpr -> Bool
`eq` CmmExpr
e2
CmmReg CmmReg
r1 `eq` CmmReg CmmReg
r2 = CmmReg
r1CmmReg -> CmmReg -> Bool
forall a. Eq a => a -> a -> Bool
==CmmReg
r2
CmmRegOff CmmReg
r1 Int
i1 `eq` CmmRegOff CmmReg
r2 Int
i2 = CmmReg
r1CmmReg -> CmmReg -> Bool
forall a. Eq a => a -> a -> Bool
==CmmReg
r2 Bool -> Bool -> Bool
&& Int
i1Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
i2
CmmMachOp MachOp
op1 [CmmExpr]
es1 `eq` CmmMachOp MachOp
op2 [CmmExpr]
es2 = MachOp
op1MachOp -> MachOp -> Bool
forall a. Eq a => a -> a -> Bool
==MachOp
op2 Bool -> Bool -> Bool
&& [CmmExpr]
es1 [CmmExpr] -> [CmmExpr] -> Bool
`eqs` [CmmExpr]
es2
CmmStackSlot Area
a1 Int
i1 `eq` CmmStackSlot Area
a2 Int
i2 = Area -> Area -> Bool
eqArea Area
a1 Area
a2 Bool -> Bool -> Bool
&& Int
i1Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
i2
CmmExpr
_e1 `eq` CmmExpr
_e2 = Bool
False
[CmmExpr]
xs eqs :: [CmmExpr] -> [CmmExpr] -> Bool
`eqs` [CmmExpr]
ys = (CmmExpr -> CmmExpr -> Bool) -> [CmmExpr] -> [CmmExpr] -> Bool
forall a b. (a -> b -> Bool) -> [a] -> [b] -> Bool
eqListWith CmmExpr -> CmmExpr -> Bool
eq [CmmExpr]
xs [CmmExpr]
ys
eqLit :: CmmLit -> CmmLit -> Bool
eqLit (CmmBlock BlockId
id1) (CmmBlock BlockId
id2) = BlockId -> BlockId -> Bool
eqBid BlockId
id1 BlockId
id2
eqLit CmmLit
l1 CmmLit
l2 = CmmLit
l1 CmmLit -> CmmLit -> Bool
forall a. Eq a => a -> a -> Bool
== CmmLit
l2
eqArea :: Area -> Area -> Bool
eqArea Area
Old Area
Old = Bool
True
eqArea (Young BlockId
id1) (Young BlockId
id2) = BlockId -> BlockId -> Bool
eqBid BlockId
id1 BlockId
id2
eqArea Area
_ Area
_ = Bool
False
eqBlockBodyWith :: (BlockId -> BlockId -> Bool) -> CmmBlock -> CmmBlock -> Bool
eqBlockBodyWith :: (BlockId -> BlockId -> Bool) -> CmmBlock -> CmmBlock -> Bool
eqBlockBodyWith BlockId -> BlockId -> Bool
eqBid CmmBlock
block CmmBlock
block'
= Bool
equal
where (CmmNode C O
_,Block CmmNode O O
m,CmmNode O C
l) = CmmBlock -> (CmmNode C O, Block CmmNode O O, CmmNode O C)
forall (n :: Extensibility -> Extensibility -> *).
Block n C C -> (n C O, Block n O O, n O C)
blockSplit CmmBlock
block
nodes :: [CmmNode O O]
nodes = (CmmNode O O -> Bool) -> [CmmNode O O] -> [CmmNode O O]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (CmmNode O O -> Bool) -> CmmNode O O -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CmmNode O O -> Bool
forall (x :: Extensibility). CmmNode O x -> Bool
dont_care) (Block CmmNode O O -> [CmmNode O O]
forall (n :: Extensibility -> Extensibility -> *).
Block n O O -> [n O O]
blockToList Block CmmNode O O
m)
(CmmNode C O
_,Block CmmNode O O
m',CmmNode O C
l') = CmmBlock -> (CmmNode C O, Block CmmNode O O, CmmNode O C)
forall (n :: Extensibility -> Extensibility -> *).
Block n C C -> (n C O, Block n O O, n O C)
blockSplit CmmBlock
block'
nodes' :: [CmmNode O O]
nodes' = (CmmNode O O -> Bool) -> [CmmNode O O] -> [CmmNode O O]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (CmmNode O O -> Bool) -> CmmNode O O -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CmmNode O O -> Bool
forall (x :: Extensibility). CmmNode O x -> Bool
dont_care) (Block CmmNode O O -> [CmmNode O O]
forall (n :: Extensibility -> Extensibility -> *).
Block n O O -> [n O O]
blockToList Block CmmNode O O
m')
equal :: Bool
equal = (CmmNode O O -> CmmNode O O -> Bool)
-> [CmmNode O O] -> [CmmNode O O] -> Bool
forall a b. (a -> b -> Bool) -> [a] -> [b] -> Bool
eqListWith ((BlockId -> BlockId -> Bool) -> CmmNode O O -> CmmNode O O -> Bool
eqMiddleWith BlockId -> BlockId -> Bool
eqBid) [CmmNode O O]
nodes [CmmNode O O]
nodes' Bool -> Bool -> Bool
&&
(BlockId -> BlockId -> Bool) -> CmmNode O C -> CmmNode O C -> Bool
eqLastWith BlockId -> BlockId -> Bool
eqBid CmmNode O C
l CmmNode O C
l'
eqLastWith :: (BlockId -> BlockId -> Bool) -> CmmNode O C -> CmmNode O C -> Bool
eqLastWith :: (BlockId -> BlockId -> Bool) -> CmmNode O C -> CmmNode O C -> Bool
eqLastWith BlockId -> BlockId -> Bool
eqBid (CmmBranch BlockId
bid1) (CmmBranch BlockId
bid2) = BlockId -> BlockId -> Bool
eqBid BlockId
bid1 BlockId
bid2
eqLastWith BlockId -> BlockId -> Bool
eqBid (CmmCondBranch CmmExpr
c1 BlockId
t1 BlockId
f1 Maybe Bool
l1) (CmmCondBranch CmmExpr
c2 BlockId
t2 BlockId
f2 Maybe Bool
l2) =
CmmExpr
c1 CmmExpr -> CmmExpr -> Bool
forall a. Eq a => a -> a -> Bool
== CmmExpr
c2 Bool -> Bool -> Bool
&& Maybe Bool
l1 Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Bool
l2 Bool -> Bool -> Bool
&& BlockId -> BlockId -> Bool
eqBid BlockId
t1 BlockId
t2 Bool -> Bool -> Bool
&& BlockId -> BlockId -> Bool
eqBid BlockId
f1 BlockId
f2
eqLastWith BlockId -> BlockId -> Bool
eqBid (CmmCall CmmExpr
t1 Maybe BlockId
c1 [GlobalReg]
g1 Int
a1 Int
r1 Int
u1) (CmmCall CmmExpr
t2 Maybe BlockId
c2 [GlobalReg]
g2 Int
a2 Int
r2 Int
u2) =
CmmExpr
t1 CmmExpr -> CmmExpr -> Bool
forall a. Eq a => a -> a -> Bool
== CmmExpr
t2 Bool -> Bool -> Bool
&& (BlockId -> BlockId -> Bool)
-> Maybe BlockId -> Maybe BlockId -> Bool
forall a b. (a -> b -> Bool) -> Maybe a -> Maybe b -> Bool
eqMaybeWith BlockId -> BlockId -> Bool
eqBid Maybe BlockId
c1 Maybe BlockId
c2 Bool -> Bool -> Bool
&& Int
a1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
a2 Bool -> Bool -> Bool
&& Int
r1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
r2 Bool -> Bool -> Bool
&& Int
u1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
u2 Bool -> Bool -> Bool
&& [GlobalReg]
g1 [GlobalReg] -> [GlobalReg] -> Bool
forall a. Eq a => a -> a -> Bool
== [GlobalReg]
g2
eqLastWith BlockId -> BlockId -> Bool
eqBid (CmmSwitch CmmExpr
e1 SwitchTargets
ids1) (CmmSwitch CmmExpr
e2 SwitchTargets
ids2) =
CmmExpr
e1 CmmExpr -> CmmExpr -> Bool
forall a. Eq a => a -> a -> Bool
== CmmExpr
e2 Bool -> Bool -> Bool
&& (BlockId -> BlockId -> Bool)
-> SwitchTargets -> SwitchTargets -> Bool
eqSwitchTargetWith BlockId -> BlockId -> Bool
eqBid SwitchTargets
ids1 SwitchTargets
ids2
eqLastWith BlockId -> BlockId -> Bool
_ CmmNode O C
_ CmmNode O C
_ = Bool
False
eqMaybeWith :: (a -> b -> Bool) -> Maybe a -> Maybe b -> Bool
eqMaybeWith :: forall a b. (a -> b -> Bool) -> Maybe a -> Maybe b -> Bool
eqMaybeWith a -> b -> Bool
eltEq (Just a
e) (Just b
e') = a -> b -> Bool
eltEq a
e b
e'
eqMaybeWith a -> b -> Bool
_ Maybe a
Nothing Maybe b
Nothing = Bool
True
eqMaybeWith a -> b -> Bool
_ Maybe a
_ Maybe b
_ = Bool
False
eqListWith :: (a -> b -> Bool) -> [a] -> [b] -> Bool
eqListWith :: forall a b. (a -> b -> Bool) -> [a] -> [b] -> Bool
eqListWith a -> b -> Bool
f (a
a : [a]
as) (b
b : [b]
bs) = a -> b -> Bool
f a
a b
b Bool -> Bool -> Bool
&& (a -> b -> Bool) -> [a] -> [b] -> Bool
forall a b. (a -> b -> Bool) -> [a] -> [b] -> Bool
eqListWith a -> b -> Bool
f [a]
as [b]
bs
eqListWith a -> b -> Bool
_ [] [] = Bool
True
eqListWith a -> b -> Bool
_ [a]
_ [b]
_ = Bool
False
copyTicks :: LabelMap BlockId -> CmmGraph -> CmmGraph
copyTicks :: LabelMap BlockId -> CmmGraph -> CmmGraph
copyTicks LabelMap BlockId
env CmmGraph
g
| LabelMap BlockId -> Bool
forall (map :: * -> *) a. IsMap map => map a -> Bool
mapNull LabelMap BlockId
env = CmmGraph
g
| Bool
otherwise = BlockId -> LabelMap CmmBlock -> CmmGraph
ofBlockMap (CmmGraph -> BlockId
forall (n :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> BlockId
g_entry CmmGraph
g) (LabelMap CmmBlock -> CmmGraph) -> LabelMap CmmBlock -> CmmGraph
forall a b. (a -> b) -> a -> b
$ (CmmBlock -> CmmBlock) -> LabelMap CmmBlock -> LabelMap CmmBlock
forall (map :: * -> *) a b. IsMap map => (a -> b) -> map a -> map b
mapMap CmmBlock -> CmmBlock
copyTo LabelMap CmmBlock
blockMap
where
blockMap :: LabelMap CmmBlock
blockMap = CmmGraph -> LabelMap CmmBlock
toBlockMap CmmGraph
g
revEnv :: Map BlockId Key
revEnv = (Map BlockId Key -> KeyOf LabelMap -> BlockId -> Map BlockId Key)
-> Map BlockId Key -> LabelMap BlockId -> Map BlockId Key
forall (map :: * -> *) b a.
IsMap map =>
(b -> KeyOf map -> a -> b) -> b -> map a -> b
mapFoldlWithKey Map BlockId Key -> KeyOf LabelMap -> BlockId -> Map BlockId Key
forall {k} {a}. Ord k => Map k [a] -> a -> k -> Map k [a]
insertRev Map BlockId Key
forall k a. Map k a
M.empty LabelMap BlockId
env
insertRev :: Map k [a] -> a -> k -> Map k [a]
insertRev Map k [a]
m a
k k
x = ([a] -> [a] -> [a]) -> k -> [a] -> Map k [a] -> Map k [a]
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith (([a] -> [a]) -> [a] -> [a] -> [a]
forall a b. a -> b -> a
const (a
ka -> [a] -> [a]
forall a. a -> [a] -> [a]
:)) k
x [a
k] Map k [a]
m
copyTo :: CmmBlock -> CmmBlock
copyTo CmmBlock
block = case BlockId -> Map BlockId Key -> Maybe Key
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (CmmBlock -> BlockId
forall (thing :: Extensibility -> Extensibility -> *)
(x :: Extensibility).
NonLocal thing =>
thing C x -> BlockId
entryLabel CmmBlock
block) Map BlockId Key
revEnv of
Maybe Key
Nothing -> CmmBlock
block
Just Key
ls -> (CmmBlock -> CmmBlock -> CmmBlock)
-> CmmBlock -> DistinctBlocks -> CmmBlock
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr CmmBlock -> CmmBlock -> CmmBlock
forall {x :: Extensibility}.
CmmBlock -> Block CmmNode C x -> Block CmmNode C x
copy CmmBlock
block (DistinctBlocks -> CmmBlock) -> DistinctBlocks -> CmmBlock
forall a b. (a -> b) -> a -> b
$ (BlockId -> Maybe CmmBlock) -> Key -> DistinctBlocks
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((BlockId -> LabelMap CmmBlock -> Maybe CmmBlock)
-> LabelMap CmmBlock -> BlockId -> Maybe CmmBlock
forall a b c. (a -> b -> c) -> b -> a -> c
flip BlockId -> LabelMap CmmBlock -> Maybe CmmBlock
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup LabelMap CmmBlock
blockMap) Key
ls
copy :: CmmBlock -> Block CmmNode C x -> Block CmmNode C x
copy CmmBlock
from Block CmmNode C x
to =
let ticks :: [CmmTickish]
ticks = CmmBlock -> [CmmTickish]
blockTicks CmmBlock
from
CmmEntry BlockId
_ CmmTickScope
scp0 = CmmBlock -> CmmNode C O
forall (n :: Extensibility -> Extensibility -> *)
(x :: Extensibility).
Block n C x -> n C O
firstNode CmmBlock
from
(CmmEntry BlockId
lbl CmmTickScope
scp1, Block CmmNode O x
code) = Block CmmNode C x -> (CmmNode C O, Block CmmNode O x)
forall (n :: Extensibility -> Extensibility -> *)
(x :: Extensibility).
Block n C x -> (n C O, Block n O x)
blockSplitHead Block CmmNode C x
to
in BlockId -> CmmTickScope -> CmmNode C O
CmmEntry BlockId
lbl (CmmTickScope -> CmmTickScope -> CmmTickScope
combineTickScopes CmmTickScope
scp0 CmmTickScope
scp1) CmmNode C O -> Block CmmNode O x -> Block CmmNode C x
forall (n :: Extensibility -> Extensibility -> *)
(x :: Extensibility).
n C O -> Block n O x -> Block n C x
`blockJoinHead`
(CmmNode O O -> Block CmmNode O x -> Block CmmNode O x)
-> Block CmmNode O x -> [CmmNode O O] -> Block CmmNode O x
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr CmmNode O O -> Block CmmNode O x -> Block CmmNode O x
forall (n :: Extensibility -> Extensibility -> *)
(x :: Extensibility).
n O O -> Block n O x -> Block n O x
blockCons Block CmmNode O x
code ((CmmTickish -> CmmNode O O) -> [CmmTickish] -> [CmmNode O O]
forall a b. (a -> b) -> [a] -> [b]
map CmmTickish -> CmmNode O O
CmmTick [CmmTickish]
ticks)
groupByLabel :: [(Key, DistinctBlocks)] -> [(Key, [DistinctBlocks])]
groupByLabel :: [(Key, DistinctBlocks)] -> [(Key, [DistinctBlocks])]
groupByLabel =
ListMap
(GenMap LabelMap)
(Key (ListMap (GenMap LabelMap)), [DistinctBlocks])
-> [(Key (ListMap (GenMap LabelMap)), DistinctBlocks)]
-> [(Key (ListMap (GenMap LabelMap)), [DistinctBlocks])]
forall {m :: * -> *} {a}.
TrieMap m =>
m (Key m, [a]) -> [(Key m, a)] -> [(Key m, [a])]
go (ListMap (GenMap LabelMap) (Key, [DistinctBlocks])
forall (m :: * -> *) a. TrieMap m => m a
TM.emptyTM :: TM.ListMap (TM.GenMap LabelMap) (Key, [DistinctBlocks]))
where
go :: m (Key m, [a]) -> [(Key m, a)] -> [(Key m, [a])]
go !m (Key m, [a])
m [] = ((Key m, [a]) -> [(Key m, [a])] -> [(Key m, [a])])
-> m (Key m, [a]) -> [(Key m, [a])] -> [(Key m, [a])]
forall (m :: * -> *) a b.
TrieMap m =>
(a -> b -> b) -> m a -> b -> b
TM.foldTM (:) m (Key m, [a])
m []
go !m (Key m, [a])
m ((Key m
k,a
v) : [(Key m, a)]
entries) = m (Key m, [a]) -> [(Key m, a)] -> [(Key m, [a])]
go (Key m -> XT (Key m, [a]) -> m (Key m, [a]) -> m (Key m, [a])
forall (m :: * -> *) b. TrieMap m => Key m -> XT b -> m b -> m b
TM.alterTM Key m
k XT (Key m, [a])
adjust m (Key m, [a])
m) [(Key m, a)]
entries
where
adjust :: XT (Key m, [a])
adjust Maybe (Key m, [a])
Nothing = (Key m, [a]) -> Maybe (Key m, [a])
forall a. a -> Maybe a
Just (Key m
k,[a
v])
adjust (Just (Key m
_,[a]
vs)) = (Key m, [a]) -> Maybe (Key m, [a])
forall a. a -> Maybe a
Just (Key m
k,a
va -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
vs)
groupByInt :: (a -> Int) -> [a] -> [[a]]
groupByInt :: forall a. (a -> Int) -> [a] -> [[a]]
groupByInt a -> Int
f [a]
xs = UniqFM Int [a] -> [[a]]
forall key elt. UniqFM key elt -> [elt]
nonDetEltsUFM (UniqFM Int [a] -> [[a]]) -> UniqFM Int [a] -> [[a]]
forall a b. (a -> b) -> a -> b
$ (UniqFM Int [a] -> a -> UniqFM Int [a])
-> UniqFM Int [a] -> [a] -> UniqFM Int [a]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' UniqFM Int [a] -> a -> UniqFM Int [a]
go UniqFM Int [a]
forall key elt. UniqFM key elt
emptyUFM [a]
xs
where
go :: UniqFM Int [a] -> a -> UniqFM Int [a]
go UniqFM Int [a]
m a
x = (Maybe [a] -> Maybe [a]) -> UniqFM Int [a] -> Int -> UniqFM Int [a]
forall key elt.
Uniquable key =>
(Maybe elt -> Maybe elt) -> UniqFM key elt -> key -> UniqFM key elt
alterUFM Maybe [a] -> Maybe [a]
addEntry UniqFM Int [a]
m (a -> Int
f a
x)
where
addEntry :: Maybe [a] -> Maybe [a]
addEntry Maybe [a]
xs = [a] -> Maybe [a]
forall a. a -> Maybe a
Just ([a] -> Maybe [a]) -> [a] -> Maybe [a]
forall a b. (a -> b) -> a -> b
$! [a] -> ([a] -> [a]) -> Maybe [a] -> [a]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [a
x] (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:) Maybe [a]
xs