    {-# 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 :: Key
    num_blocks = [CmmBlock] -> Key
    forall (t :: * -> *) a. Foldable t => t a -> Key
    length [CmmBlock]
    blocks
        block_arr :: Array Key CmmBlock
    block_arr  = {-# SCC "block_arr" #-} (Key, Key) -> [CmmBlock] -> Array Key CmmBlock
    forall i e. Ix i => (i, i) -> [e] -> Array i e
    listArray (Key
    0, Key
    num_blocks Key -> Key -> Key
    forall a. Num a => a -> a -> a
    - Key
    1) [CmmBlock]
    blocks
        start :: IntHeap
    start      = {-# SCC "start" #-} [Key] -> IntHeap
    IntSet.fromDistinctAscList
          [Key
    0 .. Key
    num_blocks Key -> Key -> Key
    forall a. Num a => a -> a -> a
    - Key
    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 (Key
    index, IntHeap
    todo1) <- IntHeap -> Maybe (Key, IntHeap)
    IntSet.minView IntHeap
    todo =
            let block :: CmmBlock
    block = Array Key CmmBlock
    block_arr Array Key CmmBlock -> Key -> CmmBlock
    forall i e. Ix i => Array i e -> i -> e
    ! Key
    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 :: Key
    num_blocks = [CmmBlock] -> Key
    forall (t :: * -> *) a. Foldable t => t a -> Key
    length [CmmBlock]
    blocks
        block_arr :: Array Key CmmBlock
    block_arr  = {-# SCC "block_arr_rewrite" #-}
                     (Key, Key) -> [CmmBlock] -> Array Key CmmBlock
    forall i e. Ix i => (i, i) -> [e] -> Array i e
    listArray (Key
    0, Key
    num_blocks Key -> Key -> Key
    forall a. Num a => a -> a -> a
    - Key
    1) [CmmBlock]
    blocks
        start :: IntHeap
    start      = {-# SCC "start_rewrite" #-}
                     [Key] -> IntHeap
    IntSet.fromDistinctAscList [Key
    0 .. Key
    num_blocks Key -> Key -> Key
    forall a. Num a => a -> a -> a
    - Key
    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 (Key
    index, IntHeap
    todo1) <- IntHeap -> Maybe (Key, 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 Key CmmBlock
    block_arr Array Key CmmBlock -> Key -> CmmBlock
    forall i e. Ix i => Array i e -> i -> e
    ! Key
    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] -> Key -> LabelMap IntHeap -> LabelMap IntHeap
    forall {map :: * -> *}
           {thing :: Extensibility -> Extensibility -> *}
           {x :: Extensibility}.
    (KeyOf map ~ Label, IsMap map, NonLocal thing) =>
    [thing C x] -> Key -> map IntHeap -> map IntHeap
    go [CmmBlock]
    blocks Key
    0 LabelMap IntHeap
    forall (map :: * -> *) a. IsMap map => map a
    mapEmpty
      where
        go :: [thing C x] -> Key -> map IntHeap -> map IntHeap
    go []     !Key
    _ !map IntHeap
    dep_map = map IntHeap
    dep_map
        go (thing C x
    b:[thing C x]
    bs) !Key
    n !map IntHeap
    dep_map =
            [thing C x] -> Key -> map IntHeap -> map IntHeap
    go [thing C x]
    bs (Key
    n Key -> Key -> Key
    forall a. Num a => a -> a -> a
    + Key
    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) (Key -> IntHeap
    IntSet.singleton Key
    n) map IntHeap
    dep_map
    mkDepBlocks Direction
    Bwd [CmmBlock]
    blocks = [CmmBlock] -> Key -> LabelMap IntHeap -> LabelMap IntHeap
    forall {map :: * -> *}
           {thing :: Extensibility -> Extensibility -> *}
           {e :: Extensibility}.
    (KeyOf map ~ Label, IsMap map, NonLocal thing) =>
    [thing e C] -> Key -> map IntHeap -> map IntHeap
    go [CmmBlock]
    blocks Key
    0 LabelMap IntHeap
    forall (map :: * -> *) a. IsMap map => map a
    mapEmpty
      where
        go :: [thing e C] -> Key -> map IntHeap -> map IntHeap
    go []     !Key
    _ !map IntHeap
    dep_map = map IntHeap
    dep_map
        go (thing e C
    b:[thing e C]
    bs) !Key
    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 (Key -> IntHeap
    IntSet.singleton Key
    n) map IntHeap
    m
            in [thing e C] -> Key -> map IntHeap -> map IntHeap
    go [thing e C]
    bs (Key
    n Key -> Key -> Key
    forall a. Num a => a -> a -> a
    + Key
    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 = (FactBase f -> (Label, f) -> FactBase f)
    -> FactBase f -> [(Label, f)] -> FactBase f
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl' FactBase f -> (Label, f) -> FactBase f
    add FactBase 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 :: FactBase f -> (Label, f) -> FactBase f
    add FactBase f
    result (Label
    l, f
    f1) =
            let !newFact :: f
    newFact =
                    case KeyOf LabelMap -> FactBase f -> Maybe f
    forall (map :: * -> *) a.
    IsMap map =>
    KeyOf map -> map a -> Maybe a
    mapLookup KeyOf LabelMap
    Label
    l FactBase 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 -> FactBase f -> FactBase f
    forall (map :: * -> *) a.
    IsMap map =>
    KeyOf map -> a -> map a -> map a
    mapInsert KeyOf LabelMap
    Label
    l f
    newFact FactBase 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