{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE MultiParamTypeClasses #-}

{-|
Module      : GHC.Cmm.Reducibility
Description : Tell if a `CmmGraph` is reducible, or make it so

Test a Cmm control-flow graph for reducibility.  And provide a
function that, when given an arbitrary control-flow graph, returns an
equivalent, reducible control-flow graph.  The equivalent graph is
obtained by "splitting" (copying) nodes of the original graph.
The resulting equivalent graph has the same dynamic behavior as the
original, but it is larger.

Documentation uses the language of control-flow analysis, in which a
basic block is called a "node."  These "nodes" are `CmmBlock`s or
equivalent; they have nothing to do with a `CmmNode`.

For more on reducibility and related analyses and algorithms, see
Note [Reducibility resources]
-}

module GHC.Cmm.Reducibility
  ( Reducibility(..)
  , reducibility

  , asReducible
  )
where

import GHC.Prelude hiding (splitAt, succ)

import Control.Monad
import Data.List (nub)
import Data.Maybe
import Data.Semigroup
import qualified Data.Sequence as Seq

import GHC.Cmm
import GHC.Cmm.BlockId
import GHC.Cmm.Dataflow
import GHC.Cmm.Dataflow.Block
import GHC.Cmm.Dominators
import GHC.Cmm.Dataflow.Graph hiding (addBlock)
import GHC.Cmm.Dataflow.Label
import GHC.Data.Graph.Collapse
import GHC.Data.Graph.Inductive.Graph
import GHC.Data.Graph.Inductive.PatriciaTree
import GHC.Types.Unique.DSM
import GHC.Utils.Panic

-- | Represents the result of a reducibility analysis.
data Reducibility = Reducible | Irreducible
  deriving (Reducibility -> Reducibility -> Bool
(Reducibility -> Reducibility -> Bool)
-> (Reducibility -> Reducibility -> Bool) -> Eq Reducibility
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Reducibility -> Reducibility -> Bool
== :: Reducibility -> Reducibility -> Bool
$c/= :: Reducibility -> Reducibility -> Bool
/= :: Reducibility -> Reducibility -> Bool
Eq, Int -> Reducibility -> ShowS
[Reducibility] -> ShowS
Reducibility -> String
(Int -> Reducibility -> ShowS)
-> (Reducibility -> String)
-> ([Reducibility] -> ShowS)
-> Show Reducibility
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Reducibility -> ShowS
showsPrec :: Int -> Reducibility -> ShowS
$cshow :: Reducibility -> String
show :: Reducibility -> String
$cshowList :: [Reducibility] -> ShowS
showList :: [Reducibility] -> ShowS
Show)

-- | Given a graph, say whether the graph is reducible.  The graph must
-- be bundled with a dominator analysis and a reverse postorder
-- numbering, as these results are needed to perform the test.

reducibility :: NonLocal node
             => GraphWithDominators node
             -> Reducibility
reducibility :: forall (node :: Extensibility -> Extensibility -> *).
NonLocal node =>
GraphWithDominators node -> Reducibility
reducibility GraphWithDominators node
gwd =
    if (Block node C C -> Bool) -> LabelMap (Block node C C) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Block node C C -> Bool
goodBlock LabelMap (Block node C C)
blockmap then Reducibility
Reducible else Reducibility
Irreducible
  where goodBlock :: Block node C C -> Bool
goodBlock Block node C C
b = (Label -> Bool) -> [Label] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Label -> Label -> Bool
goodEdge (Block node C C -> Label
forall (x :: Extensibility). Block node C x -> Label
forall (thing :: Extensibility -> Extensibility -> *)
       (x :: Extensibility).
NonLocal thing =>
thing C x -> Label
entryLabel Block node C C
b)) (Block node C C -> [Label]
forall (e :: Extensibility). Block node e C -> [Label]
forall (thing :: Extensibility -> Extensibility -> *)
       (e :: Extensibility).
NonLocal thing =>
thing e C -> [Label]
successors Block node C C
b)
        goodEdge :: Label -> Label -> Bool
