    {-# LANGUAGE DataKinds #-}
    {-# LANGUAGE GADTs #-}
    {-# LANGUAGE TypeFamilies #-}
    module GHC.Cmm.Dataflow.Graph
        ( Body
        , Graph
        , Graph'(..)
        , NonLocal(..)
        , addBlock
        , bodyList
        , bodyToBlockList
        , emptyBody
        , labelsDefined
        , mapGraph
        , mapGraphBlocks
        , revPostorderFrom
        ) where

    import GHC.Prelude
    import GHC.Utils.Misc

    import GHC.Cmm.Dataflow.Label
    import GHC.Cmm.Dataflow.Block

    import Data.Kind

    -- | A (possibly empty) collection of closed/closed blocks
    type Body s n = Body' s Block n

    -- | @Body@ abstracted over @block@
    type Body' s block (n :: Extensibility -> Extensibility -> Type) = s (block n C C)

    -------------------------------
    -- | Gives access to the anchor points for
    -- nonlocal edges as well as the edges themselves
    class NonLocal thing where
      entryLabel :: thing C x -> Label   -- ^ The label of a first node or block
      successors :: thing e C -> [Label] -- ^ Gives control-flow successors

    instance NonLocal n => NonLocal (Block n) where
      entryLabel :: forall (x :: Extensibility). Block n C x -> Label
    entryLabel (BlockCO n C 'Open
    f Block n 'Open 'Open
    _)   = n C 'Open -> Label
    forall (x :: Extensibility). n C x -> Label
    forall (thing :: Extensibility -> Extensibility -> *)
           (x :: Extensibility).
    NonLocal thing =>
    thing C x -> Label
    entryLabel n C 'Open
    f
      entryLabel (BlockCC n C 'Open
    f Block n 'Open 'Open
    _ n 'Open C
    _) = n C 'Open -> Label
    forall (x :: Extensibility). n C x -> Label
    forall (thing :: Extensibility -> Extensibility -> *)
           (x :: Extensibility).
    NonLocal thing =>
    thing C x -> Label
    entryLabel n C 'Open
    f

      successors :: forall (e :: Extensibility). Block n e C -> [Label]
    successors (BlockOC   Block n 'Open 'Open
    _ n 'Open C
    n) = n 'Open C -> [Label]
    forall (e :: Extensibility). n e C -> [Label]
    forall (thing :: Extensibility -> Extensibility -> *)
           (e :: Extensibility).
    NonLocal thing =>
    thing e C -> [Label]
    successors n 'Open C
    n
      successors (BlockCC n C 'Open
    _ Block n 'Open 'Open
    _ n 'Open C
    n) = n 'Open C -> [Label]
    forall (e :: Extensibility). n e C -> [Label]
    forall (thing :: Extensibility -> Extensibility -> *)
           (e :: Extensibility).
    NonLocal thing =>
    thing e C -> [Label]
    successors n 'Open C
    n

    emptyBody :: Body' LabelMap block n
    emptyBody :: forall (block :: (Extensibility -> Extensibility -> *)
                     -> Extensibility -> Extensibility -> *)
           (n :: Extensibility -> Extensibility -> *).
    Body' LabelMap block n
    emptyBody = LabelMap (block n C C)
    forall v. LabelMap v
    mapEmpty

    bodyList :: Body' LabelMap block n -> [(Label,block n C C)]
    bodyList :: forall (block :: (Extensibility -> Extensibility -> *)
                     -> Extensibility -> Extensibility -> *)
           (n :: Extensibility -> Extensibility -> *).
    Body' LabelMap block n -> [(Label, block n C C)]
    bodyList Body' LabelMap block n
    body = Body' LabelMap block n -> [(Label, block n C C)]
    forall b. LabelMap b -> [(Label, b)]
    mapToList Body' LabelMap block n
    body

    bodyToBlockList :: Body LabelMap n -> [Block n C C]
    bodyToBlockList :: forall (n :: Extensibility -> Extensibility -> *).
    Body LabelMap n -> [Block n C C]
    bodyToBlockList Body LabelMap n
    body = Body LabelMap n -> [Block n C C]
    forall a. LabelMap a -> [a]
    mapElems Body LabelMap n
    body

    addBlock
        :: (NonLocal block, HasDebugCallStack)
        => block C C -> LabelMap (block C C) -> LabelMap (block C C)
    addBlock :: forall (block :: Extensibility -> Extensibility -> *).
    (NonLocal block, HasDebugCallStack) =>
    block C C -> LabelMap (block C C) -> LabelMap (block C C)
    addBlock block C C
    block LabelMap (block C C)
    body = (Maybe (block C C) -> Maybe (block C C))
    -> Label -> LabelMap (block C C) -> LabelMap (block C C)
    forall v. (Maybe v -> Maybe v) -> Label -> LabelMap v -> LabelMap v
    mapAlter Maybe (block C C) -> Maybe (block C C)
    add Label
    lbl LabelMap (block C C)
    body
      where
        lbl :: Label
    lbl = block C C -> Label
    forall (x :: Extensibility). block C x -> Label
    forall (thing :: Extensibility -> Extensibility -> *)
           (x :: Extensibility).
    NonLocal thing =>
    thing C x -> Label
    entryLabel block C C
    block
        add :: Maybe (block C C) -> Maybe (block C C)
    add Maybe (block C C)
    Nothing = block C C -> Maybe (block C C)
    forall a. a -> Maybe a
    Just block C C
    block
        add Maybe (block C C)
    _ = [Char] -> Maybe (block C C)
    forall a. HasCallStack => [Char] -> a
    error ([Char] -> Maybe (block C C)) -> [Char] -> Maybe (block C C)
    forall a b. (a -> b) -> a -> b
    $ [Char]
    "duplicate label " [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ Label -> [Char]
    forall a. Show a => a -> [Char]
    show Label
    lbl [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ [Char]
    " in graph"

    -- ---------------------------------------------------------------------------
    -- Graph

    -- | A control-flow graph, which may take any of four shapes (O/O,
    -- O/C, C/O, C/C).  A graph open at the entry has a single,
    -- distinguished, anonymous entry point; if a graph is closed at the
    -- entry, its entry point(s) are supplied by a context.
    type Graph = Graph' LabelMap Block

    -- | @Graph'@ is abstracted over the block type, so that we can build
    -- graphs of annotated blocks for example (Compiler.Hoopl.Dataflow
    -- needs this).
    data Graph' s block (n :: Extensibility -> Extensibility -> Type) e x where
      GNil  :: Graph' s block n O O
      GUnit :: block n O O -> Graph' s block n O O
      GMany :: MaybeO e (block n O C)
            -> Body' s block n
            -> MaybeO x (block n C O)
            -> Graph' s block n e x

    -- -----------------------------------------------------------------------------
    -- Mapping over graphs

    -- | Maps over all nodes in a graph.
    mapGraph :: (forall e x. n e x -> n' e x) -> Graph n e x -> Graph n' e x
    mapGraph :: forall (n :: Extensibility -> Extensibility -> *)
           (n' :: Extensibility -> Extensibility -> *) (e :: Extensibility)
           (x :: Extensibility).
    (forall (e :: Extensibility) (x :: Extensibility). n e x -> n' e x)
    -> Graph n e x -> Graph n' e x
    mapGraph forall (e :: Extensibility) (x :: Extensibility). n e x -> n' e x
    f = (forall a b. (a -> b) -> LabelMap a -> LabelMap b)
    -> (forall (e :: Extensibility) (x :: Extensibility).
        Block n e x -> Block n' e x)
    -> Graph' LabelMap Block n e x
    -> Graph' LabelMap Block n' e x
    forall (s :: * -> *)
           (block :: (Extensibility -> Extensibility -> *)
                     -> Extensibility -> Extensibility -> *)
           (n :: Extensibility -> Extensibility -> *)
           (block' :: (Extensibility -> Extensibility -> *)
                      -> Extensibility -> Extensibility -> *)
           (n' :: Extensibility -> Extensibility -> *) (e :: Extensibility)
           (x :: Extensibility).
    (forall a b. (a -> b) -> s a -> s b)
    -> (forall (e :: Extensibility) (x :: Extensibility).
        block n e x -> block' n' e x)
    -> Graph' s block n e x
    -> Graph' s block' n' e x
    mapGraphBlocks (a -> b) -> LabelMap a -> LabelMap b
    forall a b. (a -> b) -> LabelMap a -> LabelMap b
    mapMap ((forall (e :: Extensibility) (x :: Extensibility). n e x -> n' e x)
    -> Block n e x -> Block n' e x
    forall (n :: Extensibility -> Extensibility -> *)
           (n' :: Extensibility -> Extensibility -> *) (e :: Extensibility)
           (x :: Extensibility).
    (forall (e1 :: Extensibility) (x1 :: Extensibility).
     n e1 x1 -> n' e1 x1)
    -> Block n e x -> Block n' e x
    mapBlock n e1 x1 -> n' e1 x1
    forall (e :: Extensibility) (x :: Extensibility). n e x -> n' e x
    f)

    -- | Function 'mapGraphBlocks' enables a change of representation of blocks,
    -- nodes, or both.  It lifts a polymorphic block transform into a polymorphic
    -- graph transform.  When the block representation stabilizes, a similar
    -- function should be provided for blocks.
    mapGraphBlocks :: forall s block n block' n' e x .
                      (forall a b . (a -> b) -> s a -> s b)
                   -> (forall e x . block n e x -> block' n' e x)
                   -> (Graph' s block n e x -> Graph' s block' n' e x)

    mapGraphBlocks :: forall (s :: * -> *)
           (block :: (Extensibility -> Extensibility -> *)
                     -> Extensibility -> Extensibility -> *)
           (n :: Extensibility -> Extensibility -> *)
           (block' :: (Extensibility -> Extensibility -> *)
                      -> Extensibility -> Extensibility -> *)
           (n' :: Extensibility -> Extensibility -> *) (e :: Extensibility)
           (x :: Extensibility).
    (forall a b. (a -> b) -> s a -> s b)
    -> (forall (e :: Extensibility) (x :: Extensibility).
        block n e x -> block' n' e x)
    -> Graph' s block n e x
    -> Graph' s block' n' e x
    mapGraphBlocks forall a b. (a -> b) -> s a -> s b
    f forall (e :: Extensibility) (x :: Extensibility).
    block n e x -> block' n' e x
    g = Graph' s block n e x -> Graph' s block' n' e x
    map
      where map :: Graph' s block n e x -> Graph' s block' n' e x
            map :: Graph' s block n e x -> Graph' s block' n' e x
    map Graph' s block n e x
    GNil = Graph' s block' n' e x
    Graph' s block' n' 'Open 'Open
    forall (s :: * -> *)
           (block :: (Extensibility -> Extensibility -> *)
                     -> Extensibility -> Extensibility -> *)
           (n :: Extensibility -> Extensibility -> *).
    Graph' s block n 'Open 'Open
    GNil
            map (GUnit block n 'Open 'Open
    b) = block' n' 'Open 'Open -> Graph' s block' n' 'Open 'Open
    forall (block :: (Extensibility -> Extensibility -> *)
                     -> Extensibility -> Extensibility -> *)
           (n :: Extensibility -> Extensibility -> *) (s :: * -> *).
    block n 'Open 'Open -> Graph' s block n 'Open 'Open
    GUnit (block n 'Open 'Open -> block' n' 'Open 'Open
    forall (e :: Extensibility) (x :: Extensibility).
    block n e x -> block' n' e x
    g block n 'Open 'Open
    b)
            map (GMany MaybeO e (block n 'Open C)
    e Body' s block n
    b MaybeO x (block n C 'Open)
    x) = MaybeO e (block' n' 'Open C)
    -> Body' s block' n'
    -> MaybeO x (block' n' C 'Open)
    -> Graph' s block' n' e x
    forall (e :: Extensibility)
           (block :: (Extensibility -> Extensibility -> *)
                     -> Extensibility -> Extensibility -> *)
           (n :: Extensibility -> Extensibility -> *) (s :: * -> *)
           (x :: Extensibility).
    MaybeO e (block n 'Open C)
    -> Body' s block n
    -> MaybeO x (block n C 'Open)
    -> Graph' s block n e x
    GMany ((block n 'Open C -> block' n' 'Open C)
    -> MaybeO e (block n 'Open C) -> MaybeO e (block' n' 'Open C)
    forall a b. (a -> b) -> MaybeO e a -> MaybeO e b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap block n 'Open C -> block' n' 'Open C
    forall (e :: Extensibility) (x :: Extensibility).
    block n e x -> block' n' e x
    g MaybeO e (block n 'Open C)
    e) ((block n C C -> block' n' C C)
    -> Body' s block n -> Body' s block' n'
    forall a b. (a -> b) -> s a -> s b
    f block n C C -> block' n' C C
    forall (e :: Extensibility) (x :: Extensibility).
    block n e x -> block' n' e x
    g Body' s block n
    b) ((block n C 'Open -> block' n' C 'Open)
    -> MaybeO x (block n C 'Open) -> MaybeO x (block' n' C 'Open)
    forall a b. (a -> b) -> MaybeO x a -> MaybeO x b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap block n C 'Open -> block' n' C 'Open
    forall (e :: Extensibility) (x :: Extensibility).
    block n e x -> block' n' e x
    g MaybeO x (block n C 'Open)
    x)

    -- -----------------------------------------------------------------------------
    -- Extracting Labels from graphs

    labelsDefined :: forall block n e x . NonLocal (block n) => Graph' LabelMap block n e x
                  -> LabelSet
    labelsDefined :: forall (block :: (Extensibility -> Extensibility -> *)
                     -> Extensibility -> Extensibility -> *)
           (n :: Extensibility -> Extensibility -> *) (e :: Extensibility)
           (x :: Extensibility).
    NonLocal (block n) =>
    Graph' LabelMap block n e x -> LabelSet
    labelsDefined Graph' LabelMap block n e x
    GNil      = LabelSet
    setEmpty
    labelsDefined (GUnit{}) = LabelSet
    setEmpty
    labelsDefined (GMany MaybeO e (block n 'Open C)
    _ Body' LabelMap block n
    body MaybeO x (block n C 'Open)
    x) = (LabelSet -> Label -> block n C C -> LabelSet)
    -> LabelSet -> Body' LabelMap block n -> LabelSet
    forall t b. (t -> Label -> b -> t) -> t -> LabelMap b -> t
    mapFoldlWithKey LabelSet -> Label -> block n C C -> LabelSet
    forall a. LabelSet -> Label -> a -> LabelSet
    addEntry (MaybeO x (block n C 'Open) -> LabelSet
    exitLabel MaybeO x (block n C 'Open)
    x) Body' LabelMap block n
    body
      where addEntry :: forall a. LabelSet -> Label -> a -> LabelSet
            addEntry :: forall a. LabelSet -> Label -> a -> LabelSet
    addEntry LabelSet
    labels Label
    label a
    _ = Label -> LabelSet -> LabelSet
    setInsert Label
    label LabelSet
    labels
            exitLabel :: MaybeO x (block n C O) -> LabelSet
            exitLabel :: MaybeO x (block n C 'Open) -> LabelSet
    exitLabel MaybeO x (block n C 'Open)
    NothingO  = LabelSet
    setEmpty
            exitLabel (JustO block n C 'Open
    b) = Label -> LabelSet
    setSingleton (block n C 'Open -> Label
    forall (x :: Extensibility). block n C x -> Label
    forall (thing :: Extensibility -> Extensibility -> *)
           (x :: Extensibility).
    NonLocal thing =>
    thing C x -> Label
    entryLabel block n C 'Open
    b)

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

    -- | Returns a list of blocks reachable from the provided Labels in the reverse
    -- postorder.
    --
    -- This is the most important traversal over this data structure.  It drops
    -- unreachable code and puts blocks in an order that is good for solving forward
    -- dataflow problems quickly.  The reverse order is good for solving backward
    -- dataflow problems quickly.  The forward order is also reasonably good for
    -- emitting instructions, except that it will not usually exploit Forrest
    -- Baskett's trick of eliminating the unconditional branch from a loop.  For
    -- that you would need a more serious analysis, probably based on dominators, to
    -- identify loop headers.
    --
    -- For forward analyses we want reverse postorder visitation, consider:
    -- @
    --      A -> [B,C]
    --      B -> D
    --      C -> D
    -- @
    -- Postorder: [D, C, B, A] (or [D, B, C, A])
    -- Reverse postorder: [A, B, C, D] (or [A, C, B, D])
    -- This matters for, e.g., forward analysis, because we want to analyze *both*
    -- B and C before we analyze D.
    revPostorderFrom
      :: forall block.  (NonLocal block)
      => LabelMap (block C C) -> Label -> [block C C]
    revPostorderFrom :: forall (block :: Extensibility -> Extensibility -> *).
    NonLocal block =>
    LabelMap (block C C) -> Label -> [block C C]
    revPostorderFrom LabelMap (block C C)
    graph Label
    start = DfsStack (block C C) -> LabelSet -> [block C C] -> [block C C]
    go DfsStack (block C C)
    start_worklist LabelSet
    setEmpty []
      where
        start_worklist :: DfsStack (block C C)
    start_worklist = Label -> DfsStack (block C C) -> DfsStack (block C C)
    lookup_for_descend Label
    start DfsStack (block C C)
    forall a. DfsStack a
    Nil

        -- To compute the postorder we need to "visit" a block (mark as done) *after*
        -- visiting all its successors. So we need to know whether we already
        -- processed all successors of each block (and @NonLocal@ allows arbitrary
        -- many successors). So we use an explicit stack with an extra bit
        -- of information:
        -- - @ConsTodo@ means to explore the block if it wasn't visited before
        -- - @ConsMark@ means that all successors were already done and we can add
        --   the block to the result.
        --
        -- NOTE: We add blocks to the result list in postorder, but we *prepend*
        -- them (i.e., we use @(:)@), which means that the final list is in reverse
        -- postorder.
        go :: DfsStack (block C C) -> LabelSet -> [block C C] -> [block C C]
        go :: DfsStack (block C C) -> LabelSet -> [block C C] -> [block C C]
    go DfsStack (block C C)
    Nil                      !LabelSet
    _           ![block C C]
    result = [block C C]
    result
        go (ConsMark block C C
    block DfsStack (block C C)
    rest)    !LabelSet
    wip_or_done ![block C C]
    result =
            DfsStack (block C C) -> LabelSet -> [block C C] -> [block C C]
    go DfsStack (block C C)
    rest LabelSet
    wip_or_done (block C C
    block block C C -> [block C C] -> [block C C]
    forall a. a -> [a] -> [a]
    : [block C C]
    result)
        go (ConsTodo block C C
    block DfsStack (block C C)
    rest)    !LabelSet
    wip_or_done ![block C C]
    result
            | block C C -> Label
    forall (x :: Extensibility). block C x -> Label
    forall (thing :: Extensibility -> Extensibility -> *)
           (x :: Extensibility).
    NonLocal thing =>
    thing C x -> Label
    entryLabel block C C
    block Label -> LabelSet -> Bool
    `setMember` LabelSet
    wip_or_done = DfsStack (block C C) -> LabelSet -> [block C C] -> [block C C]
    go DfsStack (block C C)
    rest LabelSet
    wip_or_done [block C C]
    result
            | Bool
    otherwise =
                let new_worklist :: DfsStack (block C C)
    new_worklist =
                        (Label -> DfsStack (block C C) -> DfsStack (block C C))
    -> DfsStack (block C C) -> [Label] -> DfsStack (block C C)
    forall a b. (a -> b -> b) -> b -> [a] -> b
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr Label -> DfsStack (block C C) -> DfsStack (block C C)
    lookup_for_descend
                              (block C C -> DfsStack (block C C) -> DfsStack (block C C)
    forall a. a -> DfsStack a -> DfsStack a
    ConsMark block C C
    block DfsStack (block C C)
    rest)
                              (block C C -> [Label]
    forall (e :: Extensibility). block e C -> [Label]
    forall (thing :: Extensibility -> Extensibility -> *)
           (e :: Extensibility).
    NonLocal thing =>
    thing e C -> [Label]
    successors block C C
    block)
                in DfsStack (block C C) -> LabelSet -> [block C C] -> [block C C]
    go DfsStack (block C C)
    new_worklist (Label -> LabelSet -> LabelSet
    setInsert (block C C -> Label
    forall (x :: Extensibility). block C x -> Label
    forall (thing :: Extensibility -> Extensibility -> *)
           (x :: Extensibility).
    NonLocal thing =>
    thing C x -> Label
    entryLabel block C C
    block) LabelSet
    wip_or_done) [block C C]
    result

        lookup_for_descend :: Label -> DfsStack (block C C) -> DfsStack (block C C)
        lookup_for_descend :: Label -> DfsStack (block C C) -> DfsStack (block C C)
    lookup_for_descend Label
    label DfsStack (block C C)
    wl
          | Just block C C
    b <- Label -> LabelMap (block C C) -> Maybe (block C C)
    forall a. Label -> LabelMap a -> Maybe a
    mapLookup Label
    label LabelMap (block C C)
    graph = block C C -> DfsStack (block C C) -> DfsStack (block C C)
    forall a. a -> DfsStack a -> DfsStack a
    ConsTodo block C C
    b DfsStack (block C C)
    wl
          | Bool
    otherwise =
               [Char] -> DfsStack (block C C)
    forall a. HasCallStack => [Char] -> a
    error ([Char] -> DfsStack (block C C)) -> [Char] -> DfsStack (block C C)
    forall a b. (a -> b) -> a -> b
    $ [Char]
    "Label that doesn't have a block?! " [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ Label -> [Char]
    forall a. Show a => a -> [Char]
    show Label
    label

    data DfsStack a = ConsTodo a (DfsStack a) | ConsMark a (DfsStack a) | Nil