{-# 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.Dominators
import GHC.Cmm.Dataflow.Graph
import GHC.Cmm.Dataflow.Label
import GHC.Cmm.Reducibility
import GHC.Cmm.Switch

import GHC.CmmToAsm.Wasm.Types

import GHC.Platform
import GHC.Types.Unique.Supply
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 CmmBlock -> CmmNode O C
forall (n :: Extensibility -> Extensibility -> *)
       (x :: Extensibility).
Block n x C -> n O C
lastNode CmmBlock
b of
      CmmBranch Label
l -> Label -> ControlFlow CmmExpr
forall e. Label -> ControlFlow e
Unconditional Label
l
      CmmCondBranch CmmExpr
c Label
t Label
f Maybe Bool
_ -> CmmExpr -> Label -> Label -> ControlFlow CmmExpr
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 (CmmExpr -> CmmExpr) -> CmmExpr -> CmmExpr
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
loInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
offset) (Integer
hiInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
offset)
          in  CmmExpr
-> BrTableInterval
-> [Maybe Label]
-> Maybe Label
-> ControlFlow CmmExpr
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_target :: CmmNode O C -> CmmExpr
cml_target = CmmExpr
e } -> CmmExpr -> ControlFlow CmmExpr
forall e. e -> ControlFlow e
TailCall CmmExpr
e
      CmmNode O C
_ -> String -> ControlFlow CmmExpr
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 Label -> Label -> Bool
forall a. Eq a => a -> a -> Bool
== Label
l
matchesFrame Label
label (LoopHeadedBy Label
l) = Label
label Label -> Label -> Bool
forall a. Eq a => a -> a -> Bool
== Label
l
matchesFrame Label
label (IfThenElse (Just Label
l)) = Label
label Label -> Label -> Bool
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 =
                    (ContainingSyntax -> SDoc) -> [ContainingSyntax] -> SDoc
forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas ContainingSyntax -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Context -> [ContainingSyntax]
enclosing Context
c) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"fallthrough to" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Label -> SDoc
forall a. Outputable a => a -> SDoc
ppr Label
l
        | Bool
otherwise = (ContainingSyntax -> SDoc) -> [ContainingSyntax] -> SDoc
forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas ContainingSyntax -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Context -> [ContainingSyntax]
enclosing Context
c)

emptyContext :: Context
emptyContext :: Context
emptyContext = [ContainingSyntax] -> Maybe Label -> Context
Context [] Maybe Label
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 = frame : enclosing c }
withFallthrough :: Context -> Label -> Context
withFallthrough Context
c Label
l = Context
c { fallthrough = Just l }

type CmmActions = Block CmmNode O O

type FT pre post = WasmFunctionType pre post

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