goodEdge Label
from Label
to = Label -> RPNum
rpnum Label
to RPNum -> RPNum -> Bool
forall a. Ord a => a -> a -> Bool
> Label -> RPNum
rpnum Label
from Bool -> Bool -> Bool
|| Label
to Label -> Label -> Bool
`dominates` Label
from
        rpnum :: Label -> RPNum
rpnum = GraphWithDominators node -> Label -> RPNum
forall (node :: Extensibility -> Extensibility -> *).
HasDebugCallStack =>
GraphWithDominators node -> Label -> RPNum
gwdRPNumber GraphWithDominators node
gwd
        blockmap :: LabelMap (Block node C C)
blockmap = GenCmmGraph node -> LabelMap (Block node C C)
forall (n :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> LabelMap (Block n C C)
graphMap (GenCmmGraph node -> LabelMap (Block node C C))
-> GenCmmGraph node -> LabelMap (Block node C C)
forall a b. (a -> b) -> a -> b
$ GraphWithDominators node -> GenCmmGraph node
forall (node :: Extensibility -> Extensibility -> *).
GraphWithDominators node -> GenCmmGraph node
gwd_graph GraphWithDominators node
gwd
        dominators :: Label -> DominatorSet
dominators = GraphWithDominators node -> Label -> DominatorSet
forall (node :: Extensibility -> Extensibility -> *).
HasDebugCallStack =>
GraphWithDominators node -> Label -> DominatorSet
gwdDominatorsOf GraphWithDominators node
gwd
        dominates :: Label -> Label -> Bool
dominates Label
lbl Label
blockname =
            Label
lbl Label -> Label -> Bool
forall a. Eq a => a -> a -> Bool
== Label
blockname Bool -> Bool -> Bool
|| Label -> DominatorSet -> Bool
dominatorsMember Label
lbl (Label -> DominatorSet
dominators Label
blockname)

-- | Given a graph, return an equivalent reducible graph, by
-- "splitting" (copying) nodes if necessary.  The input
-- graph must be bundled with a dominator analysis and a reverse
-- postorder numbering.  The computation is monadic because when a
-- node is split, the new copy needs a fresh label.
--
-- Use this function whenever a downstream algorithm needs a reducible
-- control-flow graph.

asReducible :: GraphWithDominators CmmNode
            -> UniqDSM (GraphWithDominators CmmNode)
asReducible :: GraphWithDominators CmmNode
-> UniqDSM (GraphWithDominators CmmNode)
asReducible GraphWithDominators CmmNode
gwd = case GraphWithDominators CmmNode -> Reducibility
forall (node :: Extensibility -> Extensibility -> *).
NonLocal node =>
GraphWithDominators node -> Reducibility
reducibility GraphWithDominators CmmNode
gwd of
                    Reducibility
Reducible -> GraphWithDominators CmmNode
-> UniqDSM (GraphWithDominators CmmNode)
forall a. a -> UniqDSM a
forall (m :: * -> *) a. Monad m => a -> m a
return GraphWithDominators CmmNode
gwd
                    Reducibility
Irreducible -> GraphWithDominators CmmNode -> GraphWithDominators CmmNode
assertReducible (GraphWithDominators CmmNode -> GraphWithDominators CmmNode)
-> UniqDSM (GraphWithDominators CmmNode)
-> UniqDSM (GraphWithDominators CmmNode)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GraphWithDominators CmmNode
-> UniqDSM (GraphWithDominators CmmNode)
nodeSplit GraphWithDominators CmmNode
gwd

assertReducible :: GraphWithDominators CmmNode -> GraphWithDominators CmmNode
assertReducible :: GraphWithDominators CmmNode -> GraphWithDominators CmmNode
assertReducible GraphWithDominators CmmNode
gwd = case GraphWithDominators CmmNode -> Reducibility
forall (node :: Extensibility -> Extensibility -> *).
NonLocal node =>
GraphWithDominators node -> Reducibility
reducibility GraphWithDominators CmmNode
gwd of
                        Reducibility
Reducible -> GraphWithDominators CmmNode
gwd
                        Reducibility
Irreducible -> String -> GraphWithDominators CmmNode
forall a. HasCallStack => String -> a
panic String
"result not reducible"

----------------------------------------------------------------

-- | Split one or more nodes of the given graph, which must be
-- irreducible.

nodeSplit :: GraphWithDominators CmmNode
          -> UniqDSM (GraphWithDominators CmmNode)
nodeSplit :: GraphWithDominators CmmNode
-> UniqDSM (GraphWithDominators CmmNode)
nodeSplit GraphWithDominators CmmNode
gwd =
    GenCmmGraph CmmNode -> GraphWithDominators CmmNode
forall (node :: Extensibility -> Extensibility -> *).
(NonLocal node, HasDebugCallStack) =>
GenCmmGraph node -> GraphWithDominators node
graphWithDominators (GenCmmGraph CmmNode -> GraphWithDominators CmmNode)
-> (Gr CmmSuper () -> GenCmmGraph CmmNode)
-> Gr CmmSuper ()
-> GraphWithDominators CmmNode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Label -> Gr CmmSuper () -> GenCmmGraph CmmNode
inflate (GenCmmGraph CmmNode -> Label
forall (s :: * -> *) (n :: Extensibility -> Extensibility -> *).
GenGenCmmGraph s n -> Label
g_entry GenCmmGraph CmmNode
g) (Gr CmmSuper () -> GraphWithDominators CmmNode)
-> UniqDSM (Gr CmmSuper ())
-> UniqDSM (GraphWithDominators CmmNode)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NullCollapseViz (Gr CmmSuper ()) -> UniqDSM (Gr CmmSuper ())
forall a. NullCollapseViz a -> UniqDSM a
runNullCollapse NullCollapseViz (Gr CmmSuper ())
collapsed
  where g :: GenCmmGraph CmmNode
g = GraphWithDominators CmmNode -> GenCmmGraph CmmNode
forall (node :: Extensibility -> Extensibility -> *).
GraphWithDominators node -> GenCmmGraph node
gwd_graph GraphWithDominators CmmNode
gwd
        collapsed :: NullCollapseViz (Gr CmmSuper ())
        collapsed :: NullCollapseViz (Gr CmmSuper ())
collapsed = Gr CmmSuper () -> NullCollapseViz (Gr CmmSuper ())
forall (gr :: * -> * -> *) s (m :: * -> *).
(DynGraph gr, Supernode s m, VizCollapseMonad m gr s) =>
gr s () -> m (gr s ())
collapseInductiveGraph (GenCmmGraph CmmNode -> Gr CmmSuper ()
cgraphOfCmm GenCmmGraph CmmNode
g)

type CGraph = Gr CmmSuper ()

-- | Turn a collapsed supernode back into a control-flow graph
inflate :: Label -> CGraph -> CmmGraph
inflate :: Label -> Gr CmmSuper () -> GenCmmGraph CmmNode
inflate Label
entry Gr CmmSuper ()
cg = Label -> Graph' LabelMap Block CmmNode C C -> GenCmmGraph CmmNode
forall (s :: * -> *) (n :: Extensibility -> Extensibility -> *).
Label -> Graph' s Block n C C -> GenGenCmmGraph s n
CmmGraph Label
entry Graph' LabelMap Block CmmNode C C
graph
  where graph :: Graph' LabelMap Block CmmNode C C
graph = MaybeO C (Block CmmNode O C)
-> Body' LabelMap Block CmmNode
-> MaybeO C (Block CmmNode C O)
-> Graph' LabelMap Block CmmNode C C
forall (e :: Extensibility)
       (block :: (Extensibility -> Extensibility -> *)
                 -> Extensibility -> Extensibility -> *)
       (n :: Extensibility -> Extensibility -> *) (s :: * -> *)
       (x :: Extensibility).
MaybeO e (block n O C)
-> Body' s block n
-> MaybeO x (block n C O)
-> Graph' s block n e x
GMany MaybeO C (Block CmmNode O C)
forall t. MaybeO C t
NothingO Body' LabelMap Block CmmNode
body MaybeO C (Block CmmNode C O)
forall t. MaybeO C t
NothingO
        body :: LabelMap CmmBlock
        body :: Body' LabelMap Block CmmNode
body = (Body' LabelMap Block CmmNode
 -> CmmBlock -> Body' LabelMap Block CmmNode)
-> Body' LabelMap Block CmmNode
-> Seq CmmBlock
-> Body' LabelMap Block CmmNode
forall b a. (b -> a -> b) -> b -> Seq a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Body' LabelMap Block CmmNode
map CmmBlock
block -> Label
-> CmmBlock
-> Body' LabelMap Block CmmNode
-> Body' LabelMap Block CmmNode
forall v. Label -> v -> LabelMap v -> LabelMap v
mapInsert (CmmBlock -> Label
forall (x :: Extensibility). Block CmmNode C x -> Label
forall (thing :: Extensibility -> Extensibility -> *)
       (x :: Extensibility).
NonLocal thing =>
thing C x -> Label
entryLabel CmmBlock
block) CmmBlock
block Body' LabelMap Block CmmNode
map) Body' LabelMap Block CmmNode
forall v. LabelMap v
mapEmpty (Seq CmmBlock -> Body' LabelMap Block CmmNode)
-> Seq CmmBlock -> Body' LabelMap Block CmmNode
forall a b. (a -> b) -> a -> b
$
               CmmSuper -> Seq CmmBlock
blocks CmmSuper
super
        super :: CmmSuper
super = case Gr CmmSuper () -> [LNode CmmSuper]
forall a b. Gr a b -> [LNode a]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LNode a]
labNodes Gr CmmSuper ()
cg of
                  [(Int
_, CmmSuper
s)] -> CmmSuper
s
                  [LNode CmmSuper]
_ -> String -> CmmSuper
forall a. HasCallStack => String -> a
panic String
"graph given to `inflate` is not singleton"


-- | Convert a `CmmGraph` into an inductive graph.
-- (The function coalesces duplicate edges into a single edge.)
cgraphOfCmm :: CmmGraph -> CGraph
cgraphOfCmm :: GenCmmGraph CmmNode -> Gr CmmSuper ()
cgraphOfCmm GenCmmGraph CmmNode
g = (Gr CmmSuper () -> (Int, CmmBlock) -> Gr CmmSuper ())
-> Gr CmmSuper () -> [(Int, CmmBlock)] -> Gr CmmSuper ()
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Gr CmmSuper () -> (Int, CmmBlock) -> Gr CmmSuper ()
addSuccEdges ([LNode CmmSuper] -> [LEdge ()] -> Gr CmmSuper ()
forall a b. [LNode a] -> [LEdge b] -> Gr a b
forall (gr :: * -> * -> *) a b.
Graph gr =>
[LNode a] -> [LEdge b] -> gr a b
mkGraph [LNode CmmSuper]
cnodes []) [(Int, CmmBlock)]
blocks
   where blocks :: [(Int, CmmBlock)]
blocks = [Int] -> [CmmBlock] -> [(Int, CmmBlock)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] ([CmmBlock] -> [(Int, CmmBlock)])
-> [CmmBlock] -> [(Int, CmmBlock)]
forall a b. (a -> b) -> a -> b
$ Body' LabelMap Block CmmNode -> Label -> [CmmBlock]
forall (block :: Extensibility -> Extensibility -> *).
NonLocal block =>
LabelMap (block C C) -> Label -> [block C C]
revPostorderFrom (GenCmmGraph CmmNode -> Body' LabelMap Block CmmNode
forall (n :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> LabelMap (Block n C C)
graphMap GenCmmGraph CmmNode
g) (GenCmmGraph CmmNode -> Label
forall (s :: * -> *) (n :: Extensibility -> Extensibility -> *).
GenGenCmmGraph s n -> Label
g_entry GenCmmGraph CmmNode
g)
         cnodes :: [LNode CmmSuper]
cnodes = [(Int
k, CmmBlock -> CmmSuper
super CmmBlock
block) | (Int
k, CmmBlock
block) <- [(Int, CmmBlock)]
blocks]
          where super :: CmmBlock -> CmmSuper
super CmmBlock
block = Label -> Seq CmmBlock -> CmmSuper
Nodes (CmmBlock -> Label
forall (x :: Extensibility). Block CmmNode C x -> Label
forall (thing :: Extensibility -> Extensibility -> *)
       (x :: Extensibility).
NonLocal thing =>
thing C x -> Label
entryLabel CmmBlock
block) (CmmBlock -> Seq CmmBlock
forall a. a -> Seq a
Seq.singleton CmmBlock
block)
         labelNumber :: Label -> Int
labelNumber = \Label
lbl -> Maybe Int -> Int
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ Label -> LabelMap Int -> Maybe Int
forall a. Label -> LabelMap a -> Maybe a
mapLookup Label
lbl LabelMap Int
numbers
             where numbers :: LabelMap Int
                   numbers :: LabelMap Int
numbers = [(Label, Int)] -> LabelMap Int
forall v. [(Label, v)] -> LabelMap v
mapFromList ([(Label, Int)] -> LabelMap Int) -> [(Label, Int)] -> LabelMap Int
forall a b. (a -> b) -> a -> b
$ ((Int, CmmBlock) -> (Label, Int))
-> [(Int, CmmBlock)] -> [(Label, Int)]
forall a b. (a -> b) -> [a] -> [b]
map (Int, CmmBlock) -> (Label, Int)
forall {thing :: Extensibility -> Extensibility -> *} {b}
       {x :: Extensibility}.
NonLocal thing =>
(b, thing C x) -> (Label, b)
swap [(Int, CmmBlock)]
blocks
                   swap :: (b, thing C x) -> (Label, b)
swap (b
k, thing C x
block) = (thing C x -> Label
forall (x :: Extensibility). thing C x -> Label
forall (thing :: Extensibility -> Extensibility -> *)
       (x :: Extensibility).
NonLocal thing =>
thing C x -> Label
entryLabel thing C x
block, b
k)
         addSuccEdges :: CGraph -> (Node, CmmBlock) -> CGraph
         addSuccEdges :: Gr CmmSuper () -> (Int, CmmBlock) -> Gr CmmSuper ()
addSuccEdges Gr CmmSuper ()
graph (Int
k, CmmBlock
block) =
             [LEdge ()] -> Gr CmmSuper () -> Gr CmmSuper ()
forall (gr :: * -> * -> *) b a.
DynGraph gr =>
[LEdge b] -> gr a b -> gr a b
insEdges [(Int
k, Label -> Int
labelNumber Label
lbl, ()) | Label
lbl <- [Label] -> [Label]
forall a. Eq a => [a] -> [a]
nub ([Label] -> [Label]) -> [Label] -> [Label]
forall a b. (a -> b) -> a -> b
$ CmmBlock -> [Label]
forall (e :: Extensibility). Block CmmNode e C -> [Label]
forall (thing :: Extensibility -> Extensibility -> *)
       (e :: Extensibility).
NonLocal thing =>
thing e C -> [Label]
successors CmmBlock
block] Gr CmmSuper ()
graph
{-
Note [Reducibility resources]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

*Flow Analysis of Computer Programs.* Matthew S. Hecht North Holland, 1977.
Available to borrow from archive.org.

Matthew S. Hecht and Jeffrey D. Ullman (1972).
Flow Graph Reducibility. SIAM J. Comput., 1(2), 188–202.
https://doi.org/10.1137/0201014

Johan Janssen and Henk Corporaal. 1997. Making graphs reducible with
controlled node splitting. ACM TOPLAS 19, 6 (Nov. 1997),
1031–1052. DOI:https://doi.org/10.1145/267959.269971

Sebastian Unger and Frank Mueller. 2002. Handling irreducible loops:
optimized node splitting versus DJ-graphs. ACM TOPLAS 24, 4 (July
2002), 299–333. https://doi.org/10.1145/567097.567098.  (This one
contains the most detailed account of how the Hecht/Ullman algorithm
is used to modify an actual control-flow graph.  But still not much detail.)

https://rgrig.blogspot.com/2009/10/dtfloatleftclearleft-summary-of-some.html
 (Nice summary of useful facts)

-}



type Seq = Seq.Seq

-- | A "supernode" contains a single-entry, multiple-exit, reducible subgraph.
-- The entry point is the given label, and the block with that label
-- dominates all the other blocks in the supernode.  When an entire
-- graph is collapsed into a single supernode, the graph is reducible.
-- More detail can be found in "GHC.Data.Graph.Collapse".

data CmmSuper
    = Nodes { CmmSuper -> Label
label :: Label
            , CmmSuper -> Seq CmmBlock
blocks :: Seq CmmBlock
            }

instance Semigroup CmmSuper where
  CmmSuper
s <> :: CmmSuper -> CmmSuper -> CmmSuper
<> CmmSuper
s' = Label -> Seq CmmBlock -> CmmSuper
Nodes (CmmSuper -> Label
label CmmSuper
s) (CmmSuper -> Seq CmmBlock
blocks CmmSuper
s Seq CmmBlock -> Seq CmmBlock -> Seq CmmBlock
forall a. Semigroup a => a -> a -> a
<> CmmSuper -> Seq CmmBlock
blocks CmmSuper
s')

instance PureSupernode CmmSuper where
  superLabel :: CmmSuper -> Label
superLabel = CmmSuper -> Label
label
  mapLabels :: (Label -> Label) -> CmmSuper -> CmmSuper
mapLabels = (Label -> Label) -> CmmSuper -> CmmSuper
changeLabels

instance Supernode CmmSuper NullCollapseViz where
  freshen :: CmmSuper -> NullCollapseViz CmmSuper
freshen CmmSuper
s = UniqDSM CmmSuper -> NullCollapseViz CmmSuper
forall a. UniqDSM a -> NullCollapseViz a
forall (m :: * -> *) a. MonadUniqDSM m => UniqDSM a -> m a
liftUniqDSM (UniqDSM CmmSuper -> NullCollapseViz CmmSuper)
-> UniqDSM CmmSuper -> NullCollapseViz CmmSuper
forall a b. (a -> b) -> a -> b
$ CmmSuper -> UniqDSM CmmSuper
relabel CmmSuper
s


-- | Return all labels defined within a supernode.
definedLabels :: CmmSuper -> Seq Label
definedLabels :: CmmSuper -> Seq Label
definedLabels = (CmmBlock -> Label) -> Seq CmmBlock -> Seq Label
forall a b. (a -> b) -> Seq a -> Seq b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CmmBlock -> Label
forall (x :: Extensibility). Block CmmNode C x -> Label
forall (thing :: Extensibility -> Extensibility -> *)
       (x :: Extensibility).
NonLocal thing =>
thing C x -> Label
entryLabel (Seq CmmBlock -> Seq Label)
-> (CmmSuper -> Seq CmmBlock) -> CmmSuper -> Seq Label
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CmmSuper -> Seq CmmBlock
blocks



-- | Map the given function over every use and definition of a label
-- in the given supernode.
changeLabels :: (Label -> Label) -> (CmmSuper -> CmmSuper)
changeLabels :: (Label -> Label) -> CmmSuper -> CmmSuper
changeLabels Label -> Label
f (Nodes Label
l Seq CmmBlock
blocks) = Label -> Seq CmmBlock -> CmmSuper
Nodes (Label -> Label
f Label
l) ((CmmBlock -> CmmBlock) -> Seq CmmBlock -> Seq CmmBlock
forall a b. (a -> b) -> Seq a -> Seq b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Label -> Label) -> CmmBlock -> CmmBlock
changeBlockLabels Label -> Label
f) Seq CmmBlock
blocks)

