{-# 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