returns :: FT '[] '[ 'I32]
returns = TypeList '[] -> TypeList '[ 'I32] -> FT '[] '[ 'I32]
forall (pre :: [WasmType]) (post :: [WasmType]).
TypeList pre -> TypeList post -> WasmFunctionType pre post
WasmFunctionType TypeList '[]
TypeListNil (WasmTypeTag 'I32 -> TypeList '[] -> TypeList '[ 'I32]
forall (t :: WasmType) (ts :: [WasmType]).
WasmTypeTag t -> TypeList ts -> TypeList (t : ts)
TypeListCons WasmTypeTag 'I32
TagI32 TypeList '[]
TypeListNil)
doesn'tReturn :: FT '[] '[]
doesn'tReturn = TypeList '[] -> TypeList '[] -> FT '[] '[]
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
                  -> UniqSupply
                  -> (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
-> UniqSupply
-> (Label -> CmmExpr -> m expr)
-> (Label -> CmmActions -> m stmt)
-> CmmGraph
-> m (WasmControl stmt expr '[] '[ 'I32])
structuredControl Platform
platform UniqSupply
us Label -> CmmExpr -> m expr
txExpr Label -> CmmActions -> m stmt
txBlock CmmGraph
g' =
   FT '[] '[ 'I32]
-> Tree CmmBlock
-> Context
-> m (WasmControl stmt expr '[] '[ 'I32])
forall (post :: [WasmType]).
FT '[] post
-> Tree CmmBlock -> Context -> m (WasmControl stmt expr '[] post)
doTree FT '[] '[ 'I32]
returns Tree CmmBlock
dominatorTree Context
emptyContext
 where
   g :: CmmGraph
   g :: CmmGraph
g = GraphWithDominators CmmNode -> CmmGraph
forall (node :: Extensibility -> Extensibility -> *).
GraphWithDominators node -> GenCmmGraph node
gwd_graph GraphWithDominators CmmNode
gwd

   gwd :: GraphWithDominators CmmNode
   gwd :: GraphWithDominators CmmNode
gwd = UniqSupply
-> UniqSM (GraphWithDominators CmmNode)
-> GraphWithDominators CmmNode
forall a. UniqSupply -> UniqSM a -> a
initUs_ UniqSupply
us (UniqSM (GraphWithDominators CmmNode)
 -> GraphWithDominators CmmNode)
-> UniqSM (GraphWithDominators CmmNode)
-> GraphWithDominators CmmNode
forall a b. (a -> b) -> a -> b
$ GraphWithDominators CmmNode -> UniqSM (GraphWithDominators CmmNode)
asReducible (GraphWithDominators CmmNode
 -> UniqSM (GraphWithDominators CmmNode))
-> GraphWithDominators CmmNode
-> UniqSM (GraphWithDominators CmmNode)
forall a b. (a -> b) -> a -> b
$ CmmGraph -> GraphWithDominators CmmNode
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 = (Label -> CmmBlock) -> Tree Label -> Tree CmmBlock
forall a b. (a -> b) -> Tree a -> Tree b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Label -> CmmBlock
blockLabeled (Tree Label -> Tree CmmBlock) -> Tree Label -> Tree CmmBlock
forall a b. (a -> b) -> a -> b
$ Tree Label -> Tree Label
sortTree (Tree Label -> Tree Label) -> Tree Label -> Tree Label
forall a b. (a -> b) -> a -> b
$ GraphWithDominators CmmNode -> Tree Label
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 = FT '[] post
-> CmmBlock
-> [Tree CmmBlock]
-> Maybe Label
-> Context
-> m (WasmControl stmt expr '[] post)
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 Maybe Label
forall a. Maybe a
Nothing
       in  if CmmBlock -> Bool
isLoopHeader CmmBlock
x then
             FT '[] post
-> WasmControl stmt expr '[] post -> WasmControl stmt expr '[] post
forall (c :: [WasmType]) (d :: [WasmType]) a b.
WasmFunctionType c d -> WasmControl a b c d -> WasmControl a b c d
WasmLoop FT '[] post
fty (WasmControl stmt expr '[] post -> WasmControl stmt expr '[] post)
-> m (WasmControl stmt expr '[] post)
-> m (WasmControl stmt expr '[] post)
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 CmmBlock -> CmmNode O C
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
_ -> (Tree CmmBlock -> Bool) -> [Tree CmmBlock] -> [Tree CmmBlock]
forall a. (a -> Bool) -> [a] -> [a]
filter Tree CmmBlock -> Bool
hasMergeRoot [Tree CmmBlock]
children
           loopContext :: Context
loopContext = Label -> ContainingSyntax
LoopHeadedBy (CmmBlock -> Label
forall (x :: Extensibility). Block CmmNode C x -> Label
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 (CmmBlock -> Bool)
-> (Tree CmmBlock -> CmmBlock) -> Tree CmmBlock -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree CmmBlock -> CmmBlock
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 =
       FT '[] post
-> WasmControl stmt expr '[] post -> WasmControl stmt expr '[] post
forall (c :: [WasmType]) (d :: [WasmType]) a b.
WasmFunctionType c d -> WasmControl a b c d -> WasmControl a b c d
WasmBlock FT '[] post
fty (WasmControl stmt expr '[] post -> WasmControl stmt expr '[] post)
-> m (WasmControl stmt expr '[] post)
-> m (WasmControl stmt expr '[] post)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FT '[] post
-> CmmBlock
-> [Tree CmmBlock]
-> Maybe Label
-> Context
-> m (WasmControl stmt expr '[] post)
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_nTree CmmBlock -> [Tree CmmBlock] -> [Tree CmmBlock]
forall a. a -> [a] -> [a]
:[Tree CmmBlock]
ys) Maybe Label
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 =
       FT '[] '[]
-> CmmBlock
-> [Tree CmmBlock]
-> Maybe Label
-> Context
-> m (WasmControl stmt expr '[] '[])
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 (Label -> Maybe Label
forall a. a -> Maybe a
Just Label
ylabel) (Context
context Context -> Label -> Context
`withFallthrough` Label
ylabel) m (WasmControl stmt expr '[] '[])
-> m (WasmControl stmt expr '[] post)
-> m (WasmControl stmt expr '[] 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)
<<>>
       FT '[] post
-> Tree CmmBlock -> Context -> m (WasmControl stmt expr '[] 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) =
         FT '[] post
-> WasmControl stmt expr '[] post -> WasmControl stmt expr '[] post
forall (c :: [WasmType]) (d :: [WasmType]) a b.
WasmFunctionType c d -> WasmControl a b c d -> WasmControl a b c d
WasmBlock FT '[] post
fty (WasmControl stmt expr '[] post -> WasmControl stmt expr '[] post)
-> m (WasmControl stmt expr '[] post)
-> m (WasmControl stmt expr '[] post)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FT '[] post
-> CmmBlock
-> [Tree CmmBlock]
-> Maybe Label
-> Context
-> m (WasmControl stmt expr '[] post)
forall (post :: [WasmType]).
FT '[] post
-> CmmBlock
-> [Tree CmmBlock]
-> Maybe Label
-> Context
-> m (WasmControl stmt expr '[] post)
nodeWithin FT '[] post
fty CmmBlock
x [] Maybe Label
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 = CmmBlock -> Label
forall (x :: Extensibility). Block CmmNode C x -> Label
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 =
             (stmt -> WasmControl stmt expr '[] '[]
forall a b (c :: [WasmType]). a -> WasmControl a b c c
WasmActions (stmt -> WasmControl stmt expr '[] '[])
-> m stmt -> m (WasmControl stmt expr '[] '[])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Label -> CmmActions -> m stmt
txBlock Label
xlabel (CmmBlock -> CmmActions
nodeBody CmmBlock
x)) m (WasmControl stmt expr '[] '[])
-> m (WasmControl stmt expr '[] post)
-> m (WasmControl stmt expr '[] 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)
<<>>
             case Platform -> CmmBlock -> ControlFlow CmmExpr
flowLeaving Platform
platform CmmBlock
x of
               Unconditional Label
l -> FT '[] post
-> Label -> Label -> Context -> m (WasmControl stmt expr '[] post)
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 ->
                 FT '[] post
-> expr
-> WasmControl stmt expr '[] post
-> WasmControl stmt expr '[] post
-> WasmControl stmt expr '[] post
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
                        (expr
 -> WasmControl stmt expr '[] post
 -> WasmControl stmt expr '[] post
 -> WasmControl stmt expr '[] post)
-> m expr
-> m (WasmControl stmt expr '[] post
      -> WasmControl stmt expr '[] post
      -> WasmControl stmt expr '[] post)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Label -> CmmExpr -> m expr
txExpr Label
xlabel CmmExpr
e
                        m (WasmControl stmt expr '[] post
   -> WasmControl stmt expr '[] post
   -> WasmControl stmt expr '[] post)
-> m (WasmControl stmt expr '[] post)
-> m (WasmControl stmt expr '[] post
      -> WasmControl stmt expr '[] post)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FT '[] post
-> Label -> Label -> Context -> m (WasmControl stmt expr '[] post)
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)
                        m (WasmControl stmt expr '[] post
   -> WasmControl stmt expr '[] post)
-> m (WasmControl stmt expr '[] post)
-> m (WasmControl stmt expr '[] post)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FT '[] post
-> Label -> Label -> Context -> m (WasmControl stmt expr '[] post)
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 -> expr -> WasmControl stmt expr '[] post
forall b a (c :: [WasmType]) (d :: [WasmType]).
b -> WasmControl a b c d
WasmTailCall (expr -> WasmControl stmt expr '[] post)
-> m expr -> m (WasmControl stmt expr '[] post)
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' ->
                   expr
-> BrTableInterval
-> [Int]
-> Int
-> WasmControl stmt expr '[] post
forall b a (c :: [WasmType]) (d :: [WasmType]).
b -> BrTableInterval -> [Int] -> Int -> WasmControl a b c d
WasmBrTable (expr
 -> BrTableInterval
 -> [Int]
 -> Int
 -> WasmControl stmt expr '[] post)
-> m expr
-> m (BrTableInterval
      -> [Int] -> Int -> WasmControl stmt expr '[] post)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>  Label -> CmmExpr -> m expr
txExpr Label
xlabel CmmExpr
e
                               m (BrTableInterval
   -> [Int] -> Int -> WasmControl stmt expr '[] post)
-> BrTableInterval
-> m ([Int] -> Int -> WasmControl stmt expr '[] post)
forall (m :: * -> *) a b. Functor m => m (a -> b) -> a -> m b
<$~> BrTableInterval
range
                               m ([Int] -> Int -> WasmControl stmt expr '[] post)
-> [Int] -> m (Int -> WasmControl stmt expr '[] post)
forall (m :: * -> *) a b. Functor m => m (a -> b) -> a -> m b
<$~> (Maybe Label -> Int) -> [Maybe Label] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Maybe Label -> Int
switchIndex [Maybe Label]
targets
                               m (Int -> WasmControl stmt expr '[] post)
-> Int -> m (WasmControl stmt expr '[] post)
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 Label -> Maybe Label -> Bool
forall a. Eq a => a -> Maybe a -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Context -> Maybe Label
fallthrough Context
context Bool -> Bool -> Bool
&& FT '[] post -> Bool
forall (pre :: [WasmType]) (post :: [WasmType]).
FT pre post -> Bool
emptyPost FT '[] post
fty = WasmControl stmt expr '[] post
-> m (WasmControl stmt expr '[] post)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure WasmControl stmt expr '[] post
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 = WasmControl stmt expr '[] post
-> m (WasmControl stmt expr '[] post)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (WasmControl stmt expr '[] post
 -> m (WasmControl stmt expr '[] post))
-> WasmControl stmt expr '[] post
-> m (WasmControl stmt expr '[] post)
forall a b. (a -> b) -> a -> b
$ Int -> WasmControl stmt expr '[] post
forall a b (c :: [WasmType]) (d :: [WasmType]).
Int -> WasmControl a b c d
WasmBr Int
i -- continue
      | Label -> Bool
isMergeLabel Label
to = WasmControl stmt expr '[] post
-> m (WasmControl stmt expr '[] post)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (WasmControl stmt expr '[] post
 -> m (WasmControl stmt expr '[] post))
-> WasmControl stmt expr '[] post
-> m (WasmControl stmt expr '[] post)
forall a b. (a -> b) -> a -> b
$ Int -> WasmControl stmt expr '[] post
forall a b (c :: [WasmType]) (d :: [WasmType]).
Int -> WasmControl a b c d
WasmBr Int
i -- exit
      | Bool
otherwise = FT '[] post
-> Tree CmmBlock -> Context -> m (WasmControl stmt expr '[] post)
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 = CmmBlock -> Label
forall (x :: Extensibility). Block CmmNode C x -> Label
forall (thing :: Extensibility -> Extensibility -> *)
       (x :: Extensibility).
NonLocal thing =>
thing C x -> Label
entryLabel (CmmBlock -> Label)
-> (Tree CmmBlock -> CmmBlock) -> Tree CmmBlock -> Label
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree CmmBlock -> CmmBlock
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) =
      Label -> [Tree Label] -> Tree Label
forall a. a -> [Tree a] -> Tree a
Tree.Node Label
label ([Tree Label] -> Tree Label) -> [Tree Label] -> Tree Label
forall a b. (a -> b) -> a -> b
$ (Tree Label -> Tree Label -> Ordering)
-> [Tree Label] -> [Tree Label]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((RPNum -> RPNum -> Ordering) -> RPNum -> RPNum -> Ordering
forall a b c. (a -> b -> c) -> b -> a -> c
flip RPNum -> RPNum -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (RPNum -> RPNum -> Ordering)
-> (Tree Label -> RPNum) -> Tree Label -> Tree Label -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Label -> RPNum
rpnum (Label -> RPNum) -> (Tree Label -> Label) -> Tree Label -> RPNum
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree Label -> Label
forall a. Tree a -> a
Tree.rootLabel)) ([Tree Label] -> [Tree Label]) -> [Tree Label] -> [Tree Label]
forall a b. (a -> b) -> a -> b
$
                        (Tree Label -> Tree Label) -> [Tree Label] -> [Tree Label]
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 = CmmGraph -> Graph' Block CmmNode C C
forall (n :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> Graph n C C
g_graph CmmGraph
g

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

   rpblocks :: [CmmBlock]
   rpblocks :: [CmmBlock]
rpblocks = LabelMap CmmBlock -> Label -> [CmmBlock]
forall (block :: Extensibility -> Extensibility -> *).
NonLocal block =>
LabelMap (block C C) -> Label -> [block C C]
revPostorderFrom LabelMap CmmBlock
blockmap (CmmGraph -> Label
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 =
     (a -> (Label, Label) -> a) -> a -> [(Label, Label)] -> a
forall b a. (b -> a -> b) -> b -> [a] -> b
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
           [(CmmBlock -> Label
forall (x :: Extensibility). Block CmmNode C x -> Label
forall (thing :: Extensibility -> Extensibility -> *)
       (x :: Extensibility).
NonLocal thing =>
thing C x -> Label
entryLabel CmmBlock
from, Label
to) | CmmBlock
from <- [CmmBlock]
rpblocks, Label
to <- CmmBlock -> [Label]
forall (e :: Extensibility). Block CmmNode e C -> [Label]
forall (thing :: Extensibility -> Extensibility -> *)
       (e :: Extensibility).
NonLocal thing =>
thing e C -> [Label]
successors CmmBlock
from]

   isMergeLabel :: Label -> Bool
isMergeLabel Label
l = Label -> LabelSet -> Bool
setMember Label
l LabelSet
mergeBlockLabels
   isMergeNode :: CmmBlock -> Bool
isMergeNode = Label -> Bool
isMergeLabel (Label -> Bool) -> (CmmBlock -> Label) -> CmmBlock -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CmmBlock -> Label
forall (x :: Extensibility). Block CmmNode C x -> Label
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 RPNum -> RPNum -> Bool
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 = Label -> LabelMap (Tree CmmBlock) -> Tree CmmBlock
forall a. HasDebugCallStack => Label -> LabelMap a -> a
findLabelIn Label
label LabelMap (Tree CmmBlock)
subtrees
   subtrees :: LabelMap (Tree.Tree CmmBlock)
   subtrees :: LabelMap (Tree CmmBlock)
subtrees = LabelMap (Tree CmmBlock)
-> Tree CmmBlock -> LabelMap (Tree CmmBlock)
forall {thing :: Extensibility -> Extensibility -> *}
       {x :: Extensibility}.
NonLocal thing =>
LabelMap (Tree (thing C x))
-> Tree (thing C x) -> LabelMap (Tree (thing C x))
addSubtree LabelMap (Tree CmmBlock)
forall v. LabelMap v
mapEmpty Tree CmmBlock
dominatorTree
     where addSubtree :: LabelMap (Tree (thing C x))
-> Tree (thing C x) -> LabelMap (Tree (thing C x))
addSubtree LabelMap (Tree (thing C x))
map t :: Tree (thing C x)
t@(Tree.Node thing C x
root [Tree (thing C x)]
children) =
               (LabelMap (Tree (thing C x))
 -> Tree (thing C x) -> LabelMap (Tree (thing C x)))
-> LabelMap (Tree (thing C x))
-> [Tree (thing C x)]
-> LabelMap (Tree (thing C x))
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl LabelMap (Tree (thing C x))
-> Tree (thing C x) -> LabelMap (Tree (thing C x))
addSubtree (Label
-> Tree (thing C x)
-> LabelMap (Tree (thing C x))
-> LabelMap (Tree (thing C x))
forall v. Label -> v -> LabelMap v -> LabelMap v
mapInsert (thing C x -> Label
forall (x :: Extensibility). thing C x -> Label
forall (thing :: Extensibility -> Extensibility -> *)
       (x :: Extensibility).
NonLocal thing =>
thing C x -> Label
entryLabel thing C x
root) Tree (thing C x)
t LabelMap (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 =
       [Label] -> LabelSet
setFromList [CmmBlock -> Label
forall (x :: Extensibility). Block CmmNode C x -> Label
forall (thing :: Extensibility -> Extensibility -> *)
       (x :: Extensibility).
NonLocal thing =>
thing C x -> Label
entryLabel CmmBlock
n | CmmBlock
n <- [CmmBlock]
rpblocks, [Label] -> Bool
forall {a}. [a] -> Bool
big (Label -> [Label]
forwardPreds (CmmBlock -> Label
forall (x :: Extensibility). Block CmmNode C x -> Label
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 -> [Label] -> Label -> LabelMap [Label] -> [Label]
forall a. a -> Label -> LabelMap a -> a
mapFindWithDefault [] Label
l LabelMap [Label]
predmap
              where predmap :: LabelMap [Label]
                    predmap :: LabelMap [Label]
predmap = (Label -> Label -> LabelMap [Label] -> LabelMap [Label])
-> LabelMap [Label] -> LabelMap [Label]
forall a. (Label -> Label -> a -> a) -> a -> a
foldEdges Label -> Label -> LabelMap [Label] -> LabelMap [Label]
addForwardEdge LabelMap [Label]
forall v. LabelMap v
mapEmpty
                    addForwardEdge :: Label -> Label -> LabelMap [Label] -> LabelMap [Label]
addForwardEdge Label
from Label
to LabelMap [Label]
pm
                        | Label -> Label -> Bool
isBackward Label
from Label
to = LabelMap [Label]
pm
                        | Bool
otherwise = ([Label] -> [Label])
-> Label -> LabelMap [Label] -> LabelMap [Label]
forall a. ([a] -> [a]) -> Label -> LabelMap [a] -> LabelMap [a]
addToList (Label
from Label -> [Label] -> [Label]
forall a. a -> [a] -> [a]
:) Label
to LabelMap [Label]
pm

   isLoopHeader :: CmmBlock -> Bool
isLoopHeader = Label -> Bool
isHeaderLabel (Label -> Bool) -> (CmmBlock -> Label) -> CmmBlock -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CmmBlock -> Label
forall (x :: Extensibility). Block CmmNode C x -> Label
forall (thing :: Extensibility -> Extensibility -> *)
       (x :: Extensibility).
NonLocal thing =>
thing C x -> Label
entryLabel
   isHeaderLabel :: Label -> Bool
isHeaderLabel = (Label -> LabelSet -> Bool
`setMember` LabelSet
headers)  -- loop headers
      where headers :: LabelSet
            headers :: LabelSet
headers = (CmmBlock -> LabelSet) -> LabelMap CmmBlock -> LabelSet
forall m a. Monoid m => (a -> m) -> LabelMap a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap CmmBlock -> LabelSet
forall {thing :: Extensibility -> Extensibility -> *}.
NonLocal thing =>
thing C C -> LabelSet
headersPointedTo LabelMap CmmBlock
blockmap
            headersPointedTo :: thing C C -> LabelSet
headersPointedTo thing C C
block =
                [Label] -> LabelSet
setFromList [Label
label | Label
label <- thing C C -> [Label]
forall (e :: Extensibility). thing e C -> [Label]
forall (thing :: Extensibility -> Extensibility -> *)
       (e :: Extensibility).
NonLocal thing =>
thing e C -> [Label]
successors thing C C
block,
                                              Label -> Label -> Bool
dominates Label
label (thing C C -> Label
forall (x :: Extensibility). thing C x -> 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
_ [] = String -> Int
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Label -> [ContainingSyntax] -> Int
index Label
label [ContainingSyntax]
context

   rpnum :: Label -> RPNum
rpnum = GraphWithDominators CmmNode -> Label -> 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 Label -> Label -> Bool
forall a. Eq a => a -> a -> Bool
== Label
blockname Bool -> Bool -> Bool
|| Label -> DominatorSet -> Bool
dominatorsMember Label
lbl (GraphWithDominators CmmNode -> Label -> DominatorSet
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 Width -> Width -> Bool
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 (Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
k) Width
width)]
  where width :: Width
width = Platform -> CmmExpr -> Width
cmmExprWidth Platform
platform CmmExpr
e

addToList :: ([a] -> [a]) -> Label -> LabelMap [a] -> LabelMap [a]
addToList :: forall a. ([a] -> [a]) -> Label -> LabelMap [a] -> LabelMap [a]
addToList [a] -> [a]
consx = (Maybe [a] -> Maybe [a]) -> Label -> LabelMap [a] -> LabelMap [a]
forall v. (Maybe v -> Maybe v) -> Label -> LabelMap v -> LabelMap v
mapAlter Maybe [a] -> Maybe [a]
add
    where add :: Maybe [a] -> Maybe [a]
add Maybe [a]
Nothing = [a] -> Maybe [a]
forall a. a -> Maybe a
Just ([a] -> [a]
consx [])
          add (Just [a]
xs) = [a] -> Maybe [a]
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) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"node" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Label -> SDoc
forall a. Outputable a => a -> SDoc
ppr Label
l
    ppr (LoopHeadedBy Label
l) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"loop" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Label -> SDoc
forall a. Outputable a => a -> SDoc
ppr Label
l
    ppr (IfThenElse Maybe Label
l) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"if-then-else" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Maybe Label -> SDoc
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 = a -> Label -> LabelMap a -> a
forall a. a -> Label -> LabelMap a -> a
mapFindWithDefault a
failed Label
lbl
  where failed :: a
failed =
            String -> SDoc -> a
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"label not found in control-flow graph" (Label -> SDoc
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 = ((a -> b) -> b) -> m (a -> b) -> m b
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> a -> b
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)
(<<>>) = (WasmControl s e pre mid
 -> WasmControl s e mid post -> WasmControl s e pre post)
-> m (WasmControl s e pre mid)
-> m (WasmControl s e mid post)
-> m (WasmControl s e pre post)
forall a b c. (a -> b -> c) -> m a -> m b -> m c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 WasmControl s e pre mid
-> WasmControl s e mid post -> WasmControl s e pre post
forall s e (pre :: [WasmType]) (mid :: [WasmType])
       (post :: [WasmType]).
WasmControl s e pre mid
-> WasmControl s e mid post -> WasmControl s e pre post
(<>)