-- | Map the given function over every use and definition of a label
-- in the given block.
changeBlockLabels :: (Label -> Label) -> CmmBlock -> CmmBlock
changeBlockLabels :: (Label -> Label) -> CmmBlock -> CmmBlock
changeBlockLabels Label -> Label
f CmmBlock
block = CmmNode C O -> Block CmmNode O O -> CmmNode O C -> CmmBlock
forall (n :: Extensibility -> Extensibility -> *).
n C O -> Block n O O -> n O C -> Block n C C
blockJoin CmmNode C O
entry' Block CmmNode O O
middle CmmNode O C
exit'
  where (CmmNode C O
entry, Block CmmNode O O
middle, CmmNode O C
exit) = 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
        entry' :: CmmNode C O
entry' = let CmmEntry Label
l CmmTickScope
scope = CmmNode C O
entry
                 in  Label -> CmmTickScope -> CmmNode C O
CmmEntry (Label -> Label
f Label
l) CmmTickScope
scope
        exit' :: CmmNode O C
exit' = case CmmNode O C
exit of
                  -- unclear why mapSuccessors doesn't touch these
                  CmmCall { cml_cont :: CmmNode O C -> Maybe Label
cml_cont = Just Label
l } -> CmmNode O C
exit { cml_cont = Just (f l) }
                  CmmForeignCall { succ :: CmmNode O C -> Label
succ = Label
l } -> CmmNode O C
exit { succ = f l }
                  CmmNode O C
