{-# 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.Data.Graph.Collapse (MonadUniqDSM (liftUniqDSM))
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
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]
, 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"
data ContainingSyntax
= BlockFollowedBy Label
| LoopHeadedBy Label
| IfThenElse (Maybe Label)
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
}
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
structuredControl :: forall expr stmt m .
MonadUniqDSM m
=> Platform
-> (Label -> CmmExpr -> m expr)
-> (Label -> CmmActions -> m stmt)
-> CmmGraph
-> m (WasmControl stmt expr '[] '[ 'I32])
structuredControl :: forall expr stmt (m :: * -> *).
MonadUniqDSM 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' = do
gwd :: GraphWithDominators CmmNode <-
UniqDSM (GraphWithDominators CmmNode)
-> m (GraphWithDominators CmmNode)
forall a. UniqDSM a -> m a
forall (m :: * -> *) a. MonadUniqDSM m => UniqDSM a -> m a
liftUniqDSM (UniqDSM (GraphWithDominators CmmNode)
-> m (GraphWithDominators CmmNode))
-> UniqDSM (GraphWithDominators CmmNode)
-> m (GraphWithDominators CmmNode)
forall a b. (a -> b) -> a -> b
$ GraphWithDominators CmmNode
-> UniqDSM (GraphWithDominators CmmNode)
asReducible (GraphWithDominators CmmNode
-> UniqDSM (GraphWithDominators CmmNode))
-> GraphWithDominators CmmNode
-> UniqDSM (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'
let
g :: CmmGraph
g = GraphWithDominators CmmNode -> CmmGraph
forall (node :: Extensibility -> Extensibility -> *).
GraphWithDominators node -> GenCmmGraph node
gwd_graph GraphWithDominators CmmNode
gwd
dominatorTree :: Tree.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 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
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 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
switchIndex (Just Label
lbl) = Label -> [ContainingSyntax] -> Int
index Label
lbl (Context -> [ContainingSyntax]
enclosing Context
context)
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
| 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
| 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
| 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
where i :: Int
i = Label -> [ContainingSyntax] -> Int
index Label
to (Context -> [ContainingSyntax]
enclosing Context
context)
generatesIf :: CmmBlock -> Bool
generatesIf CmmBlock
x = case Platform -> CmmBlock -> ControlFlow CmmExpr
flowLeaving Platform
platform CmmBlock
x of Conditional {} -> Bool
True
ControlFlow CmmExpr
_ -> Bool
False
treeEntryLabel :: Tree.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
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
isMergeLabel :: Label -> Bool
isMergeNode :: CmmBlock -> Bool
isLoopHeader :: CmmBlock -> Bool
dominates :: Label -> Label -> Bool
blockmap :: LabelMap CmmBlock
GMany NothingO blockmap NothingO = g_graph g
blockLabeled Label
l = Label -> LabelMap CmmBlock -> CmmBlock
forall a. HasDebugCallStack => Label -> LabelMap a -> a
findLabelIn Label
l LabelMap CmmBlock
blockmap
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 (s :: * -> *) (n :: Extensibility -> Extensibility -> *).
GenGenCmmGraph s n -> Label
g_entry CmmGraph
g)
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
l = Label -> LabelSet -> Bool
setMember Label
l LabelSet
mergeBlockLabels
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
from Label
to = Label -> RPNum
rpnum Label
to RPNum -> RPNum -> Bool
forall a. Ord a => a -> a -> Bool
<= Label -> RPNum
rpnum Label
from
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)
-> 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
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]
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 = 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 -> LabelSet -> Bool
`setMember` LabelSet
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
_ [] = 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 = GraphWithDominators CmmNode -> Label -> RPNum
forall (node :: Extensibility -> Extensibility -> *).
HasDebugCallStack =>
GraphWithDominators node -> Label -> RPNum
gwdRPNumber GraphWithDominators CmmNode
gwd
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)
doTree returns dominatorTree emptyContext
nodeBody :: CmmBlock -> CmmActions
nodeBody :: CmmBlock -> CmmActions
nodeBody (BlockCC CmmNode C O
_first CmmActions
middle CmmNode O C
_last) = CmmActions
middle
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)
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
(<>)