{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses  #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}

--
-- Copyright (c) 2010, João Dias, Simon Marlow, Simon Peyton Jones,
-- and Norman Ramsey
--
-- Modifications copyright (c) The University of Glasgow 2012
--
-- This module is a specialised and optimised version of
-- Compiler.Hoopl.Dataflow in the hoopl package.  In particular it is
-- specialised to the UniqSM monad.
--

module GHC.Cmm.Dataflow
  ( C, O, Block
  , lastNode, entryLabel
  , foldNodesBwdOO
  , foldRewriteNodesBwdOO
  , DataflowLattice(..), OldFact(..), NewFact(..), JoinedFact(..)
  , TransferFun, RewriteFun
  , Fact, FactBase
  , getFact, mkFactBase
  , analyzeCmmFwd, analyzeCmmBwd
  , rewriteCmmBwd
  , changedIf
  , joinOutFacts
  , joinFacts
  )
where

import GHC.Prelude

import GHC.Cmm
import GHC.Types.Unique.Supply

import Data.Array
import Data.Maybe
import Data.IntSet (IntSet)
import qualified Data.IntSet as IntSet
import Data.Kind (Type)

import GHC.Cmm.Dataflow.Block
import GHC.Cmm.Dataflow.Graph
import GHC.Cmm.Dataflow.Collections
import GHC.Cmm.Dataflow.Label

type family   Fact (x :: Extensibility) f :: Type
type instance Fact C f = FactBase f
type instance Fact O f = f

newtype OldFact a = OldFact a

newtype NewFact a = NewFact a

-- | The result of joining OldFact and NewFact.
data JoinedFact a
    = Changed !a     -- ^ Result is different than OldFact.
    | NotChanged !a  -- ^ Result is the same as OldFact.

getJoined :: JoinedFact a -> a
getJoined :: forall a. JoinedFact a -> a
getJoined (Changed a
a) = a
a
getJoined (NotChanged a
a) = a
a

changedIf :: Bool -> a -> JoinedFact a
changedIf :: forall a. Bool -> a -> JoinedFact a
changedIf Bool
True = a -> JoinedFact a
forall a. a -> JoinedFact a
Changed
changedIf Bool
False = a -> JoinedFact a
forall a. a -> JoinedFact a
NotChanged

type JoinFun a = OldFact a -> NewFact a -> JoinedFact a

data DataflowLattice a = DataflowLattice
    { forall a. DataflowLattice a -> a
fact_bot :: a
    , forall a. DataflowLattice a -> JoinFun a
fact_join :: JoinFun a
    }

data Direction = Fwd | Bwd

type TransferFun f = CmmBlock -> FactBase f -> FactBase f

-- | Function for rewrtiting and analysis combined. To be used with
-- @rewriteCmm@.
--
-- Currently set to work with @UniqSM@ monad, but we could probably abstract
-- that away (if we do that, we might want to specialize the fixpoint algorithms
-- to the particular monads through SPECIALIZE).
type RewriteFun f = CmmBlock -> FactBase f -> UniqSM (CmmBlock, FactBase f)

analyzeCmmBwd, analyzeCmmFwd
    :: DataflowLattice f
    -> TransferFun f
    -> CmmGraph
    -> FactBase f
    -> FactBase f
analyzeCmmBwd :: forall f.
DataflowLattice f
-> TransferFun f -> CmmGraph -> FactBase f -> FactBase f
analyzeCmmBwd = Direction
-> DataflowLattice f
-> TransferFun f
-> CmmGraph
-> FactBase f
-> FactBase f
forall f.
Direction
-> DataflowLattice f
-> TransferFun f
-> CmmGraph
-> FactBase f
-> FactBase f
analyzeCmm Direction
Bwd
analyzeCmmFwd :: forall f.
DataflowLattice f
-> TransferFun f -> CmmGraph -> FactBase f -> FactBase f
analyzeCmmFwd = Direction
-> DataflowLattice f
-> TransferFun f
-> CmmGraph
-> FactBase f
-> FactBase f
forall f.
Direction
-> DataflowLattice f
-> TransferFun f
-> CmmGraph
-> FactBase f
-> FactBase f
analyzeCmm Direction
Fwd

analyzeCmm
    :: Direction
    -> DataflowLattice f
    -> TransferFun f
    -> CmmGraph
    -> FactBase f
    -> FactBase f
analyzeCmm :: forall f.
Direction
-> DataflowLattice f
-> TransferFun f
-> CmmGraph
-> FactBase f
-> FactBase f
analyzeCmm Direction
dir DataflowLattice f
lattice TransferFun f
transfer CmmGraph
cmmGraph FactBase f
initFact =
    {-# SCC analyzeCmm #-}
    let entry :: Label
entry = CmmGraph -> Label
forall (n :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> Label
g_entry CmmGraph
cmmGraph
        hooplGraph :: Graph CmmNode C C
hooplGraph = CmmGraph -> Graph CmmNode C C
forall (n :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> Graph n C C
g_graph CmmGraph
cmmGraph
        blockMap :: LabelMap CmmBlock
blockMap =
            case Graph CmmNode C C
hooplGraph of
                GMany MaybeO C (Block CmmNode O C)
NothingO LabelMap CmmBlock
bm MaybeO C (Block CmmNode C O)
NothingO -> LabelMap CmmBlock
bm
    in Direction
-> DataflowLattice f
-> TransferFun f
-> Label
-> LabelMap CmmBlock
-> FactBase f
-> FactBase f
forall f.
Direction
-> DataflowLattice f
-> TransferFun f
-> Label
-> LabelMap CmmBlock
-> FactBase f
-> FactBase f
fixpointAnalysis Direction
dir DataflowLattice f
lattice TransferFun f
transfer Label
entry LabelMap CmmBlock
blockMap FactBase f
initFact

-- Fixpoint algorithm.
fixpointAnalysis
    :: forall f.
       Direction
    -> DataflowLattice f
    -> TransferFun f
    -> Label
    -> LabelMap CmmBlock
    -> FactBase f
    -> FactBase f
fixpointAnalysis :: forall f.
Direction
-> DataflowLattice f
-> TransferFun f
-> Label
-> LabelMap CmmBlock
-> FactBase f
-> FactBase f
fixpointAnalysis Direction
direction DataflowLattice f
lattice TransferFun f
do_block Label
entry LabelMap CmmBlock
blockmap = IntHeap -> FactBase f -> FactBase f
loop IntHeap
start
  where
    -- Sorting the blocks helps to minimize the number of times we need to
    -- process blocks. For instance, for forward analysis we want to look at
    -- blocks in reverse postorder. Also, see comments for sortBlocks.
    blocks :: [CmmBlock]
blocks     = Direction -> Label -> LabelMap CmmBlock -> [CmmBlock]
forall (n :: Extensibility -> Extensibility -> *).
NonLocal n =>
Direction -> Label -> LabelMap (Block n C C) -> [Block n C C]
sortBlocks Direction
direction Label
entry LabelMap CmmBlock
blockmap
    num_blocks :: Int
num_blocks = [CmmBlock] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CmmBlock]
blocks
    block_arr :: Array Int CmmBlock
block_arr  = {-# SCC "block_arr" #-} (Int, Int) -> [CmmBlock] -> Array Int CmmBlock
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0, Int
num_blocks Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [CmmBlock]
blocks
    start :: IntHeap
start      = {-# SCC "start" #-} [Int] -> IntHeap
IntSet.fromDistinctAscList
      [Int
0 .. Int
num_blocks Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
    dep_blocks :: LabelMap IntHeap
dep_blocks = {-# SCC "dep_blocks" #-} Direction -> [CmmBlock] -> LabelMap IntHeap
mkDepBlocks Direction
direction [CmmBlock]
blocks
    join :: JoinFun f
join       = DataflowLattice f -> JoinFun f
forall a. DataflowLattice a -> JoinFun a
fact_join DataflowLattice f
lattice

    loop
        :: IntHeap     -- ^ Worklist, i.e., blocks to process
        -> FactBase f  -- ^ Current result (increases monotonically)
        -> FactBase f
    loop :: IntHeap -> FactBase f -> FactBase f
loop IntHeap
todo !FactBase f
fbase1 | Just (Int
index, IntHeap
todo1) <- IntHeap -> Maybe (Int, IntHeap)
IntSet.minView IntHeap
todo =
        let block :: CmmBlock
block = Array Int CmmBlock
block_arr Array Int CmmBlock -> Int -> CmmBlock
forall i e. Ix i => Array i e -> i -> e
! Int
index
            out_facts :: FactBase f
out_facts = {-# SCC "do_block" #-} TransferFun f
do_block CmmBlock
block FactBase f
fbase1
            -- For each of the outgoing edges, we join it with the current
            -- information in fbase1 and (if something changed) we update it
            -- and add the affected blocks to the worklist.
            (IntHeap
todo2, FactBase f
fbase2) = {-# SCC "mapFoldWithKey" #-}
                ((IntHeap, FactBase f)
 -> KeyOf LabelMap -> f -> (IntHeap, FactBase f))
-> (IntHeap, FactBase f) -> FactBase f -> (IntHeap, FactBase f)
forall (map :: * -> *) b a.
IsMap map =>
(b -> KeyOf map -> a -> b) -> b -> map a -> b
mapFoldlWithKey
                    (JoinFun f
-> LabelMap IntHeap
-> (IntHeap, FactBase f)
-> Label
-> f
-> (IntHeap, FactBase f)
forall f.
JoinFun f
-> LabelMap IntHeap
-> (IntHeap, FactBase f)
-> Label
-> f
-> (IntHeap, FactBase f)
updateFact JoinFun f
join LabelMap IntHeap
dep_blocks) (IntHeap
todo1, FactBase f
fbase1) FactBase f
out_facts
        in IntHeap -> FactBase f -> FactBase f
loop IntHeap
todo2 FactBase f
fbase2
    loop IntHeap
_ !FactBase f
fbase1 = FactBase f
fbase1

rewriteCmmBwd
    :: DataflowLattice f
    -> RewriteFun f
    -> CmmGraph
    -> FactBase f
    -> UniqSM (CmmGraph, FactBase f)
rewriteCmmBwd :: forall f.
DataflowLattice f
-> RewriteFun f
-> CmmGraph
-> FactBase f
-> UniqSM (CmmGraph, FactBase f)
rewriteCmmBwd = Direction
-> DataflowLattice f
-> RewriteFun f
-> CmmGraph
-> FactBase f
-> UniqSM (CmmGraph, FactBase f)
forall f.
Direction
-> DataflowLattice f
-> RewriteFun f
-> CmmGraph
-> FactBase f
-> UniqSM (CmmGraph, FactBase f)
rewriteCmm Direction
Bwd

rewriteCmm
    :: Direction
    -> DataflowLattice f
    -> RewriteFun f
    -> CmmGraph
    -> FactBase f
    -> UniqSM (CmmGraph, FactBase f)
rewriteCmm :: forall f.
Direction
-> DataflowLattice f
-> RewriteFun f
-> CmmGraph
-> FactBase f
-> UniqSM (CmmGraph, FactBase f)
rewriteCmm Direction
dir DataflowLattice f
lattice RewriteFun f
rwFun CmmGraph
cmmGraph FactBase f
initFact = {-# SCC rewriteCmm #-} do
    let entry :: Label
entry = CmmGraph -> Label
forall (n :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> Label
g_entry CmmGraph
cmmGraph
        hooplGraph :: Graph CmmNode C C
hooplGraph = CmmGraph -> Graph CmmNode C C
forall (n :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> Graph n C C
g_graph CmmGraph
cmmGraph
        blockMap1 :: LabelMap CmmBlock
blockMap1 =
            case Graph CmmNode C C
hooplGraph of
                GMany MaybeO C (Block CmmNode O C)
NothingO LabelMap CmmBlock
bm MaybeO C (Block CmmNode C O)
NothingO -> LabelMap CmmBlock
bm
    (LabelMap CmmBlock
blockMap2, FactBase f
facts) <-
        Direction
-> DataflowLattice f
-> RewriteFun f
-> Label
-> LabelMap CmmBlock
-> FactBase f
-> UniqSM (LabelMap CmmBlock, FactBase f)
forall f.
Direction
-> DataflowLattice f
-> RewriteFun f
-> Label
-> LabelMap CmmBlock
-> FactBase f
-> UniqSM (LabelMap CmmBlock, FactBase f)
fixpointRewrite Direction
dir DataflowLattice f
lattice RewriteFun f
rwFun Label
entry LabelMap CmmBlock
blockMap1 FactBase f
initFact
    (CmmGraph, FactBase f) -> UniqSM (CmmGraph, FactBase f)
forall (m :: * -> *) a. Monad m => a -> m a
return (CmmGraph
cmmGraph {g_graph :: Graph CmmNode C C
g_graph = MaybeO C (Block CmmNode O C)
-> LabelMap CmmBlock
-> MaybeO C (Block CmmNode C O)
-> Graph CmmNode C C
forall (e :: Extensibility)
       (block :: (Extensibility -> Extensibility -> *)
                 -> Extensibility -> Extensibility -> *)
       (n :: Extensibility -> Extensibility -> *) (x :: Extensibility).
MaybeO e (block n O C)
-> Body' block n -> MaybeO x (block n C O) -> Graph' block n e x
GMany MaybeO C (Block CmmNode O C)
forall t. MaybeO C t
NothingO LabelMap CmmBlock
blockMap2 MaybeO C (Block CmmNode C O)
forall t. MaybeO C t
NothingO}, FactBase f
facts)

fixpointRewrite
    :: forall f.
       Direction
    -> DataflowLattice f
    -> RewriteFun f
    -> Label
    -> LabelMap CmmBlock
    -> FactBase f
    -> UniqSM (LabelMap CmmBlock, FactBase f)
fixpointRewrite :: forall f.
Direction
-> DataflowLattice f
-> RewriteFun f
-> Label
-> LabelMap CmmBlock
-> FactBase f
-> UniqSM (LabelMap CmmBlock, FactBase f)
fixpointRewrite Direction
dir DataflowLattice f
lattice RewriteFun f
do_block Label
entry LabelMap CmmBlock
blockmap = IntHeap
-> LabelMap CmmBlock
-> FactBase f
-> UniqSM (LabelMap CmmBlock, FactBase f)
loop IntHeap
start LabelMap CmmBlock
blockmap
  where
    -- Sorting the blocks helps to minimize the number of times we need to
    -- process blocks. For instance, for forward analysis we want to look at
    -- blocks in reverse postorder. Also, see comments for sortBlocks.
    blocks :: [CmmBlock]
blocks     = Direction -> Label -> LabelMap CmmBlock -> [CmmBlock]
forall (n :: Extensibility -> Extensibility -> *).
NonLocal n =>
Direction -> Label -> LabelMap (Block n C C) -> [Block n C C]
sortBlocks Direction
dir Label
entry LabelMap CmmBlock
blockmap
    num_blocks :: Int
num_blocks = [CmmBlock] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CmmBlock]
blocks
    block_arr :: Array Int CmmBlock
block_arr  = {-# SCC "block_arr_rewrite" #-}
                 (Int, Int) -> [CmmBlock] -> Array Int CmmBlock
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0, Int
num_blocks Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [CmmBlock]
blocks
    start :: IntHeap
start      = {-# SCC "start_rewrite" #-}
                 [Int] -> IntHeap
IntSet.fromDistinctAscList [Int
0 .. Int
num_blocks Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
    dep_blocks :: LabelMap IntHeap
dep_blocks = {-# SCC "dep_blocks_rewrite" #-} Direction -> [CmmBlock] -> LabelMap IntHeap
mkDepBlocks Direction
dir [CmmBlock]
blocks
    join :: JoinFun f
join       = DataflowLattice f -> JoinFun f
forall a. DataflowLattice a -> JoinFun a
fact_join DataflowLattice f
lattice

    loop
        :: IntHeap            -- ^ Worklist, i.e., blocks to process
        -> LabelMap CmmBlock  -- ^ Rewritten blocks.
        -> FactBase f         -- ^ Current facts.
        -> UniqSM (LabelMap CmmBlock, FactBase f)
    loop :: IntHeap
-> LabelMap CmmBlock
-> FactBase f
-> UniqSM (LabelMap CmmBlock, FactBase f)
loop IntHeap
todo !LabelMap CmmBlock
blocks1 !FactBase f
fbase1
      | Just (Int
index, IntHeap
todo1) <- IntHeap -> Maybe (Int, IntHeap)
IntSet.minView IntHeap
todo = do
        -- Note that we use the *original* block here. This is important.
        -- We're optimistically rewriting blocks even before reaching the fixed
        -- point, which means that the rewrite might be incorrect. So if the
        -- facts change, we need to rewrite the original block again (taking
        -- into account the new facts).
        let block :: CmmBlock
block = Array Int CmmBlock
block_arr Array Int CmmBlock -> Int -> CmmBlock
forall i e. Ix i => Array i e -> i -> e
! Int
index
        (CmmBlock
new_block, FactBase f
out_facts) <- {-# SCC "do_block_rewrite" #-}
            RewriteFun f
do_block CmmBlock
block FactBase f
fbase1
        let blocks2 :: LabelMap CmmBlock
blocks2 = KeyOf LabelMap
-> CmmBlock -> LabelMap CmmBlock -> LabelMap CmmBlock
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert (CmmBlock -> Label
forall (thing :: Extensibility -> Extensibility -> *)
       (x :: Extensibility).
NonLocal thing =>
thing C x -> Label
entryLabel CmmBlock
new_block) CmmBlock
new_block LabelMap CmmBlock
blocks1
            (IntHeap
todo2, FactBase f
fbase2) = {-# SCC "mapFoldWithKey_rewrite" #-}
                ((IntHeap, FactBase f)
 -> KeyOf LabelMap -> f -> (IntHeap, FactBase f))
-> (IntHeap, FactBase f) -> FactBase f -> (IntHeap, FactBase f)
forall (map :: * -> *) b a.
IsMap map =>
(b -> KeyOf map -> a -> b) -> b -> map a -> b
mapFoldlWithKey
                    (JoinFun f
-> LabelMap IntHeap
-> (IntHeap, FactBase f)
-> Label
-> f
-> (IntHeap, FactBase f)
forall f.
JoinFun f
-> LabelMap IntHeap
-> (IntHeap, FactBase f)
-> Label
-> f
-> (IntHeap, FactBase f)
updateFact JoinFun f
join LabelMap IntHeap
dep_blocks) (IntHeap
todo1, FactBase f
fbase1) FactBase f
out_facts
        IntHeap
-> LabelMap CmmBlock
-> FactBase f
-> UniqSM (LabelMap CmmBlock, FactBase f)
loop IntHeap
todo2 LabelMap CmmBlock
blocks2 FactBase f
fbase2
    loop IntHeap
_ !LabelMap CmmBlock
blocks1 !FactBase f
fbase1 = (LabelMap CmmBlock, FactBase f)
-> UniqSM (LabelMap CmmBlock, FactBase f)
forall (m :: * -> *) a. Monad m => a -> m a
return (LabelMap CmmBlock
blocks1, FactBase f
fbase1)


{-
Note [Unreachable blocks]
~~~~~~~~~~~~~~~~~~~~~~~~~
A block that is not in the domain of tfb_fbase is "currently unreachable".
A currently-unreachable block is not even analyzed.  Reason: consider
constant prop and this graph, with entry point L1:
  L1: x:=3; goto L4
  L2: x:=4; goto L4
  L4: if x>3 goto L2 else goto L5
Here L2 is actually unreachable, but if we process it with bottom input fact,
we'll propagate (x=4) to L4, and nuke the otherwise-good rewriting of L4.

* If a currently-unreachable block is not analyzed, then its rewritten
  graph will not be accumulated in tfb_rg.  And that is good:
  unreachable blocks simply do not appear in the output.

* Note that clients must be careful to provide a fact (even if bottom)
  for each entry point. Otherwise useful blocks may be garbage collected.

* Note that updateFact must set the change-flag if a label goes from
  not-in-fbase to in-fbase, even if its fact is bottom.  In effect the
  real fact lattice is
       UNR
       bottom
       the points above bottom

* Even if the fact is going from UNR to bottom, we still call the
  client's fact_join function because it might give the client
  some useful debugging information.

* All of this only applies for *forward* ixpoints.  For the backward
  case we must treat every block as reachable; it might finish with a
  'return', and therefore have no successors, for example.
-}


-----------------------------------------------------------------------------
--  Pieces that are shared by fixpoint and fixpoint_anal
-----------------------------------------------------------------------------

-- | Sort the blocks into the right order for analysis. This means reverse
-- postorder for a forward analysis. For the backward one, we simply reverse
-- that (see Note [Backward vs forward analysis]).
sortBlocks
    :: NonLocal n
    => Direction -> Label -> LabelMap (Block n C C) -> [Block n C C]
sortBlocks :: forall (n :: Extensibility -> Extensibility -> *).
NonLocal n =>
Direction -> Label -> LabelMap (Block n C C) -> [Block n C C]
sortBlocks Direction
direction Label
entry LabelMap (Block n C C)
blockmap =
    case Direction
direction of
        Direction
Fwd -> [Block n C C]
fwd
        Direction
Bwd -> [Block n C C] -> [Block n C C]
forall a. [a] -> [a]
reverse [Block n C C]
fwd
  where
    fwd :: [Block n C C]
fwd = LabelMap (Block n C C) -> Label -> [Block n C C]
forall (block :: Extensibility -> Extensibility -> *).
NonLocal block =>
LabelMap (block C C) -> Label -> [block C C]
revPostorderFrom LabelMap (Block n C C)
blockmap Label
entry

-- Note [Backward vs forward analysis]
--
-- The forward and backward cases are not dual.  In the forward case, the entry
-- points are known, and one simply traverses the body blocks from those points.
-- In the backward case, something is known about the exit points, but a
-- backward analysis must also include reachable blocks that don't reach the
-- exit, as in a procedure that loops forever and has side effects.)
-- For instance, let E be the entry and X the exit blocks (arrows indicate
-- control flow)
--   E -> X
--   E -> B
--   B -> C
--   C -> B
-- We do need to include B and C even though they're unreachable in the
-- *reverse* graph (that we could use for backward analysis):
--   E <- X
--   E <- B
--   B <- C
--   C <- B
-- So when sorting the blocks for the backward analysis, we simply take the
-- reverse of what is used for the forward one.


-- | Construct a mapping from a @Label@ to the block indexes that should be
-- re-analyzed if the facts at that @Label@ change.
--
-- Note that we're considering here the entry point of the block, so if the
-- facts change at the entry:
-- * for a backward analysis we need to re-analyze all the predecessors, but
-- * for a forward analysis, we only need to re-analyze the current block
--   (and that will in turn propagate facts into its successors).
mkDepBlocks :: Direction -> [CmmBlock] -> LabelMap IntSet
mkDepBlocks :: Direction -> [CmmBlock] -> LabelMap IntHeap
mkDepBlocks Direction
Fwd [CmmBlock]
blocks = [CmmBlock] -> Int -> LabelMap IntHeap -> LabelMap IntHeap
forall {map :: * -> *}
       {thing :: Extensibility -> Extensibility -> *}
       {x :: Extensibility}.
(IsMap map, NonLocal thing, KeyOf map ~ Label) =>
[thing C x] -> Int -> map IntHeap -> map IntHeap
go [CmmBlock]
blocks Int
0 LabelMap IntHeap
forall (map :: * -> *) a. IsMap map => map a
mapEmpty
  where
    go :: [thing C x] -> Int -> map IntHeap -> map IntHeap
go []     !Int
_ !map IntHeap
dep_map = map IntHeap
dep_map
    go (thing C x
b:[thing C x]
bs) !Int
n !map IntHeap
dep_map =
        [thing C x] -> Int -> map IntHeap -> map IntHeap
go [thing C x]
bs (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (map IntHeap -> map IntHeap) -> map IntHeap -> map IntHeap
forall a b. (a -> b) -> a -> b
$ KeyOf map -> IntHeap -> map IntHeap -> map IntHeap
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert (thing C x -> Label
forall (thing :: Extensibility -> Extensibility -> *)
       (x :: Extensibility).
NonLocal thing =>
thing C x -> Label
entryLabel thing C x
b) (Int -> IntHeap
IntSet.singleton Int
n) map IntHeap
dep_map
mkDepBlocks Direction
Bwd [CmmBlock]
blocks = [CmmBlock] -> Int -> LabelMap IntHeap -> LabelMap IntHeap
forall {map :: * -> *}
       {thing :: Extensibility -> Extensibility -> *}
       {e :: Extensibility}.
(IsMap map, NonLocal thing, KeyOf map ~ Label) =>
[thing e C] -> Int -> map IntHeap -> map IntHeap
go [CmmBlock]
blocks Int
0 LabelMap IntHeap
forall (map :: * -> *) a. IsMap map => map a
mapEmpty
  where
    go :: [thing e C] -> Int -> map IntHeap -> map IntHeap
go []     !Int
_ !map IntHeap
dep_map = map IntHeap
dep_map
    go (thing e C
b:[thing e C]
bs) !Int
n !map IntHeap
dep_map =
        let insert :: map IntHeap -> Label -> map IntHeap
insert map IntHeap
m Label
l = (IntHeap -> IntHeap -> IntHeap)
-> KeyOf map -> IntHeap -> map IntHeap -> map IntHeap
forall (map :: * -> *) a.
IsMap map =>
(a -> a -> a) -> KeyOf map -> a -> map a -> map a
mapInsertWith IntHeap -> IntHeap -> IntHeap
IntSet.union KeyOf map
Label
l (Int -> IntHeap
IntSet.singleton Int
n) map IntHeap
m
        in [thing e C] -> Int -> map IntHeap -> map IntHeap
go [thing e C]
bs (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (map IntHeap -> map IntHeap) -> map IntHeap -> map IntHeap
forall a b. (a -> b) -> a -> b
$ (map IntHeap -> Label -> map IntHeap)
-> map IntHeap -> [Label] -> map IntHeap
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' map IntHeap -> Label -> map IntHeap
insert map IntHeap
dep_map (thing e C -> [Label]
forall (thing :: Extensibility -> Extensibility -> *)
       (e :: Extensibility).
NonLocal thing =>
thing e C -> [Label]
successors thing e C
b)

-- | After some new facts have been generated by analysing a block, we
-- fold this function over them to generate (a) a list of block
-- indices to (re-)analyse, and (b) the new FactBase.
updateFact
    :: JoinFun f
    -> LabelMap IntSet
    -> (IntHeap, FactBase f)
    -> Label
    -> f -- out fact
    -> (IntHeap, FactBase f)
updateFact :: forall f.
JoinFun f
-> LabelMap IntHeap
-> (IntHeap, FactBase f)
-> Label
-> f
-> (IntHeap, FactBase f)
updateFact JoinFun f
fact_join LabelMap IntHeap
dep_blocks (IntHeap
todo, FactBase f
fbase) Label
lbl f
new_fact
  = case Label -> FactBase f -> Maybe f
forall f. Label -> FactBase f -> Maybe f
lookupFact Label
lbl FactBase f
fbase of
      Maybe f
Nothing ->
          -- Note [No old fact]
          let !z :: FactBase f
z = KeyOf LabelMap -> f -> FactBase f -> FactBase f
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert KeyOf LabelMap
Label
lbl f
new_fact FactBase f
fbase in (IntHeap
changed, FactBase f
z)
      Just f
old_fact ->
          case JoinFun f
fact_join (f -> OldFact f
forall a. a -> OldFact a
OldFact f
old_fact) (f -> NewFact f
forall a. a -> NewFact a
NewFact f
new_fact) of
              (NotChanged f
_) -> (IntHeap
todo, FactBase f
fbase)
              (Changed f
f) -> let !z :: FactBase f
z = KeyOf LabelMap -> f -> FactBase f -> FactBase f
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert KeyOf LabelMap
Label
lbl f
f FactBase f
fbase in (IntHeap
changed, FactBase f
z)
  where
    changed :: IntHeap
changed = IntHeap
todo IntHeap -> IntHeap -> IntHeap
`IntSet.union`
              IntHeap -> KeyOf LabelMap -> LabelMap IntHeap -> IntHeap
forall (map :: * -> *) a. IsMap map => a -> KeyOf map -> map a -> a
mapFindWithDefault IntHeap
IntSet.empty KeyOf LabelMap
Label
lbl LabelMap IntHeap
dep_blocks

{-
Note [No old fact]

We know that the new_fact is >= _|_, so we don't need to join.  However,
if the new fact is also _|_, and we have already analysed its block,
we don't need to record a change.  So there's a tradeoff here.  It turns
out that always recording a change is faster.
-}

----------------------------------------------------------------
--       Utilities
----------------------------------------------------------------

-- Fact lookup: the fact `orelse` bottom
getFact  :: DataflowLattice f -> Label -> FactBase f -> f
getFact :: forall f. DataflowLattice f -> Label -> FactBase f -> f
getFact DataflowLattice f
lat Label
l FactBase f
fb = case Label -> FactBase f -> Maybe f
forall f. Label -> FactBase f -> Maybe f
lookupFact Label
l FactBase f
fb of Just  f
f -> f
f
                                           Maybe f
Nothing -> DataflowLattice f -> f
forall a. DataflowLattice a -> a
fact_bot DataflowLattice f
lat

-- | Returns the result of joining the facts from all the successors of the
-- provided node or block.
joinOutFacts :: (NonLocal n) => DataflowLattice f -> n e C -> FactBase f -> f
joinOutFacts :: forall (n :: Extensibility -> Extensibility -> *) f
       (e :: Extensibility).
NonLocal n =>
DataflowLattice f -> n e C -> FactBase f -> f
joinOutFacts DataflowLattice f
lattice n e C
nonLocal FactBase f
fact_base = (f -> f -> f) -> f -> [f] -> f
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' f -> f -> f
join (DataflowLattice f -> f
forall a. DataflowLattice a -> a
fact_bot DataflowLattice f
lattice) [f]
facts
  where
    join :: f -> f -> f
join f
new f
old = JoinedFact f -> f
forall a. JoinedFact a -> a
getJoined (JoinedFact f -> f) -> JoinedFact f -> f
forall a b. (a -> b) -> a -> b
$ DataflowLattice f -> JoinFun f
forall a. DataflowLattice a -> JoinFun a
fact_join DataflowLattice f
lattice (f -> OldFact f
forall a. a -> OldFact a
OldFact f
old) (f -> NewFact f
forall a. a -> NewFact a
NewFact f
new)
    facts :: [f]
facts =
        [ Maybe f -> f
forall a. HasCallStack => Maybe a -> a
fromJust Maybe f
fact
        | Label
s <- n e C -> [Label]
forall (thing :: Extensibility -> Extensibility -> *)
       (e :: Extensibility).
NonLocal thing =>
thing e C -> [Label]
successors n e C
nonLocal
        , let fact :: Maybe f
fact = Label -> FactBase f -> Maybe f
forall f. Label -> FactBase f -> Maybe f
lookupFact Label
s FactBase f
fact_base
        , Maybe f -> Bool
forall a. Maybe a -> Bool
isJust Maybe f
fact
        ]

joinFacts :: DataflowLattice f -> [f] -> f
joinFacts :: forall f. DataflowLattice f -> [f] -> f
joinFacts DataflowLattice f
lattice [f]
facts  = (f -> f -> f) -> f -> [f] -> f
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' f -> f -> f
join (DataflowLattice f -> f
forall a. DataflowLattice a -> a
fact_bot DataflowLattice f
lattice) [f]
facts
  where
    join :: f -> f -> f
join f
new f
old = JoinedFact f -> f
forall a. JoinedFact a -> a
getJoined (JoinedFact f -> f) -> JoinedFact f -> f
forall a b. (a -> b) -> a -> b
$ DataflowLattice f -> JoinFun f
forall a. DataflowLattice a -> JoinFun a
fact_join DataflowLattice f
lattice (f -> OldFact f
forall a. a -> OldFact a
OldFact f
old) (f -> NewFact f
forall a. a -> NewFact a
NewFact f
new)

-- | Returns the joined facts for each label.
mkFactBase :: DataflowLattice f -> [(Label, f)] -> FactBase f
mkFactBase :: forall f. DataflowLattice f -> [(Label, f)] -> FactBase f
mkFactBase DataflowLattice f
lattice = (LabelMap f -> (Label, f) -> LabelMap f)
-> LabelMap f -> [(Label, f)] -> LabelMap f
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' LabelMap f -> (Label, f) -> LabelMap f
add LabelMap f
forall (map :: * -> *) a. IsMap map => map a
mapEmpty
  where
    join :: JoinFun f
join = DataflowLattice f -> JoinFun f
forall a. DataflowLattice a -> JoinFun a
fact_join DataflowLattice f
lattice

    add :: LabelMap f -> (Label, f) -> LabelMap f
add LabelMap f
result (Label
l, f
f1) =
        let !newFact :: f
newFact =
                case KeyOf LabelMap -> LabelMap f -> Maybe f
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
Label
l LabelMap f
result of
                    Maybe f
Nothing -> f
f1
                    Just f
f2 -> JoinedFact f -> f
forall a. JoinedFact a -> a
getJoined (JoinedFact f -> f) -> JoinedFact f -> f
forall a b. (a -> b) -> a -> b
$ JoinFun f
join (f -> OldFact f
forall a. a -> OldFact a
OldFact f
f1) (f -> NewFact f
forall a. a -> NewFact a
NewFact f
f2)
        in KeyOf LabelMap -> f -> LabelMap f -> LabelMap f
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert KeyOf LabelMap
Label
l f
newFact LabelMap f
result

-- | Folds backward over all nodes of an open-open block.
-- Strict in the accumulator.
foldNodesBwdOO :: (CmmNode O O -> f -> f) -> Block CmmNode O O -> f -> f
foldNodesBwdOO :: forall f. (CmmNode O O -> f -> f) -> Block CmmNode O O -> f -> f
foldNodesBwdOO CmmNode O O -> f -> f
funOO = Block CmmNode O O -> f -> f
go
  where
    go :: Block CmmNode O O -> f -> f
go (BCat Block CmmNode O O
b1 Block CmmNode O O
b2) f
f = Block CmmNode O O -> f -> f
go Block CmmNode O O
b1 (f -> f) -> f -> f
forall a b. (a -> b) -> a -> b
$! Block CmmNode O O -> f -> f
go Block CmmNode O O
b2 f
f
    go (BSnoc Block CmmNode O O
h CmmNode O O
n) f
f = Block CmmNode O O -> f -> f
go Block CmmNode O O
h (f -> f) -> f -> f
forall a b. (a -> b) -> a -> b
$! CmmNode O O -> f -> f
funOO CmmNode O O
n f
f
    go (BCons CmmNode O O
n Block CmmNode O O
t) f
f = CmmNode O O -> f -> f
funOO CmmNode O O
n (f -> f) -> f -> f
forall a b. (a -> b) -> a -> b
$! Block CmmNode O O -> f -> f
go Block CmmNode O O
t f
f
    go (BMiddle CmmNode O O
n) f
f = CmmNode O O -> f -> f
funOO CmmNode O O
n f
f
    go Block CmmNode O O
BNil f
f = f
f
{-# INLINABLE foldNodesBwdOO #-}

-- | Folds backward over all the nodes of an open-open block and allows
-- rewriting them. The accumulator is both the block of nodes and @f@ (usually
-- dataflow facts).
-- Strict in both accumulated parts.
foldRewriteNodesBwdOO
    :: forall f.
       (CmmNode O O -> f -> UniqSM (Block CmmNode O O, f))
    -> Block CmmNode O O
    -> f
    -> UniqSM (Block CmmNode O O, f)
foldRewriteNodesBwdOO :: forall f.
(CmmNode O O -> f -> UniqSM (Block CmmNode O O, f))
-> Block CmmNode O O -> f -> UniqSM (Block CmmNode O O, f)
foldRewriteNodesBwdOO CmmNode O O -> f -> UniqSM (Block CmmNode O O, f)
rewriteOO Block CmmNode O O
initBlock f
initFacts = Block CmmNode O O -> f -> UniqSM (Block CmmNode O O, f)
go Block CmmNode O O
initBlock f
initFacts
  where
    go :: Block CmmNode O O -> f -> UniqSM (Block CmmNode O O, f)
go (BCons CmmNode O O
node1 Block CmmNode O O
block1) !f
fact1 = (CmmNode O O -> f -> UniqSM (Block CmmNode O O, f)
rewriteOO CmmNode O O
node1 (f -> UniqSM (Block CmmNode O O, f))
-> (f -> UniqSM (Block CmmNode O O, f))
-> f
-> UniqSM (Block CmmNode O O, f)
forall {m :: * -> *} {t} {n :: Extensibility -> Extensibility -> *}
       {b} {t}.
Monad m =>
(t -> m (Block n O O, b))
-> (t -> m (Block n O O, t)) -> t -> m (Block n O O, b)
`comp` Block CmmNode O O -> f -> UniqSM (Block CmmNode O O, f)
go Block CmmNode O O
block1) f
fact1
    go (BSnoc Block CmmNode O O
block1 CmmNode O O
node1) !f
fact1 = (Block CmmNode O O -> f -> UniqSM (Block CmmNode O O, f)
go Block CmmNode O O
block1 (f -> UniqSM (Block CmmNode O O, f))
-> (f -> UniqSM (Block CmmNode O O, f))
-> f
-> UniqSM (Block CmmNode O O, f)
forall {m :: * -> *} {t} {n :: Extensibility -> Extensibility -> *}
       {b} {t}.
Monad m =>
(t -> m (Block n O O, b))
-> (t -> m (Block n O O, t)) -> t -> m (Block n O O, b)
`comp` CmmNode O O -> f -> UniqSM (Block CmmNode O O, f)
rewriteOO CmmNode O O
node1) f
fact1
    go (BCat Block CmmNode O O
blockA1 Block CmmNode O O
blockB1) !f
fact1 = (Block CmmNode O O -> f -> UniqSM (Block CmmNode O O, f)
go Block CmmNode O O
blockA1 (f -> UniqSM (Block CmmNode O O, f))
-> (f -> UniqSM (Block CmmNode O O, f))
-> f
-> UniqSM (Block CmmNode O O, f)
forall {m :: * -> *} {t} {n :: Extensibility -> Extensibility -> *}
       {b} {t}.
Monad m =>
(t -> m (Block n O O, b))
-> (t -> m (Block n O O, t)) -> t -> m (Block n O O, b)
`comp` Block CmmNode O O -> f -> UniqSM (Block CmmNode O O, f)
go Block CmmNode O O
blockB1) f
fact1
    go (BMiddle CmmNode O O
node) !f
fact1 = CmmNode O O -> f -> UniqSM (Block CmmNode O O, f)
rewriteOO CmmNode O O
node f
fact1
    go Block CmmNode O O
BNil !f
fact = (Block CmmNode O O, f) -> UniqSM (Block CmmNode O O, f)
forall (m :: * -> *) a. Monad m => a -> m a
return (Block CmmNode O O
forall (n :: Extensibility -> Extensibility -> *). Block n O O
BNil, f
fact)

    comp :: (t -> m (Block n O O, b))
-> (t -> m (Block n O O, t)) -> t -> m (Block n O O, b)
comp t -> m (Block n O O, b)
rew1 t -> m (Block n O O, t)
rew2 = \t
f1 -> do
        (Block n O O
b, t
f2) <- t -> m (Block n O O, t)
rew2 t
f1
        (Block n O O
a, !b
f3) <- t -> m (Block n O O, b)
rew1 t
f2
        let !c :: Block n O O
c = Block n O O -> Block n O O -> Block n O O
forall (n :: Extensibility -> Extensibility -> *).
Block n O O -> Block n O O -> Block n O O
joinBlocksOO Block n O O
a Block n O O
b
        (Block n O O, b) -> m (Block n O O, b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Block n O O
c, b
f3)
    {-# INLINE comp #-}
{-# INLINABLE foldRewriteNodesBwdOO #-}

joinBlocksOO :: Block n O O -> Block n O O -> Block n O O
joinBlocksOO :: forall (n :: Extensibility -> Extensibility -> *).
Block n O O -> Block n O O -> Block n O O
joinBlocksOO Block n O O
BNil Block n O O
b = Block n O O
b
joinBlocksOO Block n O O
b Block n O O
BNil = Block n O O
b
joinBlocksOO (BMiddle n O O
n) Block n O O
b = n O O -> Block n O O -> Block n O O
forall (n :: Extensibility -> Extensibility -> *)
       (x :: Extensibility).
n O O -> Block n O x -> Block n O x
blockCons n O O
n Block n O O
b
joinBlocksOO Block n O O
b (BMiddle n O O
n) = Block n O O -> n O O -> Block n O O
forall (n :: Extensibility -> Extensibility -> *)
       (e :: Extensibility).
Block n e O -> n O O -> Block n e O
blockSnoc Block n O O
b n O O
n
joinBlocksOO Block n O O
b1 Block n O O
b2 = Block n O O -> Block n O O -> Block n O O
forall (n :: Extensibility -> Extensibility -> *).
Block n O O -> Block n O O -> Block n O O
BCat Block n O O
b1 Block n O O
b2

type IntHeap = IntSet