{-# 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
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 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"
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 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
}
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
structuredControl :: forall expr stmt m .
Applicative m
=> Platform
-> (Label -> CmmExpr -> m expr)
-> (Label -> CmmActions -> m stmt)
-> CmmGraph
-> 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
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
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
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
| 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
| 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
| 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
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
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
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
isMergeLabel :: Label -> Bool
isMergeNode :: CmmBlock -> Bool
isLoopHeader :: CmmBlock -> Bool
dominates :: Label -> Label -> Bool
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
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
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]
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)
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
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)
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
(<>)