{-# LANGUAGE GADTs, BangPatterns, ScopedTypeVariables #-}

module CmmCommonBlockElim
  ( elimCommonBlocks
  )
where


import GhcPrelude hiding (iterate, succ, unzip, zip)

import BlockId
import Cmm
import CmmUtils
import CmmSwitch (eqSwitchTargetWith)
import CmmContFlowOpt
-- import PprCmm ()

import Hoopl.Block
import Hoopl.Graph
import Hoopl.Label
import Hoopl.Collections
import Data.Bits
import Data.Maybe (mapMaybe)
import qualified Data.List as List
import Data.Word
import qualified Data.Map as M
import Outputable
import qualified TrieMap as TM
import UniqFM
import Unique
import Control.Arrow (first, second)

-- -----------------------------------------------------------------------------
-- Eliminate common blocks

-- If two blocks are identical except for the label on the first node,
-- then we can eliminate one of the blocks. To ensure that the semantics
-- of the program are preserved, we have to rewrite each predecessor of the
-- eliminated block to proceed with the block we keep.

-- The algorithm iterates over the blocks in the graph,
-- checking whether it has seen another block that is equal modulo labels.
-- If so, then it adds an entry in a map indicating that the new block
-- is made redundant by the old block.
-- Otherwise, it is added to the useful blocks.

-- To avoid comparing every block with every other block repeatedly, we group
-- them by
--   * a hash of the block, ignoring labels (explained below)
--   * the list of outgoing labels
-- The hash is invariant under relabeling, so we only ever compare within
-- the same group of blocks.
--
-- The list of outgoing labels is updated as we merge blocks (that is why they
-- are not included in the hash, which we want to calculate only once).
--
-- All in all, two blocks should never be compared if they have different
-- hashes, and at most once otherwise. Previously, we were slower, and people
-- rightfully complained: #10397

-- TODO: Use optimization fuel
elimCommonBlocks :: CmmGraph -> CmmGraph
elimCommonBlocks :: CmmGraph -> CmmGraph
elimCommonBlocks g :: 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
     -- The order of blocks doesn't matter here. While we could use
     -- revPostorder which drops unreachable blocks this is done in
     -- ContFlowOpt already which runs before this pass. So we use
     -- toBlockList since it is faster.
     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 :: * -> * -> *) e. NonLocal thing => thing e C -> Key
successors CmmBlock
b, [CmmBlock
b]) | CmmBlock
b <- DistinctBlocks
bs] | DistinctBlocks
bs <- [DistinctBlocks]
groups]

-- Invariant: The blocks in the list are pairwise distinct
-- (so avoid comparing them again)
type DistinctBlocks = [CmmBlock]
type Key = [Label]
type Subst = LabelMap BlockId

-- The outer list groups by hash. We retain this grouping throughout.
iterate :: Subst -> [[(Key, DistinctBlocks)]] -> Subst
iterate :: LabelMap BlockId -> [[(Key, DistinctBlocks)]] -> LabelMap BlockId
iterate subst :: LabelMap BlockId
subst blocks :: [[(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)]]
    (new_substs :: LabelMap BlockId
new_substs, merged_blocks :: [[(Key, DistinctBlocks)]]
merged_blocks) = (LabelMap BlockId
 -> [(Key, [DistinctBlocks])]
 -> (LabelMap BlockId, [(Key, DistinctBlocks)]))
