{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DataKinds #-}

module GHC.Wasm.ControlFlow.FromCmm
  ( structuredControl
  )
where

import GHC.Prelude hiding (succ)

import Data.Function
import Data.List (sortBy)
import qualified Data.Tree as Tree

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

import GHC.CmmToAsm.Wasm.Types

import GHC.Platform

import GHC.Utils.Misc
import GHC.Utils.Panic
import GHC.Utils.Outputable ( Outputable, text, (<+>), ppr
                            , pprWithCommas
                            )

import GHC.Wasm.ControlFlow


{-|
Module      : GHC.Wasm.ControlFlow.FromCmm
Description : Translation of (reducible) Cmm control flow to WebAssembly

Code in this module can translate any _reducible_ Cmm control-flow
graph to the structured control flow that is required by WebAssembly.
The algorithm is subtle and is described in detail in a draft paper
to be found at https://www.cs.tufts.edu/~nr/pubs/relooper.pdf.
-}

--------------------- Abstraction of Cmm control flow -----------------------

-- | Abstracts the kind of control flow we understand how to convert.
-- A block can be left in one of four ways:
--
--   * Unconditionally
--
--   * Conditionally on a predicate of type `e`
--
--   * To a location determined by the value of a scrutinee of type `e`
--
--   * Not at all.

data ControlFlow e = Unconditional Label
                   | Conditional e Label Label
                   | Switch { forall e. ControlFlow e -> e
_scrutinee :: e
                            , forall e. ControlFlow e -> BrTableInterval
_range :: BrTableInterval
                            , forall e. ControlFlow e -> [Maybe Label]
_targets :: [Maybe Label] -- from 0
                            , forall e. ControlFlow e -> Maybe Label
_defaultTarget :: Maybe Label
                            }
                   | TailCall e

flowLeaving :: Platform -> CmmBlock -> ControlFlow CmmExpr
flowLeaving :: Platform -> CmmBlock -> ControlFlow CmmExpr
flowLeaving Platform
platform CmmBlock
b =
    case forall (n :: Extensibility -> Extensibility -> *)
       (x :: Extensibility).
Block n x C -> n O C
lastNode CmmBlock
b of
      CmmBranch Label
l -> forall e. Label -> ControlFlow e
Unconditional Label
l
      CmmCondBranch CmmExpr
c Label
t Label
f Maybe Bool
_ -> forall e. e -> Label -> Label -> ControlFlow e
Conditional CmmExpr
c Label
t Label
f
      CmmSwitch CmmExpr
e SwitchTargets
targets ->
          let (Int
offset, [Maybe Label]
target_labels) = SwitchTargets -> (Int, [Maybe Label])
switchTargetsToTable SwitchTargets
targets
              (Integer
lo, Integer
hi) = SwitchTargets -> (Integer, Integer)
switchTargetsRange SwitchTargets
targets
              default_label :: Maybe Label
default_label = SwitchTargets -> Maybe Label
switchTargetsDefault SwitchTargets
targets
              scrutinee :: CmmExpr
scrutinee = Platform -> CmmExpr -> CmmExpr
smartExtend Platform
platform forall a b. (a -> b) -> a -> b
$ Platform -> CmmExpr -> Int -> CmmExpr
smartPlus Platform
platform CmmExpr
e Int
offset
              range :: BrTableInterval
range = Integer -> Integer -> BrTableInterval
inclusiveInterval (Integer
loforall a. Num a => a -> a -> a
+forall a. Integral a => a -> Integer
toInteger Int
offset) (Integer
hiforall a. Num a => a -> a -> a
+forall a. Integral a => a -> Integer
toInteger Int
offset)
          in  forall e.
e
-> BrTableInterval -> [Maybe Label] -> Maybe Label -> ControlFlow e
Switch CmmExpr
scrutinee BrTableInterval
range [Maybe Label]
target_labels Maybe Label
default_label
      CmmCall { cml_cont :: CmmNode O C -> Maybe Label
cml_cont = Maybe Label
Nothing, cml_target :: CmmNode O C -> CmmExpr
cml_target = CmmExpr
e } -> forall e. e -> ControlFlow e
TailCall CmmExpr
e
      CmmNode O C
_ -> forall a. HasCallStack => String -> a
panic String
"flowLeaving: unreachable"

----------------------- Evaluation contexts ------------------------------

-- | The syntactic constructs in which Wasm code may be contained.
-- A list of these constructs represents an evaluation context,
-- which is used to determined what level of `br` instruction
-- reaches a given label.

data ContainingSyntax
    = BlockFollowedBy Label
    | LoopHeadedBy Label
    | IfThenElse (Maybe Label) -- ^ Carries the label that follows `if...end`, if any

matchesFrame :: Label -> ContainingSyntax -> Bool
matchesFrame :: Label -> ContainingSyntax -> Bool
matchesFrame Label
label (BlockFollowedBy Label
l) = Label
label forall a. Eq a => a -> a -> Bool
== Label
l
matchesFrame Label
label (LoopHeadedBy Label
l) = Label
label forall a. Eq a => a -> a -> Bool
== Label
l
matchesFrame Label
label (IfThenElse (Just Label
l)) = Label
label forall a. Eq a => a -> a -> Bool
== Label
l
matchesFrame Label
_ ContainingSyntax
_ = Bool
False

data Context = Context { Context -> [ContainingSyntax]
enclosing :: [ContainingSyntax]
                       , Context -> Maybe Label
fallthrough :: Maybe Label  -- the label can
                                                     -- be reached just by "falling through"
                                                     -- the hole
                       }

instance Outputable Context where
  ppr :: Context -> SDoc
ppr Context
c | Just Label
l <- Context -> Maybe Label
fallthrough Context
c =
                    forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas forall a. Outputable a => a -> SDoc
ppr (Context -> [ContainingSyntax]
enclosing Context
c) forall doc. IsLine doc => doc -> doc -> doc
<+> forall doc. IsLine doc => String -> doc
text String
"fallthrough to" forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr Label
l
        | Bool
otherwise = forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas forall a. Outputable a => a -> SDoc
ppr (Context -> [ContainingSyntax]
enclosing Context
c)

emptyContext :: Context
emptyContext :: Context
emptyContext = [ContainingSyntax] -> Maybe Label -> Context
Context [] forall a. Maybe a
Nothing

inside :: ContainingSyntax -> Context -> Context
withFallthrough :: Context -> Label -> Context

inside :: ContainingSyntax -> Context -> Context
inside ContainingSyntax
frame Context
c = Context
c { enclosing :: [ContainingSyntax]
enclosing = ContainingSyntax
frame forall a. a -> [a] -> [a]
: Context -> [ContainingSyntax]
enclosing Context
c }
withFallthrough :: Context -> Label -> Context
withFallthrough Context
c Label
l = Context
c { fallthrough :: Maybe Label
fallthrough = forall a. a -> Maybe a
Just Label
l }

type CmmActions = Block CmmNode O O

type FT pre post = WasmFunctionType pre post

returns :: FT '[] '[ 'I32]
doesn'tReturn :: FT '[] '[]

returns :: FT '[] '[ 'I32]
returns = forall (pre :: [WasmType]) (post :: [WasmType]).
TypeList pre -> TypeList post -> WasmFunctionType pre post
WasmFunctionType TypeList '[]
TypeListNil (forall (t :: WasmType) (ts :: [WasmType]).
WasmTypeTag t -> TypeList ts -> TypeList (t : ts)
TypeListCons WasmTypeTag 'I32
TagI32 TypeList '[]
TypeListNil)
doesn'tReturn :: FT '[] '[]
doesn'tReturn = forall (pre :: [WasmType]) (post :: [WasmType]).
TypeList pre -> TypeList post -> WasmFunctionType pre post
WasmFunctionType TypeList '[]
TypeListNil TypeList '[]
TypeListNil

emptyPost :: FT pre post -> Bool
emptyPost :: forall (pre :: [WasmType]) (post :: [WasmType]).
FT pre post -> Bool
emptyPost (WasmFunctionType TypeList pre
_ TypeList post
TypeListNil) = Bool
True
emptyPost WasmFunctionType pre post
_ = Bool
False

----------------------- Translation ------------------------------

-- | Convert a Cmm CFG to WebAssembly's structured control flow.

structuredControl :: forall expr stmt m .
                     Applicative m
                  => Platform  -- ^ needed for offset calculation
                  -> (Label -> CmmExpr -> m expr) -- ^ translator for expressions
                  -> (Label -> CmmActions -> m stmt) -- ^ translator for straight-line code
                  -> CmmGraph -- ^ CFG to be translated
                  -> m (WasmControl stmt expr '[] '[ 'I32])
structuredControl :: forall expr stmt (m :: * -> *).
Applicative m =>
Platform
-> (Label -> CmmExpr -> m expr)
-> (Label -> CmmActions -> m stmt)
-> CmmGraph
-> m (WasmControl stmt expr '[] '[ 'I32])
structuredControl Platform
platform Label -> CmmExpr -> m expr
txExpr Label -> CmmActions -> m stmt
txBlock CmmGraph
g =
   forall (post :: [WasmType]).
FT '[] post
-> Tree CmmBlock -> Context -> m (WasmControl stmt expr '[] post)
doTree FT '[] '[ 'I32]
returns Tree CmmBlock
dominatorTree Context
emptyContext
 where
   gwd :: GraphWithDominators CmmNode
   gwd :: GraphWithDominators CmmNode
gwd = forall (node :: Extensibility -> Extensibility -> *).
(NonLocal node, HasDebugCallStack) =>
GenCmmGraph node -> GraphWithDominators node
graphWithDominators CmmGraph
g

   dominatorTree :: Tree.Tree CmmBlock-- Dominator tree in which children are sorted
                                       -- with highest reverse-postorder number first
   dominatorTree :: Tree CmmBlock
dominatorTree = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Label -> CmmBlock
blockLabeled forall a b. (a -> b) -> a -> b
$ Tree Label -> Tree Label
sortTree forall a b. (a -> b) -> a -> b
$ forall (node :: Extensibility -> Extensibility -> *).
GraphWithDominators node -> Tree Label
gwdDominatorTree GraphWithDominators CmmNode
gwd

   doTree     :: FT '[] post -> Tree.Tree CmmBlock -> Context -> m (WasmControl stmt expr '[] post)
   nodeWithin :: forall post .
                 FT '[] post -> CmmBlock -> [Tree.Tree CmmBlock] -> Maybe Label
                                                   -> Context -> m (WasmControl stmt expr '[] post)
   doBranch   :: FT '[] post -> Label -> Label     -> Context -> m (WasmControl stmt expr '[] post)

   doTree :: forall (post :: [WasmType]).
FT '[] post
-> Tree CmmBlock -> Context -> m (WasmControl stmt expr '[] post)
doTree FT '[] post
fty (Tree.Node CmmBlock
x [Tree CmmBlock]
children) Context
context =
       let codeForX :: Context -> m (WasmControl stmt expr '[] post)
codeForX = forall (post :: [WasmType]).
FT '[] post
-> CmmBlock
-> [Tree CmmBlock]
-> Maybe Label
-> Context
-> m (WasmControl stmt expr '[] post)
nodeWithin FT '[] post
fty CmmBlock
x [Tree CmmBlock]
selectedChildren forall a. Maybe a
Nothing
       in  if CmmBlock -> Bool
isLoopHeader CmmBlock
x then
             forall (c :: [WasmType]) (d :: [WasmType]) a b.
WasmFunctionType c d -> WasmControl a b c d -> WasmControl a b c d
WasmLoop FT '[] post
fty forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context -> m (WasmControl stmt expr '[] post)
codeForX Context
loopContext
           else
             Context -> m (WasmControl stmt expr '[] post)
codeForX Context
context
     where selectedChildren :: [Tree CmmBlock]
selectedChildren = case forall (n :: Extensibility -> Extensibility -> *)
       (x :: Extensibility).
Block n x C -> n O C
lastNode CmmBlock
x of
                                CmmSwitch {} -> [Tree CmmBlock]
children
                                   -- N.B. Unlike `if`, translation of Switch uses only labels.
                                CmmNode O C
_ -> forall a. (a -> Bool) -> [a] -> [a]
filter Tree CmmBlock -> Bool
hasMergeRoot [Tree CmmBlock]
children
           loopContext :: Context
loopContext = Label -> ContainingSyntax
LoopHeadedBy (forall (thing :: Extensibility -> Extensibility -> *)
       (x :: Extensibility).
NonLocal thing =>
thing C x -> Label
entryLabel CmmBlock
x) ContainingSyntax -> Context -> Context
`inside` Context
context
           hasMergeRoot :: Tree CmmBlock -> Bool
hasMergeRoot = CmmBlock -> Bool
isMergeNode forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Tree a -> a
Tree.rootLabel

   nodeWithin :: forall (post :: [WasmType]).
FT '[] post
-> CmmBlock
-> [Tree CmmBlock]
-> Maybe Label
-> Context
-> m (WasmControl stmt expr '[] post)
nodeWithin FT '[] post
fty CmmBlock
x (Tree CmmBlock
y_n:[Tree CmmBlock]
ys) (Just Label
zlabel) Context
context =
       forall (c :: [WasmType]) (d :: [WasmType]) a b.
WasmFunctionType c d -> WasmControl a b c d -> WasmControl a b c d
WasmBlock FT '[] post
fty forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (post :: [WasmType]).
FT '[] post
-> CmmBlock
-> [Tree CmmBlock]
-> Maybe Label
-> Context
-> m (WasmControl stmt expr '[] post)
nodeWithin FT '[] post
fty CmmBlock
x (Tree CmmBlock
y_nforall a. a -> [a] -> [a]
:[Tree CmmBlock]
ys) forall a. Maybe a
Nothing Context
context'
     where context' :: Context
context' = Label -> ContainingSyntax
BlockFollowedBy Label
zlabel ContainingSyntax -> Context -> Context
`inside` Context
context
   nodeWithin FT '[] post
fty CmmBlock
x (Tree CmmBlock
y_n:[Tree CmmBlock]
ys) Maybe Label
Nothing Context
context =
       forall (post :: [WasmType]).
FT '[] post
-> CmmBlock
-> [Tree CmmBlock]
-> Maybe Label
-> Context
-> m (WasmControl stmt expr '[] post)
nodeWithin FT '[] '[]
doesn'tReturn CmmBlock
x [Tree CmmBlock]
ys (forall a. a -> Maybe a
Just Label
ylabel) (Context
context Context -> Label -> Context
`withFallthrough` Label
ylabel) forall (m :: * -> *) s e (pre :: [WasmType]) (mid :: [WasmType])
       (post :: [WasmType]).
Applicative m =>
m (WasmControl s e pre mid)
-> m (WasmControl s e mid post) -> m (WasmControl s e pre post)
<<>>
       forall (post :: [WasmType]).
FT '[] post
-> Tree CmmBlock -> Context -> m (WasmControl stmt expr '[] post)
doTree FT '[] post
fty Tree CmmBlock
y_n Context
context
     where ylabel :: Label
ylabel = Tree CmmBlock -> Label
treeEntryLabel Tree CmmBlock
y_n
   nodeWithin FT '[] post
fty CmmBlock
x [] (Just Label
zlabel) Context
context
     | Bool -> Bool
not (CmmBlock -> Bool
generatesIf CmmBlock
x) =
         forall (c :: [WasmType]) (d :: [WasmType]) a b.
WasmFunctionType c d -> WasmControl a b c d -> WasmControl a b c d
WasmBlock FT '[] post
fty forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (post :: [WasmType]).
FT '[] post
-> CmmBlock
-> [Tree CmmBlock]
-> Maybe Label
-> Context
-> m (WasmControl stmt expr '[] post)
nodeWithin FT '[] post
fty CmmBlock
x [] forall a. Maybe a
Nothing Context
context'
     where context' :: Context
context' = Label -> ContainingSyntax
BlockFollowedBy Label
zlabel ContainingSyntax -> Context -> Context
`inside` Context
context
   nodeWithin FT '[] post
fty CmmBlock
x [] Maybe Label
maybeMarks Context
context =
       Context -> m (WasmControl stmt expr '[] post)
translationOfX Context
context
     where xlabel :: Label
xlabel = forall (thing :: Extensibility -> Extensibility -> *)
       (x :: Extensibility).
NonLocal thing =>
thing C x -> Label
entryLabel CmmBlock
x

           translationOfX :: Context -> m (WasmControl stmt expr '[] post)
           translationOfX :: Context -> m (WasmControl stmt expr '[] post)
translationOfX Context
context =
             (forall a b (c :: [WasmType]). a -> WasmControl a b c c
WasmActions forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Label -> CmmActions -> m stmt
txBlock Label
xlabel (CmmBlock -> CmmActions
nodeBody CmmBlock
x)) forall (m :: * -> *) s e (pre :: [WasmType]) (mid :: [WasmType])
       (post :: [WasmType]).
Applicative m =>
m (WasmControl s e pre mid)
-> m (WasmControl s e mid post) -> m (WasmControl s e pre post)
<<>>
             case Platform -> CmmBlock -> ControlFlow CmmExpr
flowLeaving Platform
platform CmmBlock
x of
               Unconditional Label
l -> forall (post :: [WasmType]).
FT '[] post
-> Label -> Label -> Context -> m (WasmControl stmt expr '[] post)
doBranch FT '[] post
fty Label
xlabel Label
l Context
context
               Conditional CmmExpr
e Label
t Label
f ->
                 forall (pre :: [WasmType]) (post :: [WasmType]) e s.
WasmFunctionType pre post
-> e
-> WasmControl s e pre post
-> WasmControl s e pre post
-> WasmControl s e pre post
WasmIf FT '[] post
fty
                        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Label -> CmmExpr -> m expr
txExpr Label
xlabel CmmExpr
e
                        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (post :: [WasmType]).
FT '[] post
-> Label -> Label -> Context -> m (WasmControl stmt expr '[] post)
doBranch FT '[] post
fty Label
xlabel Label
t (Maybe Label -> ContainingSyntax
IfThenElse Maybe Label
maybeMarks ContainingSyntax -> Context -> Context
`inside` Context
context)
                        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (post :: [WasmType]).
FT '[] post
-> Label -> Label -> Context -> m (WasmControl stmt expr '[] post)
doBranch FT '[] post
fty Label
xlabel Label
f (Maybe Label -> ContainingSyntax
IfThenElse Maybe Label
maybeMarks ContainingSyntax -> Context -> Context
`inside` Context
context)
               TailCall CmmExpr
e -> forall b a (c :: [WasmType]) (d :: [WasmType]).
b -> WasmControl a b c d
WasmTailCall forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Label -> CmmExpr -> m expr
txExpr Label
xlabel CmmExpr
e
               Switch CmmExpr
e BrTableInterval
range [Maybe Label]
targets Maybe Label
default' ->
                   forall b a (c :: [WasmType]) (d :: [WasmType]).
b -> BrTableInterval -> [Int] -> Int -> WasmControl a b c d
WasmBrTable forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>  Label -> CmmExpr -> m expr
txExpr Label
xlabel CmmExpr
e
                               forall (m :: * -> *) a b. Functor m => m (a -> b) -> a -> m b
<$~> BrTableInterval
range
                               forall (m :: * -> *) a b. Functor m => m (a -> b) -> a -> m b
<$~> forall a b. (a -> b) -> [a] -> [b]
map Maybe Label -> Int
switchIndex [Maybe Label]
targets
                               forall (m :: * -> *) a b. Functor m => m (a -> b) -> a -> m b
<$~> Maybe Label -> Int
switchIndex Maybe Label
default'
            where switchIndex :: Maybe Label -> Int
                  switchIndex :: Maybe Label -> Int
switchIndex Maybe Label
Nothing = Int
0 -- arbitrary; GHC won't go here
                  switchIndex (Just Label
lbl) = Label -> [ContainingSyntax] -> Int
index Label
lbl (Context -> [ContainingSyntax]
enclosing Context
context)

   doBranch :: forall (post :: [WasmType]).
FT '[] post
-> Label -> Label -> Context -> m (WasmControl stmt expr '[] post)
doBranch FT '[] post
fty Label
from Label
to Context
context
      | Label
to forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Context -> Maybe Label
fallthrough Context
context Bool -> Bool -> Bool
&& forall (pre :: [WasmType]) (post :: [WasmType]).
FT pre post -> Bool
emptyPost FT '[] post
fty = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b (c :: [WasmType]) (d :: [WasmType]). WasmControl a b c d
WasmFallthrough
                -- optimization: `br` is not needed, but it typechecks
                -- only if nothing is expected to be left on the stack

      | Label -> Label -> Bool
isBackward Label
from Label
to = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b (c :: [WasmType]) (d :: [WasmType]).
Int -> WasmControl a b c d
WasmBr Int
i -- continue
      | Label -> Bool
isMergeLabel Label
to = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b (c :: [WasmType]) (d :: [WasmType]).
Int -> WasmControl a b c d
WasmBr Int
i -- exit
      | Bool
otherwise = forall (post :: [WasmType]).
FT '[] post
-> Tree CmmBlock -> Context -> m (WasmControl stmt expr '[] post)
doTree FT '[] post
fty (Label -> Tree CmmBlock
subtreeAt Label
to) Context
context -- inline the code here
     where i :: Int
i = Label -> [ContainingSyntax] -> Int
index Label
to (Context -> [ContainingSyntax]
enclosing Context
context)

   generatesIf :: CmmBlock -> Bool
   generatesIf :: CmmBlock -> Bool
generatesIf CmmBlock
x = case Platform -> CmmBlock -> ControlFlow CmmExpr
flowLeaving Platform
platform CmmBlock
x of Conditional {} -> Bool
True
                                                  ControlFlow CmmExpr
_ -> Bool
False

   ---- everything else is utility functions

   treeEntryLabel :: Tree.Tree CmmBlock -> Label
   treeEntryLabel :: Tree CmmBlock -> Label
treeEntryLabel = forall (thing :: Extensibility -> Extensibility -> *)
       (x :: Extensibility).
NonLocal thing =>
thing C x -> Label
entryLabel forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Tree a -> a
Tree.rootLabel

   sortTree :: Tree.Tree Label -> Tree.Tree Label
    -- Sort highest rpnum first
   sortTree :: Tree Label -> Tree Label
sortTree (Tree.Node Label
label [Tree Label]
children) =
      forall a. a -> [Tree a] -> Tree a
Tree.Node Label
label forall a b. (a -> b) -> a -> b
$ forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Ord a => a -> a -> Ordering
compare forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Label -> RPNum
rpnum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Tree a -> a
Tree.rootLabel)) forall a b. (a -> b) -> a -> b
$
                        forall a b. (a -> b) -> [a] -> [b]
map Tree Label -> Tree Label
sortTree [Tree Label]
children

   subtreeAt :: Label -> Tree.Tree CmmBlock
   blockLabeled :: Label -> CmmBlock
   rpnum :: Label -> RPNum-- reverse postorder number of the labeled block
   isMergeLabel :: Label -> Bool
   isMergeNode :: CmmBlock -> Bool
   isLoopHeader :: CmmBlock -> Bool-- identify loop headers
    -- all nodes whose immediate dominator is the given block.
     -- They are produced with the largest RP number first,
     -- so the largest RP number is pushed on the context first.
   dominates :: Label -> Label -> Bool
    -- Domination relation (not just immediate domination)

   blockmap :: LabelMap CmmBlock
   GMany MaybeO C (Block CmmNode O C)
NothingO LabelMap CmmBlock
blockmap MaybeO C (Block CmmNode C O)
NothingO = forall (n :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> Graph n C C
g_graph CmmGraph
g

   blockLabeled :: Label -> CmmBlock
blockLabeled Label
l = forall a. HasDebugCallStack => Label -> LabelMap a -> a
findLabelIn Label
l LabelMap CmmBlock
blockmap

   rpblocks :: [CmmBlock]
   rpblocks :: [CmmBlock]
rpblocks = forall (block :: Extensibility -> Extensibility -> *).
NonLocal block =>
LabelMap (block C C) -> Label -> [block C C]
revPostorderFrom LabelMap CmmBlock
blockmap (forall (n :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> Label
g_entry CmmGraph
g)

   foldEdges :: forall a . (Label -> Label -> a -> a) -> a -> a
   foldEdges :: forall a. (Label -> Label -> a -> a) -> a -> a
foldEdges Label -> Label -> a -> a
f a
a =
     forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\a
a (Label
from, Label
to) -> Label -> Label -> a -> a
f Label
from Label
to a
a)
           a
a
           [(forall (thing :: Extensibility -> Extensibility -> *)
       (x :: Extensibility).
NonLocal thing =>
thing C x -> Label
entryLabel CmmBlock
from, Label
to) | CmmBlock
from <- [CmmBlock]
rpblocks, Label
to <- forall (thing :: Extensibility -> Extensibility -> *)
       (e :: Extensibility).
NonLocal thing =>
thing e C -> [Label]
successors CmmBlock
from]

   isMergeLabel :: Label -> Bool
isMergeLabel Label
l = forall set. IsSet set => ElemOf set -> set -> Bool
setMember Label
l LabelSet
mergeBlockLabels
   isMergeNode :: CmmBlock -> Bool
isMergeNode = Label -> Bool
isMergeLabel forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (thing :: Extensibility -> Extensibility -> *)
       (x :: Extensibility).
NonLocal thing =>
thing C x -> Label
entryLabel

   isBackward :: Label -> Label -> Bool
   isBackward :: Label -> Label -> Bool
isBackward Label
from Label
to = Label -> RPNum
rpnum Label
to forall a. Ord a => a -> a -> Bool
<= Label -> RPNum
rpnum Label
from -- self-edge counts as a backward edge

   subtreeAt :: Label -> Tree CmmBlock
subtreeAt Label
label = forall a. HasDebugCallStack => Label -> LabelMap a -> a
findLabelIn Label
label LabelMap (Tree CmmBlock)
subtrees
   subtrees :: LabelMap (Tree.Tree CmmBlock)
   subtrees :: LabelMap (Tree CmmBlock)
subtrees = forall {map :: * -> *}
       {thing :: Extensibility -> Extensibility -> *}
       {x :: Extensibility}.
(KeyOf map ~ Label, IsMap map, NonLocal thing) =>
map (Tree (thing C x))
-> Tree (thing C x) -> map (Tree (thing C x))
addSubtree forall (map :: * -> *) a. IsMap map => map a
mapEmpty Tree CmmBlock
dominatorTree
     where addSubtree :: map (Tree (thing C x))
-> Tree (thing C x) -> map (Tree (thing C x))
addSubtree map (Tree (thing C x))
map t :: Tree (thing C x)
t@(Tree.Node thing C x
root [Tree (thing C x)]
children) =
               forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl map (Tree (thing C x))
-> Tree (thing C x) -> map (Tree (thing C x))
addSubtree (forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert (forall (thing :: Extensibility -> Extensibility -> *)
       (x :: Extensibility).
NonLocal thing =>
thing C x -> Label
entryLabel thing C x
root) Tree (thing C x)
t map (Tree (thing C x))
map) [Tree (thing C x)]
children

   mergeBlockLabels :: LabelSet
   -- N.B. A block is a merge node if it is where control flow merges.
   -- That means it is entered by multiple control-flow edges, _except_
   -- back edges don't count.  There must be multiple paths that enter the
   -- block _without_ passing through the block itself.
   mergeBlockLabels :: LabelSet
mergeBlockLabels =
       forall set. IsSet set => [ElemOf set] -> set
setFromList [forall (thing :: Extensibility -> Extensibility -> *)
       (x :: Extensibility).
NonLocal thing =>
thing C x -> Label
entryLabel CmmBlock
n | CmmBlock
n <- [CmmBlock]
rpblocks, forall {a}. [a] -> Bool
big (Label -> [Label]
forwardPreds (forall (thing :: Extensibility -> Extensibility -> *)
       (x :: Extensibility).
NonLocal thing =>
thing C x -> Label
entryLabel CmmBlock
n))]
    where big :: [a] -> Bool
big [] = Bool
False
          big [a
_] = Bool
False
          big (a
_ : a
_ : [a]
_) = Bool
True

          forwardPreds :: Label -> [Label] -- reachable predecessors of reachable blocks,
                                           -- via forward edges only
          forwardPreds :: Label -> [Label]
forwardPreds = \Label
l -> forall (map :: * -> *) a. IsMap map => a -> KeyOf map -> map a -> a
mapFindWithDefault [] Label
l LabelMap [Label]
predmap
              where predmap :: LabelMap [Label]
                    predmap :: LabelMap [Label]
predmap = forall a. (Label -> Label -> a -> a) -> a -> a
foldEdges forall {map :: * -> *}.
(KeyOf map ~ Label, IsMap map) =>
Label -> Label -> map [Label] -> map [Label]
addForwardEdge forall (map :: * -> *) a. IsMap map => map a
mapEmpty
                    addForwardEdge :: Label -> Label -> map [Label] -> map [Label]
addForwardEdge Label
from Label
to map [Label]
pm
                        | Label -> Label -> Bool
isBackward Label
from Label
to = map [Label]
pm
                        | Bool
otherwise = forall (map :: * -> *) a.
IsMap map =>
([a] -> [a]) -> KeyOf map -> map [a] -> map [a]
addToList (Label
from forall a. a -> [a] -> [a]
:) Label
to map [Label]
pm

   isLoopHeader :: CmmBlock -> Bool
isLoopHeader = Label -> Bool
isHeaderLabel forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (thing :: Extensibility -> Extensibility -> *)
       (x :: Extensibility).
NonLocal thing =>
thing C x -> Label
entryLabel
   isHeaderLabel :: ElemOf LabelSet -> Bool
isHeaderLabel = (forall set. IsSet set => ElemOf set -> set -> Bool
`setMember` LabelSet
headers)  -- loop headers
      where headers :: LabelSet
            headers :: LabelSet
headers = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall {set} {thing :: Extensibility -> Extensibility -> *}.
(ElemOf set ~ Label, IsSet set, NonLocal thing) =>
thing C C -> set
headersPointedTo LabelMap CmmBlock
blockmap
            headersPointedTo :: thing C C -> set
headersPointedTo thing C C
block =
                forall set. IsSet set => [ElemOf set] -> set
setFromList [Label
label | Label
label <- forall (thing :: Extensibility -> Extensibility -> *)
       (e :: Extensibility).
NonLocal thing =>
thing e C -> [Label]
successors thing C C
block,
                                              Label -> Label -> Bool
dominates Label
label (forall (thing :: Extensibility -> Extensibility -> *)
       (x :: Extensibility).
NonLocal thing =>
thing C x -> Label
entryLabel thing C C
block)]

   index :: Label -> [ContainingSyntax] -> Int
   index :: Label -> [ContainingSyntax] -> Int
index Label
_ [] = forall a. HasCallStack => String -> a
panic String
"destination label not in evaluation context"
   index Label
label (ContainingSyntax
frame : [ContainingSyntax]
context)
       | Label
label Label -> ContainingSyntax -> Bool
`matchesFrame` ContainingSyntax
frame = Int
0
       | Bool
otherwise = Int
1 forall a. Num a => a -> a -> a
+ Label -> [ContainingSyntax] -> Int
index Label
label [ContainingSyntax]
context

   rpnum :: Label -> RPNum
rpnum = forall (node :: Extensibility -> Extensibility -> *).
HasDebugCallStack =>
GraphWithDominators node -> Label -> RPNum
gwdRPNumber GraphWithDominators CmmNode
gwd
   dominates :: Label -> Label -> Bool
dominates Label
lbl Label
blockname =
       Label
lbl forall a. Eq a => a -> a -> Bool
== Label
blockname Bool -> Bool -> Bool
|| Label -> DominatorSet -> Bool
dominatorsMember Label
lbl (forall (node :: Extensibility -> Extensibility -> *).
HasDebugCallStack =>
GraphWithDominators node -> Label -> DominatorSet
gwdDominatorsOf GraphWithDominators CmmNode
gwd Label
blockname)



nodeBody :: CmmBlock -> CmmActions
nodeBody :: CmmBlock -> CmmActions
nodeBody (BlockCC CmmNode C O
_first CmmActions
middle CmmNode O C
_last) = CmmActions
middle

-- | A CmmSwitch scrutinee may have any width, but a br_table operand
-- must be exactly word sized, hence the extension here. (#22871)
smartExtend :: Platform -> CmmExpr -> CmmExpr
smartExtend :: Platform -> CmmExpr -> CmmExpr
smartExtend Platform
p CmmExpr
e | Width
w0 forall a. Eq a => a -> a -> Bool
== Width
w1 = CmmExpr
e
                | Bool
otherwise = MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (Width -> Width -> MachOp
MO_UU_Conv Width
w0 Width
w1) [CmmExpr
e]
  where
    w0 :: Width
w0 = Platform -> CmmExpr -> Width
cmmExprWidth Platform
p CmmExpr
e
    w1 :: Width
w1 = Platform -> Width
wordWidth Platform
p

smartPlus :: Platform -> CmmExpr -> Int -> CmmExpr
smartPlus :: Platform -> CmmExpr -> Int -> CmmExpr
smartPlus Platform
_ CmmExpr
e Int
0 = CmmExpr
e
smartPlus Platform
platform CmmExpr
e Int
k =
    MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (Width -> MachOp
MO_Add Width
width) [CmmExpr
e, CmmLit -> CmmExpr
CmmLit (Integer -> Width -> CmmLit
CmmInt (forall a. Integral a => a -> Integer
toInteger Int
k) Width
width)]
  where width :: Width
width = Platform -> CmmExpr -> Width
cmmExprWidth Platform
platform CmmExpr
e

addToList :: (IsMap map) => ([a] -> [a]) -> KeyOf map -> map [a] -> map [a]
addToList :: forall (map :: * -> *) a.
IsMap map =>
([a] -> [a]) -> KeyOf map -> map [a] -> map [a]
addToList [a] -> [a]
consx = forall (map :: * -> *) a.
IsMap map =>
(Maybe a -> Maybe a) -> KeyOf map -> map a -> map a
mapAlter Maybe [a] -> Maybe [a]
add
    where add :: Maybe [a] -> Maybe [a]
add Maybe [a]
Nothing = forall a. a -> Maybe a
Just ([a] -> [a]
consx [])
          add (Just [a]
xs) = forall a. a -> Maybe a
Just ([a] -> [a]
consx [a]
xs)

------------------------------------------------------------------
--- everything below here is for diagnostics in case of panic

instance Outputable ContainingSyntax where
    ppr :: ContainingSyntax -> SDoc
ppr (BlockFollowedBy Label
l) = forall doc. IsLine doc => String -> doc
text String
"node" forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr Label
l
    ppr (LoopHeadedBy Label
l) = forall doc. IsLine doc => String -> doc
text String
"loop" forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr Label
l
    ppr (IfThenElse Maybe Label
l) = forall doc. IsLine doc => String -> doc
text String
"if-then-else" forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr Maybe Label
l

findLabelIn :: HasDebugCallStack => Label -> LabelMap a -> a
findLabelIn :: forall a. HasDebugCallStack => Label -> LabelMap a -> a
findLabelIn Label
lbl = forall (map :: * -> *) a. IsMap map => a -> KeyOf map -> map a -> a
mapFindWithDefault a
failed Label
lbl
  where failed :: a
failed =
            forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"label not found in control-flow graph" (forall a. Outputable a => a -> SDoc
ppr Label
lbl)


infixl 4 <$~>
(<$~>) :: Functor m => m (a -> b) -> a -> m b
<$~> :: forall (m :: * -> *) a b. Functor m => m (a -> b) -> a -> m b
(<$~>) m (a -> b)
f a
x = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a -> b) -> a -> b
$ a
x) m (a -> b)
f

(<<>>) :: forall m s e pre mid post
       . Applicative m
       => m (WasmControl s e pre mid)
       -> m (WasmControl s e mid post)
       -> m (WasmControl s e pre post)
<<>> :: forall (m :: * -> *) s e (pre :: [WasmType]) (mid :: [WasmType])
       (post :: [WasmType]).
Applicative m =>
m (WasmControl s e pre mid)
-> m (WasmControl s e mid post) -> m (WasmControl s e pre post)
(<<>>) = forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 forall s e (pre :: [WasmType]) (mid :: [WasmType])
       (post :: [WasmType]).
WasmControl s e pre mid
-> WasmControl s e mid post -> WasmControl s e pre post
(<>)