_ -> (Label -> Label) -> CmmNode O C -> CmmNode O C
mapSuccessors Label -> Label
f CmmNode O C
exit


-- | Within the given supernode, replace every defined label (and all
-- of its uses) with a fresh label.

relabel :: CmmSuper -> UniqDSM CmmSuper
relabel :: CmmSuper -> UniqDSM CmmSuper
relabel CmmSuper
node = do
     finite_map <- (LabelMap Label -> Label -> UniqDSM (LabelMap Label))
-> LabelMap Label -> Seq Label -> UniqDSM (LabelMap Label)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM LabelMap Label -> Label -> UniqDSM (LabelMap Label)
addPair LabelMap Label
forall v. LabelMap v
mapEmpty (Seq Label -> UniqDSM (LabelMap Label))
-> Seq Label -> UniqDSM (LabelMap Label)
forall a b. (a -> b) -> a -> b
$ CmmSuper -> Seq Label
definedLabels CmmSuper
node
     return $ changeLabels (labelChanger finite_map) node
  where addPair :: LabelMap Label -> Label -> UniqDSM (LabelMap Label)
        addPair :: LabelMap Label -> Label -> UniqDSM (LabelMap Label)
addPair LabelMap Label
map Label
old = do new <- UniqDSM Label
forall (m :: * -> *). MonadGetUnique m => m Label
newBlockId
                             return $ mapInsert old new map
        labelChanger :: LabelMap Label -> (Label -> Label)
        labelChanger :: LabelMap Label -> Label -> Label
labelChanger LabelMap Label
mapping = \Label
lbl -> Label -> Label -> LabelMap Label -> Label
forall a. a -> Label -> LabelMap a -> a
mapFindWithDefault Label
lbl Label
lbl LabelMap Label
mapping