-> LabelMap BlockId
-> [[(Key, [DistinctBlocks])]]
-> (LabelMap BlockId, [[(Key, DistinctBlocks)]])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
List.mapAccumL ((LabelMap BlockId
 -> (Key, [DistinctBlocks])
 -> (LabelMap BlockId, (Key, DistinctBlocks)))
-> LabelMap BlockId
-> [(Key, [DistinctBlocks])]
-> (LabelMap BlockId, [(Key, DistinctBlocks)])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
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 (k :: Key
k,dbs :: [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
            (new_subst2 :: LabelMap BlockId
new_subst2, db :: 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

-- Combine two lists of blocks.
-- While they are internally distinct they can still share common blocks.
mergeBlocks :: Subst -> DistinctBlocks -> DistinctBlocks -> (Subst, DistinctBlocks)
mergeBlocks :: LabelMap BlockId
-> DistinctBlocks
-> DistinctBlocks
-> (LabelMap BlockId, DistinctBlocks)
mergeBlocks subst :: LabelMap BlockId
subst existing :: DistinctBlocks
existing new :: 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 (b :: CmmBlock
b:bs :: 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
        -- This block is a duplicate. Drop it, and add it to the substitution
        Just b' :: 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 :: * -> * -> *) x.
NonLocal thing =>
thing C x -> BlockId
entryLabel CmmBlock
b) (CmmBlock -> BlockId
forall (thing :: * -> * -> *) x.
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
        -- This block is not a duplicate, keep it.
        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 _ [] = String -> SDoc -> (LabelMap BlockId, DistinctBlocks)
forall a. HasCallStack => String -> SDoc -> a
pprPanic "mergeBlockList" SDoc
empty
mergeBlockList subst :: LabelMap BlockId
subst (b :: DistinctBlocks
b:bs :: [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 b :: DistinctBlocks
b [] = (LabelMap BlockId
new_subst1, DistinctBlocks
b)
    go !LabelMap BlockId
new_subst1 b1 :: DistinctBlocks
b1 (b2 :: DistinctBlocks
b2:bs :: [DistinctBlocks]
bs) = LabelMap BlockId
-> DistinctBlocks
-> [DistinctBlocks]
-> (LabelMap BlockId, DistinctBlocks)
go LabelMap BlockId
new_subst DistinctBlocks
b [DistinctBlocks]
bs
      where
        (new_subst2 :: LabelMap BlockId
new_subst2, b :: 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


-- -----------------------------------------------------------------------------
-- Hashing and equality on blocks

-- Below here is mostly boilerplate: hashing blocks ignoring labels,
-- and comparing blocks modulo a label mapping.

-- To speed up comparisons, we hash each basic block modulo jump labels.
-- The hashing is a bit arbitrary (the numbers are completely arbitrary),
-- but it should be fast and good enough.

-- We want to get as many small buckets as possible, as comparing blocks is
-- expensive. So include as much as possible in the hash. Ideally everything
-- that is compared with (==) in eqBlockBodyWith.

type HashCode = Int

hash_block :: CmmBlock -> HashCode
hash_block :: CmmBlock -> Int
hash_block 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)
-> CmmBlock
-> IndexedCO C Word32 Word32
-> IndexedCO C Word32 Word32
forall (n :: * -> * -> *) a b c.
(n C O -> b -> c, n O O -> b -> b, n O C -> a -> b)
-> forall e x. 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. CmmNode O x -> Word32 -> Word32
hash_mid, CmmNode O C -> Word32 -> Word32
forall x. CmmNode O x -> Word32 -> Word32
hash_lst) CmmBlock
block (0 :: Word32) Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. (0x7fffffff :: Word32))
  -- UniqFM doesn't like negative Ints
  where hash_fst :: p -> p -> p
hash_fst _ h :: p
h = p
h
        hash_mid :: CmmNode O x -> Word32 -> Word32
hash_mid m :: CmmNode O x
m h :: Word32
h = CmmNode O x -> Word32
forall x. 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` 1
        hash_lst :: CmmNode O x -> Word32 -> Word32
hash_lst m :: CmmNode O x
m h :: Word32
h = CmmNode O x -> Word32
forall x. 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` 1

        hash_node :: CmmNode O x -> Word32
        hash_node :: CmmNode O x -> Word32
hash_node n :: CmmNode O x
n | CmmNode O x -> Bool
forall x. CmmNode O x -> Bool
dont_care CmmNode O x
n = 0 -- don't care
        hash_node (CmmAssign r :: CmmReg
r e :: 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 e :: CmmExpr
e 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 t :: ForeignTarget
t _ as :: [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 _) = 23 -- NB. ignore the label
        hash_node (CmmCondBranch p :: CmmExpr
p _ _ _) = CmmExpr -> Word32
hash_e CmmExpr
p
        hash_node (CmmCall e :: CmmExpr
e _ _ _ _ _) = CmmExpr -> Word32
hash_e CmmExpr
e
        hash_node (CmmForeignCall t :: ForeignTarget
t _ _ _ _ _ _) = ForeignTarget -> Word32
hash_tgt ForeignTarget
t
        hash_node (CmmSwitch e :: CmmExpr
e _) = CmmExpr -> Word32
hash_e CmmExpr
e
        hash_node _ = String -> Word32
forall a. HasCallStack => String -> a
error "hash_node: unknown Cmm node!"

        hash_reg :: CmmReg -> Word32
        hash_reg :: CmmReg -> Word32
hash_reg   (CmmLocal localReg :: LocalReg
localReg) = LocalReg -> Word32
forall a. Uniquable a => a -> Word32
hash_unique LocalReg
localReg -- important for performance, see #10397
        hash_reg   (CmmGlobal _)    = 19

        hash_e :: CmmExpr -> Word32
        hash_e :: CmmExpr -> Word32
hash_e (CmmLit l :: CmmLit
l) = CmmLit -> Word32
hash_lit CmmLit
l
        hash_e (CmmLoad e :: CmmExpr
e _) = 67 Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ CmmExpr -> Word32
hash_e CmmExpr
e
        hash_e (CmmReg r :: CmmReg
r) = CmmReg -> Word32
hash_reg CmmReg
r
        hash_e (CmmMachOp _ es :: [CmmExpr]
es) = (CmmExpr -> Word32) -> [CmmExpr] -> Word32
forall (t :: * -> *) t.
Foldable t =>
(t -> Word32) -> t t -> Word32
hash_list CmmExpr -> Word32
hash_e [CmmExpr]
es -- pessimal - no operator check
        hash_e (CmmRegOff r :: CmmReg
r i :: 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 _ _) = 13

        hash_lit :: CmmLit -> Word32
        hash_lit :: CmmLit -> Word32
hash_lit (CmmInt i :: Integer
i _) = Integer -> Word32
forall a. Num a => Integer -> a
fromInteger Integer
i
        hash_lit (CmmFloat r :: Rational
r _) = Rational -> Word32
forall a b. (RealFrac a, Integral b) => a -> b
truncate Rational
r
        hash_lit (CmmVec ls :: [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 _) = 119 -- ugh
        hash_lit (CmmLabelOff _ i :: Int
i) = Int -> Word32
cvt (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$ 199 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i
        hash_lit (CmmLabelDiffOff _ _ i :: Int
i _) = Int -> Word32
cvt (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$ 299 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i
        hash_lit (CmmBlock _) = 191 -- ugh
        hash_lit (CmmLit
CmmHighStackMark) = Int -> Word32
cvt 313

        hash_tgt :: ForeignTarget -> Word32
hash_tgt (ForeignTarget e :: CmmExpr
e _) = CmmExpr -> Word32
hash_e CmmExpr
e
        hash_tgt (PrimTarget _) = 31 -- lots of these

        hash_list :: (t -> Word32) -> t t -> Word32
hash_list f :: t -> Word32
f = (Word32 -> t -> Word32) -> Word32 -> t t -> Word32
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\z :: Word32
z x :: t
x -> t -> Word32
f t
x Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
z) (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 :: 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

-- | Ignore these node types for equality
dont_care :: CmmNode O x -> Bool
dont_care :: CmmNode O x -> Bool
dont_care CmmComment {}  = Bool
True
dont_care CmmTick {}     = Bool
True
dont_care CmmUnwind {}   = Bool
True
dont_care _other :: CmmNode O x
_other         = Bool
False

-- Utilities: equality and substitution on the graph.

-- Given a map ``subst'' from BlockID -> BlockID, we define equality.
eqBid :: LabelMap BlockId -> BlockId -> BlockId -> Bool
eqBid :: LabelMap BlockId -> BlockId -> BlockId -> Bool
eqBid subst :: LabelMap BlockId
subst bid :: BlockId
bid 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 subst :: LabelMap BlockId
subst bid :: 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 bid :: BlockId
bid  -> LabelMap BlockId -> BlockId -> BlockId
lookupBid LabelMap BlockId
subst BlockId
bid
                        Nothing -> BlockId
bid

-- Middle nodes and expressions can contain BlockIds, in particular in
-- CmmStackSlot and CmmBlock, so we have to use a special equality for
-- these.
--
eqMiddleWith :: (BlockId -> BlockId -> Bool)
             -> CmmNode O O -> CmmNode O O -> Bool
eqMiddleWith :: (BlockId -> BlockId -> Bool) -> CmmNode O O -> CmmNode O O -> Bool
eqMiddleWith eqBid :: BlockId -> BlockId -> Bool
eqBid (CmmAssign r1 :: CmmReg
r1 e1 :: CmmExpr
e1) (CmmAssign r2 :: CmmReg
r2 e2 :: 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 eqBid :: BlockId -> BlockId -> Bool
eqBid (CmmStore l1 :: CmmExpr
l1 r1 :: CmmExpr
r1) (CmmStore l2 :: CmmExpr
l2 r2 :: 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 eqBid :: BlockId -> BlockId -> Bool
eqBid (CmmUnsafeForeignCall t1 :: ForeignTarget
t1 r1 :: [LocalReg]
r1 a1 :: [CmmExpr]
a1)
                   (CmmUnsafeForeignCall t2 :: ForeignTarget
t2 r2 :: [LocalReg]
r2 a2 :: [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 _ _ _ = Bool
False

eqExprWith :: (BlockId -> BlockId -> Bool)
           -> CmmExpr -> CmmExpr -> Bool
eqExprWith :: (BlockId -> BlockId -> Bool) -> CmmExpr -> CmmExpr -> Bool
eqExprWith eqBid :: BlockId -> BlockId -> Bool
eqBid = CmmExpr -> CmmExpr -> Bool
eq
 where
  CmmLit l1 :: CmmLit
l1          eq :: CmmExpr -> CmmExpr -> Bool
`eq` CmmLit l2 :: CmmLit
l2          = CmmLit -> CmmLit -> Bool
eqLit CmmLit
l1 CmmLit
l2
  CmmLoad e1 :: CmmExpr
e1 _       `eq` CmmLoad e2 :: CmmExpr
e2 _       = CmmExpr
e1 CmmExpr -> CmmExpr -> Bool
`eq` CmmExpr
e2
  CmmReg r1 :: CmmReg
r1          `eq` CmmReg r2 :: CmmReg
r2          = CmmReg
r1CmmReg -> CmmReg -> Bool
forall a. Eq a => a -> a -> Bool
==CmmReg
r2
  CmmRegOff r1 :: CmmReg
r1 i1 :: Int
i1    `eq` CmmRegOff r2 :: CmmReg
r2 i2 :: 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 op1 :: MachOp
op1 es1 :: [CmmExpr]
es1  `eq` CmmMachOp op2 :: MachOp
op2 es2 :: [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 a1 :: Area
a1 i1 :: Int
i1 `eq` CmmStackSlot a2 :: Area
a2 i2 :: 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
  _e1 :: CmmExpr
_e1                `eq` _e2 :: CmmExpr
_e2                = Bool
False

  xs :: [CmmExpr]
xs eqs :: [CmmExpr] -> [CmmExpr] -> Bool
`eqs` ys :: [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 id1 :: BlockId
id1) (CmmBlock id2 :: BlockId
id2) = BlockId -> BlockId -> Bool
eqBid BlockId
id1 BlockId
id2
  eqLit l1 :: CmmLit
l1 l2 :: CmmLit
l2 = CmmLit
l1 CmmLit -> CmmLit -> Bool
forall a. Eq a => a -> a -> Bool
== CmmLit
l2

  eqArea :: Area -> Area -> Bool
eqArea Old Old = Bool
True
  eqArea (Young id1 :: BlockId
id1) (Young id2 :: BlockId
id2) = BlockId -> BlockId -> Bool
eqBid BlockId
id1 BlockId
id2
  eqArea _ _ = Bool
False

-- Equality on the body of a block, modulo a function mapping block
-- IDs to block IDs.
eqBlockBodyWith :: (BlockId -> BlockId -> Bool) -> CmmBlock -> CmmBlock -> Bool
eqBlockBodyWith :: (BlockId -> BlockId -> Bool) -> CmmBlock -> CmmBlock -> Bool
eqBlockBodyWith eqBid :: BlockId -> BlockId -> Bool
eqBid block :: CmmBlock
block block' :: CmmBlock
block'
  {-
  | equal     = pprTrace "equal" (vcat [ppr block, ppr block']) True
  | otherwise = pprTrace "not equal" (vcat [ppr block, ppr block']) False
  -}
  = Bool
equal
  where (_,m :: Block CmmNode O O
m,l :: CmmNode O C
l)   = CmmBlock -> (CmmNode C O, Block CmmNode O O, CmmNode O C)
forall (n :: * -> * -> *).
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. CmmNode O x -> Bool
dont_care) (Block CmmNode O O -> [CmmNode O O]
forall (n :: * -> * -> *). Block n O O -> [n O O]
blockToList Block CmmNode O O
m)
        (_,m' :: Block CmmNode O O
m',l' :: CmmNode O C
l') = CmmBlock -> (CmmNode C O, Block CmmNode O O, CmmNode O C)
forall (n :: * -> * -> *).
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. CmmNode O x -> Bool
dont_care) (Block CmmNode O O -> [CmmNode O O]
forall (n :: * -> * -> *). 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 eqBid :: BlockId -> BlockId -> Bool
eqBid (CmmBranch bid1 :: BlockId
bid1) (CmmBranch bid2 :: BlockId
bid2) = BlockId -> BlockId -> Bool
eqBid BlockId
bid1 BlockId
bid2
eqLastWith eqBid :: BlockId -> BlockId -> Bool
eqBid (CmmCondBranch c1 :: CmmExpr
c1 t1 :: BlockId
t1 f1 :: BlockId
f1 l1 :: Maybe Bool
l1) (CmmCondBranch c2 :: CmmExpr
c2 t2 :: BlockId
t2 f2 :: BlockId
f2 l2 :: 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 eqBid :: BlockId -> BlockId -> Bool
eqBid (CmmCall t1 :: CmmExpr
t1 c1 :: Maybe BlockId
c1 g1 :: [GlobalReg]
g1 a1 :: Int
a1 r1 :: Int
r1 u1 :: Int
u1) (CmmCall t2 :: CmmExpr
t2 c2 :: Maybe BlockId
c2 g2 :: [GlobalReg]
g2 a2 :: Int
a2 r2 :: Int
r2 u2 :: 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 eqBid :: BlockId -> BlockId -> Bool
eqBid (CmmSwitch e1 :: CmmExpr
e1 ids1 :: SwitchTargets
ids1) (CmmSwitch e2 :: CmmExpr
e2 ids2 :: 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 _ _ _ = Bool
False

eqMaybeWith :: (a -> b -> Bool) -> Maybe a -> Maybe b -> Bool
eqMaybeWith :: (a -> b -> Bool) -> Maybe a -> Maybe b -> Bool
eqMaybeWith eltEq :: a -> b -> Bool
eltEq (Just e :: a
e) (Just e' :: b
e') = a -> b -> Bool
eltEq a
e b
e'
eqMaybeWith _ Nothing Nothing = Bool
True
eqMaybeWith _ _ _ = Bool
False

eqListWith :: (a -> b -> Bool) -> [a] -> [b] -> Bool
eqListWith :: (a -> b -> Bool) -> [a] -> [b] -> Bool
eqListWith f :: a -> b -> Bool
f (a :: a
a : as :: [a]
as) (b :: b
b : bs :: [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 _ []       []       = Bool
True
eqListWith _ _        _        = Bool
False

-- | Given a block map, ensure that all "target" blocks are covered by
-- the same ticks as the respective "source" blocks. This not only
-- means copying ticks, but also adjusting tick scopes where
-- necessary.
copyTicks :: LabelMap BlockId -> CmmGraph -> CmmGraph
copyTicks :: LabelMap BlockId -> CmmGraph -> CmmGraph
copyTicks env :: LabelMap BlockId
env g :: 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 :: * -> * -> *). 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 -- Reverse block merge map
        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 m :: Map k [a]
m k :: a
k x :: 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
        -- Copy ticks and scopes into the given block
        copyTo :: CmmBlock -> CmmBlock
copyTo block :: 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 :: * -> * -> *) x.
NonLocal thing =>
thing C x -> BlockId
entryLabel CmmBlock
block) Map BlockId Key
revEnv of
          Nothing -> CmmBlock
block
          Just ls :: 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. 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 from :: CmmBlock
from to :: Block CmmNode C x
to =
          let ticks :: [CmmTickish]
ticks = CmmBlock -> [CmmTickish]
blockTicks CmmBlock
from
              CmmEntry  _   scp0        = CmmBlock -> CmmNode C O
forall (n :: * -> * -> *) x. Block n C x -> n C O
firstNode CmmBlock
from
              (CmmEntry lbl scp1, code) = Block CmmNode C x -> (CmmNode C O, Block CmmNode O x)
forall (n :: * -> * -> *) x. 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 :: * -> * -> *) x. 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 :: * -> * -> *) x. 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)

-- Group by [Label]
-- See Note [Compressed TrieMap] in coreSyn/TrieMap about the usage of GenMap.
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 ((k :: Key m
k,v :: a
v) : entries :: [(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 --k' = map (getKey . getUnique) k
              adjust :: XT (Key m, [a])
adjust Nothing       = (Key m, [a]) -> Maybe (Key m, [a])
forall a. a -> Maybe a
Just (Key m
k,[a
v])
              adjust (Just (_,vs :: [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 :: (a -> Int) -> [a] -> [[a]]
groupByInt f :: a -> Int
f xs :: [a]
xs = UniqFM [a] -> [[a]]
forall elt. UniqFM elt -> [elt]
nonDetEltsUFM (UniqFM [a] -> [[a]]) -> UniqFM [a] -> [[a]]
forall a b. (a -> b) -> a -> b
$ (UniqFM [a] -> a -> UniqFM [a]) -> UniqFM [a] -> [a] -> UniqFM [a]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' UniqFM [a] -> a -> UniqFM [a]
go UniqFM [a]
forall elt. UniqFM elt
emptyUFM [a]
xs
   -- See Note [Unique Determinism and code generation]
  where
    go :: UniqFM [a] -> a -> UniqFM [a]
go m :: UniqFM [a]
m x :: a
x = (Maybe [a] -> Maybe [a]) -> UniqFM [a] -> Int -> UniqFM [a]
forall key elt.
Uniquable key =>
(Maybe elt -> Maybe elt) -> UniqFM elt -> key -> UniqFM elt
alterUFM Maybe [a] -> Maybe [a]
addEntry UniqFM [a]
m (a -> Int
f a
x)
      where
        addEntry :: Maybe [a] -> Maybe [a]
addEntry xs :: 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