{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE LambdaCase #-}
module GHC.Cmm.Node (
CmmNode(..), CmmFormal, CmmActual, CmmTickish,
UpdFrameOffset, Convention(..),
ForeignConvention(..), ForeignTarget(..), foreignTargetHints,
CmmReturnInfo(..),
mapExp, mapExpDeep, wrapRecExp, foldExp, foldExpDeep, wrapRecExpf,
mapExpM, mapExpDeepM, wrapRecExpM, mapSuccessors, mapCollectSuccessors,
CmmTickScope(..), isTickSubScope, combineTickScopes,
) where
import GHC.Prelude hiding (succ)
import GHC.Platform.Regs
import GHC.Cmm.CLabel
import GHC.Cmm.Expr
import GHC.Cmm.Switch
import GHC.Data.FastString
import GHC.Data.Pair
import GHC.Types.ForeignCall
import GHC.Utils.Outputable
import GHC.Runtime.Heap.Layout
import GHC.Types.Tickish (CmmTickish)
import qualified GHC.Types.Unique as U
import GHC.Types.Basic (FunctionOrData(..))
import GHC.Platform
import GHC.Cmm.Dataflow.Block
import GHC.Cmm.Dataflow.Graph
import GHC.Cmm.Dataflow.Collections
import GHC.Cmm.Dataflow.Label
import Data.Foldable (toList)
import Data.Functor.Classes (liftCompare)
import Data.Maybe
import Data.List (tails,sortBy)
import GHC.Types.Unique (nonDetCmpUnique)
import GHC.Utils.Constants (debugIsOn)
#define ULabel {-# UNPACK #-} !Label
data CmmNode e x where
CmmEntry :: ULabel -> CmmTickScope -> CmmNode C O
:: FastString -> CmmNode O O
CmmTick :: !CmmTickish -> CmmNode O O
CmmUnwind :: [(GlobalReg, Maybe CmmExpr)] -> CmmNode O O
CmmAssign :: !CmmReg -> !CmmExpr -> CmmNode O O
CmmStore :: !CmmExpr -> !CmmExpr -> !AlignmentSpec -> CmmNode O O
CmmUnsafeForeignCall ::
ForeignTarget ->
[CmmFormal] ->
[CmmActual] ->
CmmNode O O
CmmBranch :: ULabel -> CmmNode O C
CmmCondBranch :: {
CmmNode 'Open 'Closed -> CmmExpr
cml_pred :: CmmExpr,
CmmNode 'Open 'Closed -> Label
cml_true, CmmNode 'Open 'Closed -> Label
cml_false :: ULabel,
CmmNode 'Open 'Closed -> Maybe Bool
cml_likely :: Maybe Bool
} -> CmmNode O C
CmmSwitch
:: CmmExpr
-> SwitchTargets
-> CmmNode O C
CmmCall :: {
CmmNode 'Open 'Closed -> CmmExpr
cml_target :: CmmExpr,
CmmNode 'Open 'Closed -> Maybe Label
cml_cont :: Maybe Label,
CmmNode 'Open 'Closed -> [GlobalReg]
cml_args_regs :: [GlobalReg],
CmmNode 'Open 'Closed -> ByteOff
cml_args :: ByteOff,
CmmNode 'Open 'Closed -> ByteOff
cml_ret_args :: ByteOff,
CmmNode 'Open 'Closed -> ByteOff
cml_ret_off :: ByteOff
} -> CmmNode O C
CmmForeignCall :: {
CmmNode 'Open 'Closed -> ForeignTarget
tgt :: ForeignTarget,
CmmNode 'Open 'Closed -> [CmmFormal]
res :: [CmmFormal],
CmmNode 'Open 'Closed -> [CmmExpr]
args :: [CmmActual],
CmmNode 'Open 'Closed -> Label
succ :: ULabel,
CmmNode 'Open 'Closed -> ByteOff
ret_args :: ByteOff,
CmmNode 'Open 'Closed -> ByteOff
ret_off :: ByteOff,
CmmNode 'Open 'Closed -> Bool
intrbl:: Bool
} -> CmmNode O C
instance OutputableP Platform (CmmNode e x) where
pdoc :: Platform -> CmmNode e x -> SDoc
pdoc = Platform -> CmmNode e x -> SDoc
forall (e :: Extensibility) (x :: Extensibility).
Platform -> CmmNode e x -> SDoc
pprNode
pprNode :: Platform -> CmmNode e x -> SDoc
pprNode :: forall (e :: Extensibility) (x :: Extensibility).
Platform -> CmmNode e x -> SDoc
pprNode Platform
platform CmmNode e x
node = SDoc
pp_node SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
pp_debug
where
pp_node :: SDoc
pp_node :: SDoc
pp_node = case CmmNode e x
node of
CmmEntry Label
id CmmTickScope
tscope ->
((SDocContext -> Bool) -> (Bool -> SDoc) -> SDoc
forall a. (SDocContext -> a) -> (a -> SDoc) -> SDoc
sdocOption SDocContext -> Bool
sdocSuppressUniques ((Bool -> SDoc) -> SDoc) -> (Bool -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \case
Bool
True -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"_lbl_"
Bool
False -> Label -> SDoc
forall a. Outputable a => a -> SDoc
ppr Label
id
)
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
colon
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> (SDocContext -> Bool) -> SDoc -> SDoc
forall doc. IsLine doc => (SDocContext -> Bool) -> doc -> doc
ppUnlessOption SDocContext -> Bool
sdocSuppressTicks (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"//" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> CmmTickScope -> SDoc
forall a. Outputable a => a -> SDoc
ppr CmmTickScope
tscope)
CmmComment FastString
s -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"//" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> FastString -> SDoc
forall doc. IsLine doc => FastString -> doc
ftext FastString
s
CmmTick CmmTickish
t -> (SDocContext -> Bool) -> SDoc -> SDoc
forall doc. IsLine doc => (SDocContext -> Bool) -> doc -> doc
ppUnlessOption SDocContext -> Bool
sdocSuppressTicks
(String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"//tick" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> CmmTickish -> SDoc
forall a. Outputable a => a -> SDoc
ppr CmmTickish
t)
CmmUnwind [(GlobalReg, Maybe CmmExpr)]
regs ->
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"unwind "
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [SDoc] -> SDoc
commafy (((GlobalReg, Maybe CmmExpr) -> SDoc)
-> [(GlobalReg, Maybe CmmExpr)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (\(GlobalReg
r,Maybe CmmExpr
e) -> GlobalReg -> SDoc
forall a. Outputable a => a -> SDoc
ppr GlobalReg
r SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'=' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Platform -> Maybe CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform Maybe CmmExpr
e) [(GlobalReg, Maybe CmmExpr)]
regs) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
semi
CmmAssign CmmReg
reg CmmExpr
expr -> CmmReg -> SDoc
forall a. Outputable a => a -> SDoc
ppr CmmReg
reg SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
forall doc. IsLine doc => doc
equals SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CmmExpr
expr SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
semi
CmmStore CmmExpr
lv CmmExpr
expr AlignmentSpec
align -> SDoc
rep SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
align_mark SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
brackets (Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CmmExpr
lv) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
forall doc. IsLine doc => doc
equals SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CmmExpr
expr SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
semi
where
align_mark :: SDoc
align_mark = case AlignmentSpec
align of
AlignmentSpec
Unaligned -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"^"
AlignmentSpec
NaturallyAligned -> SDoc
forall doc. IsOutput doc => doc
empty
rep :: SDoc
rep = CmmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ( Platform -> CmmExpr -> CmmType
cmmExprType Platform
platform CmmExpr
expr )
CmmUnsafeForeignCall ForeignTarget
target [CmmFormal]
results [CmmExpr]
args ->
[SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep [ Bool -> SDoc -> SDoc
forall doc. IsOutput doc => Bool -> doc -> doc
ppUnless ([CmmFormal] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CmmFormal]
results) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens ([SDoc] -> SDoc
commafy ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (CmmFormal -> SDoc) -> [CmmFormal] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map CmmFormal -> SDoc
forall a. Outputable a => a -> SDoc
ppr [CmmFormal]
results) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
forall doc. IsLine doc => doc
equals,
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"call",
Platform -> ForeignTarget -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform ForeignTarget
target SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens ([SDoc] -> SDoc
commafy ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (CmmExpr -> SDoc) -> [CmmExpr] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform) [CmmExpr]
args) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
semi]
CmmBranch Label
ident -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"goto" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Label -> SDoc
forall a. Outputable a => a -> SDoc
ppr Label
ident SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
semi
CmmCondBranch CmmExpr
expr Label
t Label
f Maybe Bool
l ->
[SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"if"
, SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CmmExpr
expr)
, case Maybe Bool
l of
Maybe Bool
Nothing -> SDoc
forall doc. IsOutput doc => doc
empty
Just Bool
b -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"likely:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bool
b)
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"goto"
, Label -> SDoc
forall a. Outputable a => a -> SDoc
ppr Label
t SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
semi
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"else goto"
, Label -> SDoc
forall a. Outputable a => a -> SDoc
ppr Label
f SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
semi
]
CmmSwitch CmmExpr
expr SwitchTargets
ids ->
SDoc -> ByteOff -> SDoc -> SDoc
hang ([SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"switch"
, SDoc
range
, if CmmExpr -> Bool
isTrivialCmmExpr CmmExpr
expr
then Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CmmExpr
expr
else SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CmmExpr
expr)
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"{"
])
ByteOff
4 ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat (((NonEmpty Integer, Label) -> SDoc)
-> [(NonEmpty Integer, Label)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (NonEmpty Integer, Label) -> SDoc
forall {t :: * -> *} {a}.
(Foldable t, Functor t, Outputable a) =>
(t Integer, a) -> SDoc
ppCase [(NonEmpty Integer, Label)]
cases) SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ SDoc
def) SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ SDoc
forall doc. IsLine doc => doc
rbrace
where
([(NonEmpty Integer, Label)]
cases, Maybe Label
mbdef) = SwitchTargets -> ([(NonEmpty Integer, Label)], Maybe Label)
switchTargetsFallThrough SwitchTargets
ids
ppCase :: (t Integer, a) -> SDoc
ppCase (t Integer
is,a
l) = [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep
[ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"case"
, [SDoc] -> SDoc
commafy ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ t SDoc -> [SDoc]
forall a. t a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (t SDoc -> [SDoc]) -> t SDoc -> [SDoc]
forall a b. (a -> b) -> a -> b
$ (Integer -> SDoc) -> t Integer -> t SDoc
forall a b. (a -> b) -> t a -> t b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Integer -> SDoc
forall doc. IsLine doc => Integer -> doc
integer t Integer
is
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
": goto"
, a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
l SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
semi
]
def :: SDoc
def | Just Label
l <- Maybe Label
mbdef = [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep
[ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"default:"
, SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
braces (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"goto" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Label -> SDoc
forall a. Outputable a => a -> SDoc
ppr Label
l SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
semi)
]
| Bool
otherwise = SDoc
forall doc. IsOutput doc => doc
empty
range :: SDoc
range = SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
brackets (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep [Integer -> SDoc
forall doc. IsLine doc => Integer -> doc
integer Integer
lo, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"..", Integer -> SDoc
forall doc. IsLine doc => Integer -> doc
integer Integer
hi]
where (Integer
lo,Integer
hi) = SwitchTargets -> (Integer, Integer)
switchTargetsRange SwitchTargets
ids
CmmCall CmmExpr
tgt Maybe Label
k [GlobalReg]
regs ByteOff
out ByteOff
res ByteOff
updfr_off ->
[SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"call", SDoc
forall doc. IsLine doc => doc
space
, CmmExpr -> SDoc
pprFun CmmExpr
tgt, SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens ([GlobalReg] -> SDoc
forall a. Outputable a => [a] -> SDoc
interpp'SP [GlobalReg]
regs), SDoc
forall doc. IsLine doc => doc
space
, SDoc
returns SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"args: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> ByteOff -> SDoc
forall a. Outputable a => a -> SDoc
ppr ByteOff
out SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
comma SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"res: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> ByteOff -> SDoc
forall a. Outputable a => a -> SDoc
ppr ByteOff
res SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
comma SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"upd: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> ByteOff -> SDoc
forall a. Outputable a => a -> SDoc
ppr ByteOff
updfr_off
, SDoc
forall doc. IsLine doc => doc
semi ]
where pprFun :: CmmExpr -> SDoc
pprFun f :: CmmExpr
f@(CmmLit CmmLit
_) = Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CmmExpr
f
pprFun CmmExpr
f = SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CmmExpr
f)
returns :: SDoc
returns
| Just Label
r <- Maybe Label
k = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"returns to" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Label -> SDoc
forall a. Outputable a => a -> SDoc
ppr Label
r SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
comma
| Bool
otherwise = SDoc
forall doc. IsOutput doc => doc
empty
CmmForeignCall {tgt :: CmmNode 'Open 'Closed -> ForeignTarget
tgt=ForeignTarget
t, res :: CmmNode 'Open 'Closed -> [CmmFormal]
res=[CmmFormal]
rs, args :: CmmNode 'Open 'Closed -> [CmmExpr]
args=[CmmExpr]
as, succ :: CmmNode 'Open 'Closed -> Label
succ=Label
s, ret_args :: CmmNode 'Open 'Closed -> ByteOff
ret_args=ByteOff
a, ret_off :: CmmNode 'Open 'Closed -> ByteOff
ret_off=ByteOff
u, intrbl :: CmmNode 'Open 'Closed -> Bool
intrbl=Bool
i} ->
[SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ if Bool
i then [String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"interruptible", SDoc
forall doc. IsLine doc => doc
space] else [] [SDoc] -> [SDoc] -> [SDoc]
forall a. [a] -> [a] -> [a]
++
[ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"foreign call", SDoc
forall doc. IsLine doc => doc
space
, Platform -> ForeignTarget -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform ForeignTarget
t, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"(...)", SDoc
forall doc. IsLine doc => doc
space
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"returns to" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Label -> SDoc
forall a. Outputable a => a -> SDoc
ppr Label
s
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"args:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (Platform -> [CmmExpr] -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform [CmmExpr]
as)
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"ress:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens ([CmmFormal] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [CmmFormal]
rs)
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"ret_args:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> ByteOff -> SDoc
forall a. Outputable a => a -> SDoc
ppr ByteOff
a
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"ret_off:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> ByteOff -> SDoc
forall a. Outputable a => a -> SDoc
ppr ByteOff
u
, SDoc
forall doc. IsLine doc => doc
semi ]
pp_debug :: SDoc
pp_debug :: SDoc
pp_debug =
if Bool -> Bool
not Bool
debugIsOn then SDoc
forall doc. IsOutput doc => doc
empty
else case CmmNode e x
node of
CmmEntry {} -> SDoc
forall doc. IsOutput doc => doc
empty
CmmComment {} -> SDoc
forall doc. IsOutput doc => doc
empty
CmmTick {} -> SDoc
forall doc. IsOutput doc => doc
empty
CmmUnwind {} -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
" // CmmUnwind"
CmmAssign {} -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
" // CmmAssign"
CmmStore {} -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
" // CmmStore"
CmmUnsafeForeignCall {} -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
" // CmmUnsafeForeignCall"
CmmBranch {} -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
" // CmmBranch"
CmmCondBranch {} -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
" // CmmCondBranch"
CmmSwitch {} -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
" // CmmSwitch"
CmmCall {} -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
" // CmmCall"
CmmForeignCall {} -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
" // CmmForeignCall"
commafy :: [SDoc] -> SDoc
commafy :: [SDoc] -> SDoc
commafy [SDoc]
xs = [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
forall doc. IsLine doc => doc -> [doc] -> [doc]
punctuate SDoc
forall doc. IsLine doc => doc
comma [SDoc]
xs
instance OutputableP Platform (Block CmmNode C C) where
pdoc :: Platform -> Block CmmNode 'Closed 'Closed -> SDoc
pdoc = Platform -> Block CmmNode 'Closed 'Closed -> SDoc
Platform
-> Block CmmNode 'Closed 'Closed -> IndexedCO 'Closed SDoc SDoc
forall (x :: Extensibility) (e :: Extensibility).
(IndexedCO x SDoc SDoc ~ SDoc) =>
Platform -> Block CmmNode e x -> IndexedCO e SDoc SDoc
pprBlock
instance OutputableP Platform (Block CmmNode C O) where
pdoc :: Platform -> Block CmmNode 'Closed 'Open -> SDoc
pdoc = Platform -> Block CmmNode 'Closed 'Open -> SDoc
Platform
-> Block CmmNode 'Closed 'Open -> IndexedCO 'Closed SDoc SDoc
forall (x :: Extensibility) (e :: Extensibility).
(IndexedCO x SDoc SDoc ~ SDoc) =>
Platform -> Block CmmNode e x -> IndexedCO e SDoc SDoc
pprBlock
instance OutputableP Platform (Block CmmNode O C) where
pdoc :: Platform -> Block CmmNode 'Open 'Closed -> SDoc
pdoc = Platform -> Block CmmNode 'Open 'Closed -> SDoc
Platform
-> Block CmmNode 'Open 'Closed -> IndexedCO 'Open SDoc SDoc
forall (x :: Extensibility) (e :: Extensibility).
(IndexedCO x SDoc SDoc ~ SDoc) =>
Platform -> Block CmmNode e x -> IndexedCO e SDoc SDoc
pprBlock
instance OutputableP Platform (Block CmmNode O O) where
pdoc :: Platform -> Block CmmNode 'Open 'Open -> SDoc
pdoc = Platform -> Block CmmNode 'Open 'Open -> SDoc
Platform -> Block CmmNode 'Open 'Open -> IndexedCO 'Open SDoc SDoc
forall (x :: Extensibility) (e :: Extensibility).
(IndexedCO x SDoc SDoc ~ SDoc) =>
Platform -> Block CmmNode e x -> IndexedCO e SDoc SDoc
pprBlock
instance OutputableP Platform (Graph CmmNode e x) where
pdoc :: Platform -> Graph CmmNode e x -> SDoc
pdoc = Platform -> Graph CmmNode e x -> SDoc
forall (e :: Extensibility) (x :: Extensibility).
Platform -> Graph CmmNode e x -> SDoc
pprGraph
pprBlock :: IndexedCO x SDoc SDoc ~ SDoc
=> Platform -> Block CmmNode e x -> IndexedCO e SDoc SDoc
pprBlock :: forall (x :: Extensibility) (e :: Extensibility).
(IndexedCO x SDoc SDoc ~ SDoc) =>
Platform -> Block CmmNode e x -> IndexedCO e SDoc SDoc
pprBlock Platform
platform Block CmmNode e x
block
= (CmmNode 'Closed 'Open -> SDoc -> SDoc,
CmmNode 'Open 'Open -> SDoc -> SDoc,
CmmNode 'Open 'Closed -> SDoc -> SDoc)
-> forall (e :: Extensibility) (x :: Extensibility).
Block CmmNode e x -> IndexedCO x SDoc SDoc -> IndexedCO e SDoc SDoc
forall (n :: Extensibility -> Extensibility -> *) a b c.
(n 'Closed 'Open -> b -> c, n 'Open 'Open -> b -> b,
n 'Open 'Closed -> a -> b)
-> forall (e :: Extensibility) (x :: Extensibility).
Block n e x -> IndexedCO x a b -> IndexedCO e c b
foldBlockNodesB3 ( SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
($$) (SDoc -> SDoc -> SDoc)
-> (CmmNode 'Closed 'Open -> SDoc)
-> CmmNode 'Closed 'Open
-> SDoc
-> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Platform -> CmmNode 'Closed 'Open -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform
, SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
($$) (SDoc -> SDoc -> SDoc)
-> (CmmNode 'Open 'Open -> SDoc)
-> CmmNode 'Open 'Open
-> SDoc
-> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteOff -> SDoc -> SDoc
nest ByteOff
4) (SDoc -> SDoc)
-> (CmmNode 'Open 'Open -> SDoc) -> CmmNode 'Open 'Open -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Platform -> CmmNode 'Open 'Open -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform
, SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
($$) (SDoc -> SDoc -> SDoc)
-> (CmmNode 'Open 'Closed -> SDoc)
-> CmmNode 'Open 'Closed
-> SDoc
-> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteOff -> SDoc -> SDoc
nest ByteOff
4) (SDoc -> SDoc)
-> (CmmNode 'Open 'Closed -> SDoc) -> CmmNode 'Open 'Closed -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Platform -> CmmNode 'Open 'Closed -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform
)
Block CmmNode e x
block
SDoc
IndexedCO x SDoc SDoc
forall doc. IsOutput doc => doc
empty
pprGraph :: Platform -> Graph CmmNode e x -> SDoc
pprGraph :: forall (e :: Extensibility) (x :: Extensibility).
Platform -> Graph CmmNode e x -> SDoc
pprGraph Platform
platform = \case
Graph CmmNode e x
GNil -> SDoc
forall doc. IsOutput doc => doc
empty
GUnit Block CmmNode 'Open 'Open
block -> Platform -> Block CmmNode 'Open 'Open -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform Block CmmNode 'Open 'Open
block
GMany MaybeO e (Block CmmNode 'Open 'Closed)
entry Body' Block CmmNode
body MaybeO x (Block CmmNode 'Closed 'Open)
exit ->
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"{"
SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ ByteOff -> SDoc -> SDoc
nest ByteOff
2 (MaybeO e (Block CmmNode 'Open 'Closed) -> SDoc
forall (e :: Extensibility) (x :: Extensibility)
(ex :: Extensibility).
OutputableP Platform (Block CmmNode e x) =>
MaybeO ex (Block CmmNode e x) -> SDoc
pprMaybeO MaybeO e (Block CmmNode 'Open 'Closed)
entry SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (Block CmmNode 'Closed 'Closed -> SDoc)
-> [Block CmmNode 'Closed 'Closed] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (Platform -> Block CmmNode 'Closed 'Closed -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform) ([Block CmmNode 'Closed 'Closed] -> [SDoc])
-> [Block CmmNode 'Closed 'Closed] -> [SDoc]
forall a b. (a -> b) -> a -> b
$ Body' Block CmmNode -> [Block CmmNode 'Closed 'Closed]
forall (n :: Extensibility -> Extensibility -> *).
Body n -> [Block n 'Closed 'Closed]
bodyToBlockList Body' Block CmmNode
body) SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ MaybeO x (Block CmmNode 'Closed 'Open) -> SDoc
forall (e :: Extensibility) (x :: Extensibility)
(ex :: Extensibility).
OutputableP Platform (Block CmmNode e x) =>
MaybeO ex (Block CmmNode e x) -> SDoc
pprMaybeO MaybeO x (Block CmmNode 'Closed 'Open)
exit)
SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"}"
where pprMaybeO :: OutputableP Platform (Block CmmNode e x)
=> MaybeO ex (Block CmmNode e x) -> SDoc
pprMaybeO :: forall (e :: Extensibility) (x :: Extensibility)
(ex :: Extensibility).
OutputableP Platform (Block CmmNode e x) =>
MaybeO ex (Block CmmNode e x) -> SDoc
pprMaybeO MaybeO ex (Block CmmNode e x)
NothingO = SDoc
forall doc. IsOutput doc => doc
empty
pprMaybeO (JustO Block CmmNode e x
block) = Platform -> Block CmmNode e x -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform Block CmmNode e x
block
deriving instance Eq (CmmNode e x)
instance NonLocal CmmNode where
entryLabel :: forall (x :: Extensibility). CmmNode 'Closed x -> Label
entryLabel (CmmEntry Label
l CmmTickScope
_) = Label
l
successors :: forall (e :: Extensibility). CmmNode e 'Closed -> [Label]
successors (CmmBranch Label
l) = [Label
l]
successors (CmmCondBranch {cml_true :: CmmNode 'Open 'Closed -> Label
cml_true=Label
t, cml_false :: CmmNode 'Open 'Closed -> Label
cml_false=Label
f}) = [Label
f, Label
t]
successors (CmmSwitch CmmExpr
_ SwitchTargets
ids) = SwitchTargets -> [Label]
switchTargetsToList SwitchTargets
ids
successors (CmmCall {cml_cont :: CmmNode 'Open 'Closed -> Maybe Label
cml_cont=Maybe Label
l}) = Maybe Label -> [Label]
forall a. Maybe a -> [a]
maybeToList Maybe Label
l
successors (CmmForeignCall {succ :: CmmNode 'Open 'Closed -> Label
succ=Label
l}) = [Label
l]
type CmmActual = CmmExpr
type CmmFormal = LocalReg
type UpdFrameOffset = ByteOff
data Convention
= NativeDirectCall
| NativeNodeCall
| NativeReturn
| Slow
| GC
deriving( Convention -> Convention -> Bool
(Convention -> Convention -> Bool)
-> (Convention -> Convention -> Bool) -> Eq Convention
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Convention -> Convention -> Bool
== :: Convention -> Convention -> Bool
$c/= :: Convention -> Convention -> Bool
/= :: Convention -> Convention -> Bool
Eq )
data ForeignConvention
= ForeignConvention
CCallConv
[ForeignHint]
[ForeignHint]
CmmReturnInfo
deriving ForeignConvention -> ForeignConvention -> Bool
(ForeignConvention -> ForeignConvention -> Bool)
-> (ForeignConvention -> ForeignConvention -> Bool)
-> Eq ForeignConvention
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ForeignConvention -> ForeignConvention -> Bool
== :: ForeignConvention -> ForeignConvention -> Bool
$c/= :: ForeignConvention -> ForeignConvention -> Bool
/= :: ForeignConvention -> ForeignConvention -> Bool
Eq
instance Outputable ForeignConvention where
ppr :: ForeignConvention -> SDoc
ppr = ForeignConvention -> SDoc
pprForeignConvention
pprForeignConvention :: ForeignConvention -> SDoc
pprForeignConvention :: ForeignConvention -> SDoc
pprForeignConvention (ForeignConvention CCallConv
c [ForeignHint]
args [ForeignHint]
res CmmReturnInfo
ret) =
SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
doubleQuotes (CCallConv -> SDoc
forall a. Outputable a => a -> SDoc
ppr CCallConv
c) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"arg hints: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [ForeignHint] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [ForeignHint]
args SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
" result hints: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [ForeignHint] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [ForeignHint]
res SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> CmmReturnInfo -> SDoc
forall a. Outputable a => a -> SDoc
ppr CmmReturnInfo
ret
data CmmReturnInfo
= CmmMayReturn
| CmmNeverReturns
deriving ( CmmReturnInfo -> CmmReturnInfo -> Bool
(CmmReturnInfo -> CmmReturnInfo -> Bool)
-> (CmmReturnInfo -> CmmReturnInfo -> Bool) -> Eq CmmReturnInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CmmReturnInfo -> CmmReturnInfo -> Bool
== :: CmmReturnInfo -> CmmReturnInfo -> Bool
$c/= :: CmmReturnInfo -> CmmReturnInfo -> Bool
/= :: CmmReturnInfo -> CmmReturnInfo -> Bool
Eq )
instance Outputable CmmReturnInfo where
ppr :: CmmReturnInfo -> SDoc
ppr = CmmReturnInfo -> SDoc
pprReturnInfo
pprReturnInfo :: CmmReturnInfo -> SDoc
pprReturnInfo :: CmmReturnInfo -> SDoc
pprReturnInfo CmmReturnInfo
CmmMayReturn = SDoc
forall doc. IsOutput doc => doc
empty
pprReturnInfo CmmReturnInfo
CmmNeverReturns = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"never returns"
data ForeignTarget
= ForeignTarget
CmmExpr
ForeignConvention
| PrimTarget
CallishMachOp
deriving ForeignTarget -> ForeignTarget -> Bool
(ForeignTarget -> ForeignTarget -> Bool)
-> (ForeignTarget -> ForeignTarget -> Bool) -> Eq ForeignTarget
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ForeignTarget -> ForeignTarget -> Bool
== :: ForeignTarget -> ForeignTarget -> Bool
$c/= :: ForeignTarget -> ForeignTarget -> Bool
/= :: ForeignTarget -> ForeignTarget -> Bool
Eq
instance OutputableP Platform ForeignTarget where
pdoc :: Platform -> ForeignTarget -> SDoc
pdoc = Platform -> ForeignTarget -> SDoc
pprForeignTarget
pprForeignTarget :: Platform -> ForeignTarget -> SDoc
pprForeignTarget :: Platform -> ForeignTarget -> SDoc
pprForeignTarget Platform
platform (ForeignTarget CmmExpr
fn ForeignConvention
c) =
ForeignConvention -> SDoc
forall a. Outputable a => a -> SDoc
ppr ForeignConvention
c SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> CmmExpr -> SDoc
ppr_target CmmExpr
fn
where
ppr_target :: CmmExpr -> SDoc
ppr_target :: CmmExpr -> SDoc
ppr_target t :: CmmExpr
t@(CmmLit CmmLit
_) = Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CmmExpr
t
ppr_target CmmExpr
fn' = SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CmmExpr
fn')
pprForeignTarget Platform
platform (PrimTarget CallishMachOp
op)
= Platform -> CLabel -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform
(FastString
-> Maybe ByteOff -> ForeignLabelSource -> FunctionOrData -> CLabel
mkForeignLabel
(String -> FastString
mkFastString (CallishMachOp -> String
forall a. Show a => a -> String
show CallishMachOp
op))
Maybe ByteOff
forall a. Maybe a
Nothing ForeignLabelSource
ForeignLabelInThisPackage FunctionOrData
IsFunction)
instance Outputable Convention where
ppr :: Convention -> SDoc
ppr = Convention -> SDoc
pprConvention
pprConvention :: Convention -> SDoc
pprConvention :: Convention -> SDoc
pprConvention (NativeNodeCall {}) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"<native-node-call-convention>"
pprConvention (NativeDirectCall {}) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"<native-direct-call-convention>"
pprConvention (NativeReturn {}) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"<native-ret-convention>"
pprConvention Convention
Slow = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"<slow-convention>"
pprConvention Convention
GC = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"<gc-convention>"
foreignTargetHints :: ForeignTarget -> ([ForeignHint], [ForeignHint])
foreignTargetHints :: ForeignTarget -> ([ForeignHint], [ForeignHint])
foreignTargetHints ForeignTarget
target
= ( [ForeignHint]
res_hints [ForeignHint] -> [ForeignHint] -> [ForeignHint]
forall a. [a] -> [a] -> [a]
++ ForeignHint -> [ForeignHint]
forall a. a -> [a]
repeat ForeignHint
NoHint
, [ForeignHint]
arg_hints [ForeignHint] -> [ForeignHint] -> [ForeignHint]
forall a. [a] -> [a] -> [a]
++ ForeignHint -> [ForeignHint]
forall a. a -> [a]
repeat ForeignHint
NoHint )
where
([ForeignHint]
res_hints, [ForeignHint]
arg_hints) =
case ForeignTarget
target of
PrimTarget CallishMachOp
op -> CallishMachOp -> ([ForeignHint], [ForeignHint])
callishMachOpHints CallishMachOp
op
ForeignTarget CmmExpr
_ (ForeignConvention CCallConv
_ [ForeignHint]
arg_hints [ForeignHint]
res_hints CmmReturnInfo
_) ->
([ForeignHint]
res_hints, [ForeignHint]
arg_hints)
instance UserOfRegs LocalReg (CmmNode e x) where
{-# INLINEABLE foldRegsUsed #-}
foldRegsUsed :: forall b.
Platform -> (b -> CmmFormal -> b) -> b -> CmmNode e x -> b
foldRegsUsed Platform
platform b -> CmmFormal -> b
f !b
z CmmNode e x
n = case CmmNode e x
n of
CmmAssign CmmReg
_ CmmExpr
expr -> (b -> CmmFormal -> b) -> b -> CmmExpr -> b
forall a b.
UserOfRegs CmmFormal a =>
(b -> CmmFormal -> b) -> b -> a -> b
fold b -> CmmFormal -> b
f b
z CmmExpr
expr
CmmStore CmmExpr
addr CmmExpr
rval AlignmentSpec
_ -> (b -> CmmFormal -> b) -> b -> CmmExpr -> b
forall a b.
UserOfRegs CmmFormal a =>
(b -> CmmFormal -> b) -> b -> a -> b
fold b -> CmmFormal -> b
f ((b -> CmmFormal -> b) -> b -> CmmExpr -> b
forall a b.
UserOfRegs CmmFormal a =>
(b -> CmmFormal -> b) -> b -> a -> b
fold b -> CmmFormal -> b
f b
z CmmExpr
addr) CmmExpr
rval
CmmUnsafeForeignCall ForeignTarget
t [CmmFormal]
_ [CmmExpr]
args -> (b -> CmmFormal -> b) -> b -> [CmmExpr] -> b
forall a b.
UserOfRegs CmmFormal a =>
(b -> CmmFormal -> b) -> b -> a -> b
fold b -> CmmFormal -> b
f ((b -> CmmFormal -> b) -> b -> ForeignTarget -> b
forall a b.
UserOfRegs CmmFormal a =>
(b -> CmmFormal -> b) -> b -> a -> b
fold b -> CmmFormal -> b
f b
z ForeignTarget
t) [CmmExpr]
args
CmmCondBranch CmmExpr
expr Label
_ Label
_ Maybe Bool
_ -> (b -> CmmFormal -> b) -> b -> CmmExpr -> b
forall a b.
UserOfRegs CmmFormal a =>
(b -> CmmFormal -> b) -> b -> a -> b
fold b -> CmmFormal -> b
f b
z CmmExpr
expr
CmmSwitch CmmExpr
expr SwitchTargets
_ -> (b -> CmmFormal -> b) -> b -> CmmExpr -> b
forall a b.
UserOfRegs CmmFormal a =>
(b -> CmmFormal -> b) -> b -> a -> b
fold b -> CmmFormal -> b
f b
z CmmExpr
expr
CmmCall {cml_target :: CmmNode 'Open 'Closed -> CmmExpr
cml_target=CmmExpr
tgt} -> (b -> CmmFormal -> b) -> b -> CmmExpr -> b
forall a b.
UserOfRegs CmmFormal a =>
(b -> CmmFormal -> b) -> b -> a -> b
fold b -> CmmFormal -> b
f b
z CmmExpr
tgt
CmmForeignCall {tgt :: CmmNode 'Open 'Closed -> ForeignTarget
tgt=ForeignTarget
tgt, args :: CmmNode 'Open 'Closed -> [CmmExpr]
args=[CmmExpr]
args} -> (b -> CmmFormal -> b) -> b -> [CmmExpr] -> b
forall a b.
UserOfRegs CmmFormal a =>
(b -> CmmFormal -> b) -> b -> a -> b
fold b -> CmmFormal -> b
f ((b -> CmmFormal -> b) -> b -> ForeignTarget -> b
forall a b.
UserOfRegs CmmFormal a =>
(b -> CmmFormal -> b) -> b -> a -> b
fold b -> CmmFormal -> b
f b
z ForeignTarget
tgt) [CmmExpr]
args
CmmNode e x
_ -> b
z
where fold :: forall a b. UserOfRegs LocalReg a
=> (b -> LocalReg -> b) -> b -> a -> b
fold :: forall a b.
UserOfRegs CmmFormal a =>
(b -> CmmFormal -> b) -> b -> a -> b
fold b -> CmmFormal -> b
f b
z a
n = Platform -> (b -> CmmFormal -> b) -> b -> a -> b
forall b. Platform -> (b -> CmmFormal -> b) -> b -> a -> b
forall r a b.
UserOfRegs r a =>
Platform -> (b -> r -> b) -> b -> a -> b
foldRegsUsed Platform
platform b -> CmmFormal -> b
f b
z a
n
instance UserOfRegs GlobalReg (CmmNode e x) where
{-# INLINEABLE foldRegsUsed #-}
foldRegsUsed :: forall b.
Platform -> (b -> GlobalReg -> b) -> b -> CmmNode e x -> b
foldRegsUsed Platform
platform b -> GlobalReg -> b
f !b
z CmmNode e x
n = case CmmNode e x
n of
CmmAssign CmmReg
_ CmmExpr
expr -> (b -> GlobalReg -> b) -> b -> CmmExpr -> b
forall a b.
UserOfRegs GlobalReg a =>
(b -> GlobalReg -> b) -> b -> a -> b
fold b -> GlobalReg -> b
f b
z CmmExpr
expr
CmmStore CmmExpr
addr CmmExpr
rval AlignmentSpec
_ -> (b -> GlobalReg -> b) -> b -> CmmExpr -> b
forall a b.
UserOfRegs GlobalReg a =>
(b -> GlobalReg -> b) -> b -> a -> b
fold b -> GlobalReg -> b
f ((b -> GlobalReg -> b) -> b -> CmmExpr -> b
forall a b.
UserOfRegs GlobalReg a =>
(b -> GlobalReg -> b) -> b -> a -> b
fold b -> GlobalReg -> b
f b
z CmmExpr
addr) CmmExpr
rval
CmmUnsafeForeignCall ForeignTarget
t [CmmFormal]
_ [CmmExpr]
args -> (b -> GlobalReg -> b) -> b -> [CmmExpr] -> b
forall a b.
UserOfRegs GlobalReg a =>
(b -> GlobalReg -> b) -> b -> a -> b
fold b -> GlobalReg -> b
f ((b -> GlobalReg -> b) -> b -> ForeignTarget -> b
forall a b.
UserOfRegs GlobalReg a =>
(b -> GlobalReg -> b) -> b -> a -> b
fold b -> GlobalReg -> b
f b
z ForeignTarget
t) [CmmExpr]
args
CmmCondBranch CmmExpr
expr Label
_ Label
_ Maybe Bool
_ -> (b -> GlobalReg -> b) -> b -> CmmExpr -> b
forall a b.
UserOfRegs GlobalReg a =>
(b -> GlobalReg -> b) -> b -> a -> b
fold b -> GlobalReg -> b
f b
z CmmExpr
expr
CmmSwitch CmmExpr
expr SwitchTargets
_ -> (b -> GlobalReg -> b) -> b -> CmmExpr -> b
forall a b.
UserOfRegs GlobalReg a =>
(b -> GlobalReg -> b) -> b -> a -> b
fold b -> GlobalReg -> b
f b
z CmmExpr
expr
CmmCall {cml_target :: CmmNode 'Open 'Closed -> CmmExpr
cml_target=CmmExpr
tgt, cml_args_regs :: CmmNode 'Open 'Closed -> [GlobalReg]
cml_args_regs=[GlobalReg]
args} -> (b -> GlobalReg -> b) -> b -> CmmExpr -> b
forall a b.
UserOfRegs GlobalReg a =>
(b -> GlobalReg -> b) -> b -> a -> b
fold b -> GlobalReg -> b
f ((b -> GlobalReg -> b) -> b -> [GlobalReg] -> b
forall a b.
UserOfRegs GlobalReg a =>
(b -> GlobalReg -> b) -> b -> a -> b
fold b -> GlobalReg -> b
f b
z [GlobalReg]
args) CmmExpr
tgt
CmmForeignCall {tgt :: CmmNode 'Open 'Closed -> ForeignTarget
tgt=ForeignTarget
tgt, args :: CmmNode 'Open 'Closed -> [CmmExpr]
args=[CmmExpr]
args} -> (b -> GlobalReg -> b) -> b -> [CmmExpr] -> b
forall a b.
UserOfRegs GlobalReg a =>
(b -> GlobalReg -> b) -> b -> a -> b
fold b -> GlobalReg -> b
f ((b -> GlobalReg -> b) -> b -> ForeignTarget -> b
forall a b.
UserOfRegs GlobalReg a =>
(b -> GlobalReg -> b) -> b -> a -> b
fold b -> GlobalReg -> b
f b
z ForeignTarget
tgt) [CmmExpr]
args
CmmNode e x
_ -> b
z
where fold :: forall a b. UserOfRegs GlobalReg a
=> (b -> GlobalReg -> b) -> b -> a -> b
fold :: forall a b.
UserOfRegs GlobalReg a =>
(b -> GlobalReg -> b) -> b -> a -> b
fold b -> GlobalReg -> b
f b
z a
n = Platform -> (b -> GlobalReg -> b) -> b -> a -> b
forall b. Platform -> (b -> GlobalReg -> b) -> b -> a -> b
forall r a b.
UserOfRegs r a =>
Platform -> (b -> r -> b) -> b -> a -> b
foldRegsUsed Platform
platform b -> GlobalReg -> b
f b
z a
n
instance (Ord r, UserOfRegs r CmmReg) => UserOfRegs r ForeignTarget where
{-# INLINEABLE foldRegsUsed #-}
foldRegsUsed :: forall b. Platform -> (b -> r -> b) -> b -> ForeignTarget -> b
foldRegsUsed Platform
_ b -> r -> b
_ !b
z (PrimTarget CallishMachOp
_) = b
z
foldRegsUsed Platform
platform b -> r -> b
f !b
z (ForeignTarget CmmExpr
e ForeignConvention
_) = Platform -> (b -> r -> b) -> b -> CmmExpr -> b
forall b. Platform -> (b -> r -> b) -> b -> CmmExpr -> b
forall r a b.
UserOfRegs r a =>
Platform -> (b -> r -> b) -> b -> a -> b
foldRegsUsed Platform
platform b -> r -> b
f b
z CmmExpr
e
instance DefinerOfRegs LocalReg (CmmNode e x) where
{-# INLINEABLE foldRegsDefd #-}
foldRegsDefd :: forall b.
Platform -> (b -> CmmFormal -> b) -> b -> CmmNode e x -> b
foldRegsDefd Platform
platform b -> CmmFormal -> b
f !b
z CmmNode e x
n = case CmmNode e x
n of
CmmAssign CmmReg
lhs CmmExpr
_ -> (b -> CmmFormal -> b) -> b -> CmmReg -> b
forall a b.
DefinerOfRegs CmmFormal a =>
(b -> CmmFormal -> b) -> b -> a -> b
fold b -> CmmFormal -> b
f b
z CmmReg
lhs
CmmUnsafeForeignCall ForeignTarget
_ [CmmFormal]
fs [CmmExpr]
_ -> (b -> CmmFormal -> b) -> b -> [CmmFormal] -> b
forall a b.
DefinerOfRegs CmmFormal a =>
(b -> CmmFormal -> b) -> b -> a -> b
fold b -> CmmFormal -> b
f b
z [CmmFormal]
fs
CmmForeignCall {res :: CmmNode 'Open 'Closed -> [CmmFormal]
res=[CmmFormal]
res} -> (b -> CmmFormal -> b) -> b -> [CmmFormal] -> b
forall a b.
DefinerOfRegs CmmFormal a =>
(b -> CmmFormal -> b) -> b -> a -> b
fold b -> CmmFormal -> b
f b
z [CmmFormal]
res
CmmNode e x
_ -> b
z
where fold :: forall a b. DefinerOfRegs LocalReg a
=> (b -> LocalReg -> b) -> b -> a -> b
fold :: forall a b.
DefinerOfRegs CmmFormal a =>
(b -> CmmFormal -> b) -> b -> a -> b
fold b -> CmmFormal -> b
f b
z a
n = Platform -> (b -> CmmFormal -> b) -> b -> a -> b
forall b. Platform -> (b -> CmmFormal -> b) -> b -> a -> b
forall r a b.
DefinerOfRegs r a =>
Platform -> (b -> r -> b) -> b -> a -> b
foldRegsDefd Platform
platform b -> CmmFormal -> b
f b
z a
n
instance DefinerOfRegs GlobalReg (CmmNode e x) where
{-# INLINEABLE foldRegsDefd #-}
foldRegsDefd :: forall b.
Platform -> (b -> GlobalReg -> b) -> b -> CmmNode e x -> b
foldRegsDefd Platform
platform b -> GlobalReg -> b
f !b
z CmmNode e x
n = case CmmNode e x
n of
CmmAssign CmmReg
lhs CmmExpr
_ -> (b -> GlobalReg -> b) -> b -> CmmReg -> b
forall a b.
DefinerOfRegs GlobalReg a =>
(b -> GlobalReg -> b) -> b -> a -> b
fold b -> GlobalReg -> b
f b
z CmmReg
lhs
CmmUnsafeForeignCall ForeignTarget
tgt [CmmFormal]
_ [CmmExpr]
_ -> (b -> GlobalReg -> b) -> b -> [GlobalReg] -> b
forall a b.
DefinerOfRegs GlobalReg a =>
(b -> GlobalReg -> b) -> b -> a -> b
fold b -> GlobalReg -> b
f b
z (ForeignTarget -> [GlobalReg]
foreignTargetRegs ForeignTarget
tgt)
CmmCall {} -> (b -> GlobalReg -> b) -> b -> [GlobalReg] -> b
forall a b.
DefinerOfRegs GlobalReg a =>
(b -> GlobalReg -> b) -> b -> a -> b
fold b -> GlobalReg -> b
f b
z [GlobalReg]
activeRegs
CmmForeignCall {} -> (b -> GlobalReg -> b) -> b -> [GlobalReg] -> b
forall a b.
DefinerOfRegs GlobalReg a =>
(b -> GlobalReg -> b) -> b -> a -> b
fold b -> GlobalReg -> b
f b
z [GlobalReg]
activeRegs
CmmNode e x
_ -> b
z
where fold :: forall a b. DefinerOfRegs GlobalReg a
=> (b -> GlobalReg -> b) -> b -> a -> b
fold :: forall a b.
DefinerOfRegs GlobalReg a =>
(b -> GlobalReg -> b) -> b -> a -> b
fold b -> GlobalReg -> b
f b
z a
n = Platform -> (b -> GlobalReg -> b) -> b -> a -> b
forall b. Platform -> (b -> GlobalReg -> b) -> b -> a -> b
forall r a b.
DefinerOfRegs r a =>
Platform -> (b -> r -> b) -> b -> a -> b
foldRegsDefd Platform
platform b -> GlobalReg -> b
f b
z a
n
activeRegs :: [GlobalReg]
activeRegs = Platform -> [GlobalReg]
activeStgRegs Platform
platform
activeCallerSavesRegs :: [GlobalReg]
activeCallerSavesRegs = (GlobalReg -> Bool) -> [GlobalReg] -> [GlobalReg]
forall a. (a -> Bool) -> [a] -> [a]
filter (Platform -> GlobalReg -> Bool
callerSaves Platform
platform) [GlobalReg]
activeRegs
foreignTargetRegs :: ForeignTarget -> [GlobalReg]
foreignTargetRegs (ForeignTarget CmmExpr
_ (ForeignConvention CCallConv
_ [ForeignHint]
_ [ForeignHint]
_ CmmReturnInfo
CmmNeverReturns)) = []
foreignTargetRegs ForeignTarget
_ = [GlobalReg]
activeCallerSavesRegs
mapForeignTarget :: (CmmExpr -> CmmExpr) -> ForeignTarget -> ForeignTarget
mapForeignTarget :: (CmmExpr -> CmmExpr) -> ForeignTarget -> ForeignTarget
mapForeignTarget CmmExpr -> CmmExpr
exp (ForeignTarget CmmExpr
e ForeignConvention
c) = CmmExpr -> ForeignConvention -> ForeignTarget
ForeignTarget (CmmExpr -> CmmExpr
exp CmmExpr
e) ForeignConvention
c
mapForeignTarget CmmExpr -> CmmExpr
_ m :: ForeignTarget
m@(PrimTarget CallishMachOp
_) = ForeignTarget
m
wrapRecExp :: (CmmExpr -> CmmExpr) -> CmmExpr -> CmmExpr
wrapRecExp :: (CmmExpr -> CmmExpr) -> CmmExpr -> CmmExpr
wrapRecExp CmmExpr -> CmmExpr
f (CmmMachOp MachOp
op [CmmExpr]
es) = CmmExpr -> CmmExpr
f (MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp MachOp
op ([CmmExpr] -> CmmExpr) -> [CmmExpr] -> CmmExpr
forall a b. (a -> b) -> a -> b
$ (CmmExpr -> CmmExpr) -> [CmmExpr] -> [CmmExpr]
forall a b. (a -> b) -> [a] -> [b]
map ((CmmExpr -> CmmExpr) -> CmmExpr -> CmmExpr
wrapRecExp CmmExpr -> CmmExpr
f) [CmmExpr]
es)
wrapRecExp CmmExpr -> CmmExpr
f (CmmLoad CmmExpr
addr CmmType
ty AlignmentSpec
align) = CmmExpr -> CmmExpr
f (CmmExpr -> CmmType -> AlignmentSpec -> CmmExpr
CmmLoad ((CmmExpr -> CmmExpr) -> CmmExpr -> CmmExpr
wrapRecExp CmmExpr -> CmmExpr
f CmmExpr
addr) CmmType
ty AlignmentSpec
align)
wrapRecExp CmmExpr -> CmmExpr
f CmmExpr
e = CmmExpr -> CmmExpr
f CmmExpr
e
mapExp :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
mapExp :: forall (e :: Extensibility) (x :: Extensibility).
(CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
mapExp CmmExpr -> CmmExpr
_ f :: CmmNode e x
f@(CmmEntry{}) = CmmNode e x
f
mapExp CmmExpr -> CmmExpr
_ m :: CmmNode e x
m@(CmmComment FastString
_) = CmmNode e x
m
mapExp CmmExpr -> CmmExpr
_ m :: CmmNode e x
m@(CmmTick CmmTickish
_) = CmmNode e x
m
mapExp CmmExpr -> CmmExpr
f (CmmUnwind [(GlobalReg, Maybe CmmExpr)]
regs) = [(GlobalReg, Maybe CmmExpr)] -> CmmNode 'Open 'Open
CmmUnwind (((GlobalReg, Maybe CmmExpr) -> (GlobalReg, Maybe CmmExpr))
-> [(GlobalReg, Maybe CmmExpr)] -> [(GlobalReg, Maybe CmmExpr)]
forall a b. (a -> b) -> [a] -> [b]
map ((Maybe CmmExpr -> Maybe CmmExpr)
-> (GlobalReg, Maybe CmmExpr) -> (GlobalReg, Maybe CmmExpr)
forall a b. (a -> b) -> (GlobalReg, a) -> (GlobalReg, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((CmmExpr -> CmmExpr) -> Maybe CmmExpr -> Maybe CmmExpr
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CmmExpr -> CmmExpr
f)) [(GlobalReg, Maybe CmmExpr)]
regs)
mapExp CmmExpr -> CmmExpr
f (CmmAssign CmmReg
r CmmExpr
e) = CmmReg -> CmmExpr -> CmmNode 'Open 'Open
CmmAssign CmmReg
r (CmmExpr -> CmmExpr
f CmmExpr
e)
mapExp CmmExpr -> CmmExpr
f (CmmStore CmmExpr
addr CmmExpr
e AlignmentSpec
align) = CmmExpr -> CmmExpr -> AlignmentSpec -> CmmNode 'Open 'Open
CmmStore (CmmExpr -> CmmExpr
f CmmExpr
addr) (CmmExpr -> CmmExpr
f CmmExpr
e) AlignmentSpec
align
mapExp CmmExpr -> CmmExpr
f (CmmUnsafeForeignCall ForeignTarget
tgt [CmmFormal]
fs [CmmExpr]
as) = ForeignTarget -> [CmmFormal] -> [CmmExpr] -> CmmNode 'Open 'Open
CmmUnsafeForeignCall ((CmmExpr -> CmmExpr) -> ForeignTarget -> ForeignTarget
mapForeignTarget CmmExpr -> CmmExpr
f ForeignTarget
tgt) [CmmFormal]
fs ((CmmExpr -> CmmExpr) -> [CmmExpr] -> [CmmExpr]
forall a b. (a -> b) -> [a] -> [b]
map CmmExpr -> CmmExpr
f [CmmExpr]
as)
mapExp CmmExpr -> CmmExpr
_ l :: CmmNode e x
l@(CmmBranch Label
_) = CmmNode e x
l
mapExp CmmExpr -> CmmExpr
f (CmmCondBranch CmmExpr
e Label
ti Label
fi Maybe Bool
l) = CmmExpr -> Label -> Label -> Maybe Bool -> CmmNode 'Open 'Closed
CmmCondBranch (CmmExpr -> CmmExpr
f CmmExpr
e) Label
ti Label
fi Maybe Bool
l
mapExp CmmExpr -> CmmExpr
f (CmmSwitch CmmExpr
e SwitchTargets
ids) = CmmExpr -> SwitchTargets -> CmmNode 'Open 'Closed
CmmSwitch (CmmExpr -> CmmExpr
f CmmExpr
e) SwitchTargets
ids
mapExp CmmExpr -> CmmExpr
f n :: CmmNode e x
n@CmmCall {cml_target :: CmmNode 'Open 'Closed -> CmmExpr
cml_target=CmmExpr
tgt} = CmmNode e x
n{cml_target = f tgt}
mapExp CmmExpr -> CmmExpr
f (CmmForeignCall ForeignTarget
tgt [CmmFormal]
fs [CmmExpr]
as Label
succ ByteOff
ret_args ByteOff
updfr Bool
intrbl) = ForeignTarget
-> [CmmFormal]
-> [CmmExpr]
-> Label
-> ByteOff
-> ByteOff
-> Bool
-> CmmNode 'Open 'Closed
CmmForeignCall ((CmmExpr -> CmmExpr) -> ForeignTarget -> ForeignTarget
mapForeignTarget CmmExpr -> CmmExpr
f ForeignTarget
tgt) [CmmFormal]
fs ((CmmExpr -> CmmExpr) -> [CmmExpr] -> [CmmExpr]
forall a b. (a -> b) -> [a] -> [b]
map CmmExpr -> CmmExpr
f [CmmExpr]
as) Label
succ ByteOff
ret_args ByteOff
updfr Bool
intrbl
mapExpDeep :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
mapExpDeep :: forall (e :: Extensibility) (x :: Extensibility).
(CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
mapExpDeep CmmExpr -> CmmExpr
f = (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
forall (e :: Extensibility) (x :: Extensibility).
(CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
mapExp ((CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x)
-> (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
forall a b. (a -> b) -> a -> b
$ (CmmExpr -> CmmExpr) -> CmmExpr -> CmmExpr
wrapRecExp CmmExpr -> CmmExpr
f
mapForeignTargetM :: (CmmExpr -> Maybe CmmExpr) -> ForeignTarget -> Maybe ForeignTarget
mapForeignTargetM :: (CmmExpr -> Maybe CmmExpr) -> ForeignTarget -> Maybe ForeignTarget
mapForeignTargetM CmmExpr -> Maybe CmmExpr
f (ForeignTarget CmmExpr
e ForeignConvention
c) = (\CmmExpr
x -> CmmExpr -> ForeignConvention -> ForeignTarget
ForeignTarget CmmExpr
x ForeignConvention
c) (CmmExpr -> ForeignTarget) -> Maybe CmmExpr -> Maybe ForeignTarget
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` CmmExpr -> Maybe CmmExpr
f CmmExpr
e
mapForeignTargetM CmmExpr -> Maybe CmmExpr
_ (PrimTarget CallishMachOp
_) = Maybe ForeignTarget
forall a. Maybe a
Nothing
wrapRecExpM :: (CmmExpr -> Maybe CmmExpr) -> (CmmExpr -> Maybe CmmExpr)
wrapRecExpM :: (CmmExpr -> Maybe CmmExpr) -> CmmExpr -> Maybe CmmExpr
wrapRecExpM CmmExpr -> Maybe CmmExpr
f n :: CmmExpr
n@(CmmMachOp MachOp
op [CmmExpr]
es) = Maybe CmmExpr
-> ([CmmExpr] -> Maybe CmmExpr) -> Maybe [CmmExpr] -> Maybe CmmExpr
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (CmmExpr -> Maybe CmmExpr
f CmmExpr
n) (CmmExpr -> Maybe CmmExpr
f (CmmExpr -> Maybe CmmExpr)
-> ([CmmExpr] -> CmmExpr) -> [CmmExpr] -> Maybe CmmExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp MachOp
op) ((CmmExpr -> Maybe CmmExpr) -> [CmmExpr] -> Maybe [CmmExpr]
forall a. (a -> Maybe a) -> [a] -> Maybe [a]
mapListM ((CmmExpr -> Maybe CmmExpr) -> CmmExpr -> Maybe CmmExpr
wrapRecExpM CmmExpr -> Maybe CmmExpr
f) [CmmExpr]
es)
wrapRecExpM CmmExpr -> Maybe CmmExpr
f n :: CmmExpr
n@(CmmLoad CmmExpr
addr CmmType
ty AlignmentSpec
align) = Maybe CmmExpr
-> (CmmExpr -> Maybe CmmExpr) -> Maybe CmmExpr -> Maybe CmmExpr
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (CmmExpr -> Maybe CmmExpr
f CmmExpr
n) (\CmmExpr
addr' -> CmmExpr -> Maybe CmmExpr
f (CmmExpr -> Maybe CmmExpr) -> CmmExpr -> Maybe CmmExpr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> CmmType -> AlignmentSpec -> CmmExpr
CmmLoad CmmExpr
addr' CmmType
ty AlignmentSpec
align) ((CmmExpr -> Maybe CmmExpr) -> CmmExpr -> Maybe CmmExpr
wrapRecExpM CmmExpr -> Maybe CmmExpr
f CmmExpr
addr)
wrapRecExpM CmmExpr -> Maybe CmmExpr
f CmmExpr
e = CmmExpr -> Maybe CmmExpr
f CmmExpr
e
mapExpM :: (CmmExpr -> Maybe CmmExpr) -> CmmNode e x -> Maybe (CmmNode e x)
mapExpM :: forall (e :: Extensibility) (x :: Extensibility).
(CmmExpr -> Maybe CmmExpr) -> CmmNode e x -> Maybe (CmmNode e x)
mapExpM CmmExpr -> Maybe CmmExpr
_ (CmmEntry{}) = Maybe (CmmNode e x)
forall a. Maybe a
Nothing
mapExpM CmmExpr -> Maybe CmmExpr
_ (CmmComment FastString
_) = Maybe (CmmNode e x)
forall a. Maybe a
Nothing
mapExpM CmmExpr -> Maybe CmmExpr
_ (CmmTick CmmTickish
_) = Maybe (CmmNode e x)
forall a. Maybe a
Nothing
mapExpM CmmExpr -> Maybe CmmExpr
f (CmmUnwind [(GlobalReg, Maybe CmmExpr)]
regs) = [(GlobalReg, Maybe CmmExpr)] -> CmmNode e x
[(GlobalReg, Maybe CmmExpr)] -> CmmNode 'Open 'Open
CmmUnwind ([(GlobalReg, Maybe CmmExpr)] -> CmmNode e x)
-> Maybe [(GlobalReg, Maybe CmmExpr)] -> Maybe (CmmNode e x)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` ((GlobalReg, Maybe CmmExpr) -> Maybe (GlobalReg, Maybe CmmExpr))
-> [(GlobalReg, Maybe CmmExpr)]
-> Maybe [(GlobalReg, Maybe CmmExpr)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\(GlobalReg
r,Maybe CmmExpr
e) -> (CmmExpr -> Maybe CmmExpr)
-> Maybe CmmExpr -> Maybe (Maybe CmmExpr)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Maybe a -> m (Maybe b)
mapM CmmExpr -> Maybe CmmExpr
f Maybe CmmExpr
e Maybe (Maybe CmmExpr)
-> (Maybe CmmExpr -> Maybe (GlobalReg, Maybe CmmExpr))
-> Maybe (GlobalReg, Maybe CmmExpr)
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Maybe CmmExpr
e' -> (GlobalReg, Maybe CmmExpr) -> Maybe (GlobalReg, Maybe CmmExpr)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GlobalReg
r,Maybe CmmExpr
e')) [(GlobalReg, Maybe CmmExpr)]
regs
mapExpM CmmExpr -> Maybe CmmExpr
f (CmmAssign CmmReg
r CmmExpr
e) = CmmReg -> CmmExpr -> CmmNode 'Open 'Open
CmmAssign CmmReg
r (CmmExpr -> CmmNode e x) -> Maybe CmmExpr -> Maybe (CmmNode e x)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` CmmExpr -> Maybe CmmExpr
f CmmExpr
e
mapExpM CmmExpr -> Maybe CmmExpr
f (CmmStore CmmExpr
addr CmmExpr
e AlignmentSpec
align) = (\ (Pair CmmExpr
addr' CmmExpr
e') -> CmmExpr -> CmmExpr -> AlignmentSpec -> CmmNode 'Open 'Open
CmmStore CmmExpr
addr' CmmExpr
e' AlignmentSpec
align) (Pair CmmExpr -> CmmNode e x)
-> Maybe (Pair CmmExpr) -> Maybe (CmmNode e x)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (CmmExpr -> Maybe CmmExpr) -> Pair CmmExpr -> Maybe (Pair CmmExpr)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Pair a -> f (Pair b)
traverse CmmExpr -> Maybe CmmExpr
f (CmmExpr -> CmmExpr -> Pair CmmExpr
forall a. a -> a -> Pair a
Pair CmmExpr
addr CmmExpr
e)
mapExpM CmmExpr -> Maybe CmmExpr
_ (CmmBranch Label
_) = Maybe (CmmNode e x)
forall a. Maybe a
Nothing
mapExpM CmmExpr -> Maybe CmmExpr
f (CmmCondBranch CmmExpr
e Label
ti Label
fi Maybe Bool
l) = (\CmmExpr
x -> CmmExpr -> Label -> Label -> Maybe Bool -> CmmNode 'Open 'Closed
CmmCondBranch CmmExpr
x Label
ti Label
fi Maybe Bool
l) (CmmExpr -> CmmNode e x) -> Maybe CmmExpr -> Maybe (CmmNode e x)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` CmmExpr -> Maybe CmmExpr
f CmmExpr
e
mapExpM CmmExpr -> Maybe CmmExpr
f (CmmSwitch CmmExpr
e SwitchTargets
tbl) = (\CmmExpr
x -> CmmExpr -> SwitchTargets -> CmmNode 'Open 'Closed
CmmSwitch CmmExpr
x SwitchTargets
tbl) (CmmExpr -> CmmNode e x) -> Maybe CmmExpr -> Maybe (CmmNode e x)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` CmmExpr -> Maybe CmmExpr
f CmmExpr
e
mapExpM CmmExpr -> Maybe CmmExpr
f (CmmCall CmmExpr
tgt Maybe Label
mb_id [GlobalReg]
r ByteOff
o ByteOff
i ByteOff
s) = (\CmmExpr
x -> CmmExpr
-> Maybe Label
-> [GlobalReg]
-> ByteOff
-> ByteOff
-> ByteOff
-> CmmNode 'Open 'Closed
CmmCall CmmExpr
x Maybe Label
mb_id [GlobalReg]
r ByteOff
o ByteOff
i ByteOff
s) (CmmExpr -> CmmNode e x) -> Maybe CmmExpr -> Maybe (CmmNode e x)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` CmmExpr -> Maybe CmmExpr
f CmmExpr
tgt
mapExpM CmmExpr -> Maybe CmmExpr
f (CmmUnsafeForeignCall ForeignTarget
tgt [CmmFormal]
fs [CmmExpr]
as)
= case (CmmExpr -> Maybe CmmExpr) -> ForeignTarget -> Maybe ForeignTarget
mapForeignTargetM CmmExpr -> Maybe CmmExpr
f ForeignTarget
tgt of
Just ForeignTarget
tgt' -> CmmNode e x -> Maybe (CmmNode e x)
forall a. a -> Maybe a
Just (ForeignTarget -> [CmmFormal] -> [CmmExpr] -> CmmNode 'Open 'Open
CmmUnsafeForeignCall ForeignTarget
tgt' [CmmFormal]
fs ((CmmExpr -> Maybe CmmExpr) -> [CmmExpr] -> [CmmExpr]
forall a. (a -> Maybe a) -> [a] -> [a]
mapListJ CmmExpr -> Maybe CmmExpr
f [CmmExpr]
as))
Maybe ForeignTarget
Nothing -> (\[CmmExpr]
xs -> ForeignTarget -> [CmmFormal] -> [CmmExpr] -> CmmNode 'Open 'Open
CmmUnsafeForeignCall ForeignTarget
tgt [CmmFormal]
fs [CmmExpr]
xs) ([CmmExpr] -> CmmNode e x)
-> Maybe [CmmExpr] -> Maybe (CmmNode e x)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (CmmExpr -> Maybe CmmExpr) -> [CmmExpr] -> Maybe [CmmExpr]
forall a. (a -> Maybe a) -> [a] -> Maybe [a]
mapListM CmmExpr -> Maybe CmmExpr
f [CmmExpr]
as
mapExpM CmmExpr -> Maybe CmmExpr
f (CmmForeignCall ForeignTarget
tgt [CmmFormal]
fs [CmmExpr]
as Label
succ ByteOff
ret_args ByteOff
updfr Bool
intrbl)
= case (CmmExpr -> Maybe CmmExpr) -> ForeignTarget -> Maybe ForeignTarget
mapForeignTargetM CmmExpr -> Maybe CmmExpr
f ForeignTarget
tgt of
Just ForeignTarget
tgt' -> CmmNode e x -> Maybe (CmmNode e x)
forall a. a -> Maybe a
Just (ForeignTarget
-> [CmmFormal]
-> [CmmExpr]
-> Label
-> ByteOff
-> ByteOff
-> Bool
-> CmmNode 'Open 'Closed
CmmForeignCall ForeignTarget
tgt' [CmmFormal]
fs ((CmmExpr -> Maybe CmmExpr) -> [CmmExpr] -> [CmmExpr]
forall a. (a -> Maybe a) -> [a] -> [a]
mapListJ CmmExpr -> Maybe CmmExpr
f [CmmExpr]
as) Label
succ ByteOff
ret_args ByteOff
updfr Bool
intrbl)
Maybe ForeignTarget
Nothing -> (\[CmmExpr]
xs -> ForeignTarget
-> [CmmFormal]
-> [CmmExpr]
-> Label
-> ByteOff
-> ByteOff
-> Bool
-> CmmNode 'Open 'Closed
CmmForeignCall ForeignTarget
tgt [CmmFormal]
fs [CmmExpr]
xs Label
succ ByteOff
ret_args ByteOff
updfr Bool
intrbl) ([CmmExpr] -> CmmNode e x)
-> Maybe [CmmExpr] -> Maybe (CmmNode e x)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (CmmExpr -> Maybe CmmExpr) -> [CmmExpr] -> Maybe [CmmExpr]
forall a. (a -> Maybe a) -> [a] -> Maybe [a]
mapListM CmmExpr -> Maybe CmmExpr
f [CmmExpr]
as
mapListM :: (a -> Maybe a) -> [a] -> Maybe [a]
mapListM :: forall a. (a -> Maybe a) -> [a] -> Maybe [a]
mapListM a -> Maybe a
f [a]
xs = let (Bool
b, [a]
r) = (a -> Maybe a) -> [a] -> (Bool, [a])
forall a. (a -> Maybe a) -> [a] -> (Bool, [a])
mapListT a -> Maybe a
f [a]
xs
in if Bool
b then [a] -> Maybe [a]
forall a. a -> Maybe a
Just [a]
r else Maybe [a]
forall a. Maybe a
Nothing
mapListJ :: (a -> Maybe a) -> [a] -> [a]
mapListJ :: forall a. (a -> Maybe a) -> [a] -> [a]
mapListJ a -> Maybe a
f [a]
xs = (Bool, [a]) -> [a]
forall a b. (a, b) -> b
snd ((a -> Maybe a) -> [a] -> (Bool, [a])
forall a. (a -> Maybe a) -> [a] -> (Bool, [a])
mapListT a -> Maybe a
f [a]
xs)
mapListT :: (a -> Maybe a) -> [a] -> (Bool, [a])
mapListT :: forall a. (a -> Maybe a) -> [a] -> (Bool, [a])
mapListT a -> Maybe a
f [a]
xs = (([a], a, Maybe a) -> (Bool, [a]) -> (Bool, [a]))
-> (Bool, [a]) -> [([a], a, Maybe a)] -> (Bool, [a])
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ([a], a, Maybe a) -> (Bool, [a]) -> (Bool, [a])
forall {a}. ([a], a, Maybe a) -> (Bool, [a]) -> (Bool, [a])
g (Bool
False, []) ([[a]] -> [a] -> [Maybe a] -> [([a], a, Maybe a)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 ([a] -> [[a]]
forall a. [a] -> [[a]]
tails [a]
xs) [a]
xs ((a -> Maybe a) -> [a] -> [Maybe a]
forall a b. (a -> b) -> [a] -> [b]
map a -> Maybe a
f [a]
xs))
where g :: ([a], a, Maybe a) -> (Bool, [a]) -> (Bool, [a])
g ([a]
_, a
y, Maybe a
Nothing) (Bool
True, [a]
ys) = (Bool
True, a
ya -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
ys)
g ([a]
_, a
_, Just a
y) (Bool
True, [a]
ys) = (Bool
True, a
ya -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
ys)
g ([a]
ys', a
_, Maybe a
Nothing) (Bool
False, [a]
_) = (Bool
False, [a]
ys')
g ([a]
_, a
_, Just a
y) (Bool
False, [a]
ys) = (Bool
True, a
ya -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
ys)
mapExpDeepM :: (CmmExpr -> Maybe CmmExpr) -> CmmNode e x -> Maybe (CmmNode e x)
mapExpDeepM :: forall (e :: Extensibility) (x :: Extensibility).
(CmmExpr -> Maybe CmmExpr) -> CmmNode e x -> Maybe (CmmNode e x)
mapExpDeepM CmmExpr -> Maybe CmmExpr
f = (CmmExpr -> Maybe CmmExpr) -> CmmNode e x -> Maybe (CmmNode e x)
forall (e :: Extensibility) (x :: Extensibility).
(CmmExpr -> Maybe CmmExpr) -> CmmNode e x -> Maybe (CmmNode e x)
mapExpM ((CmmExpr -> Maybe CmmExpr) -> CmmNode e x -> Maybe (CmmNode e x))
-> (CmmExpr -> Maybe CmmExpr) -> CmmNode e x -> Maybe (CmmNode e x)
forall a b. (a -> b) -> a -> b
$ (CmmExpr -> Maybe CmmExpr) -> CmmExpr -> Maybe CmmExpr
wrapRecExpM CmmExpr -> Maybe CmmExpr
f
foldExpForeignTarget :: (CmmExpr -> z -> z) -> ForeignTarget -> z -> z
foldExpForeignTarget :: forall z. (CmmExpr -> z -> z) -> ForeignTarget -> z -> z
foldExpForeignTarget CmmExpr -> z -> z
exp (ForeignTarget CmmExpr
e ForeignConvention
_) z
z = CmmExpr -> z -> z
exp CmmExpr
e z
z
foldExpForeignTarget CmmExpr -> z -> z
_ (PrimTarget CallishMachOp
_) z
z = z
z
wrapRecExpf :: (CmmExpr -> z -> z) -> CmmExpr -> z -> z
wrapRecExpf :: forall z. (CmmExpr -> z -> z) -> CmmExpr -> z -> z
wrapRecExpf CmmExpr -> z -> z
f e :: CmmExpr
e@(CmmMachOp MachOp
_ [CmmExpr]
es) z
z = (CmmExpr -> z -> z) -> z -> [CmmExpr] -> z
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((CmmExpr -> z -> z) -> CmmExpr -> z -> z
forall z. (CmmExpr -> z -> z) -> CmmExpr -> z -> z
wrapRecExpf CmmExpr -> z -> z
f) (CmmExpr -> z -> z
f CmmExpr
e z
z) [CmmExpr]
es
wrapRecExpf CmmExpr -> z -> z
f e :: CmmExpr
e@(CmmLoad CmmExpr
addr CmmType
_ AlignmentSpec
_) z
z = (CmmExpr -> z -> z) -> CmmExpr -> z -> z
forall z. (CmmExpr -> z -> z) -> CmmExpr -> z -> z
wrapRecExpf CmmExpr -> z -> z
f CmmExpr
addr (CmmExpr -> z -> z
f CmmExpr
e z
z)
wrapRecExpf CmmExpr -> z -> z
f CmmExpr
e z
z = CmmExpr -> z -> z
f CmmExpr
e z
z
foldExp :: (CmmExpr -> z -> z) -> CmmNode e x -> z -> z
foldExp :: forall z (e :: Extensibility) (x :: Extensibility).
(CmmExpr -> z -> z) -> CmmNode e x -> z -> z
foldExp CmmExpr -> z -> z
_ (CmmEntry {}) z
z = z
z
foldExp CmmExpr -> z -> z
_ (CmmComment {}) z
z = z
z
foldExp CmmExpr -> z -> z
_ (CmmTick {}) z
z = z
z
foldExp CmmExpr -> z -> z
f (CmmUnwind [(GlobalReg, Maybe CmmExpr)]
xs) z
z = (Maybe CmmExpr -> z -> z) -> z -> [Maybe CmmExpr] -> z
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((z -> z) -> (CmmExpr -> z -> z) -> Maybe CmmExpr -> z -> z
forall b a. b -> (a -> b) -> Maybe a -> b
maybe z -> z
forall a. a -> a
id CmmExpr -> z -> z
f) z
z (((GlobalReg, Maybe CmmExpr) -> Maybe CmmExpr)
-> [(GlobalReg, Maybe CmmExpr)] -> [Maybe CmmExpr]
forall a b. (a -> b) -> [a] -> [b]
map (GlobalReg, Maybe CmmExpr) -> Maybe CmmExpr
forall a b. (a, b) -> b
snd [(GlobalReg, Maybe CmmExpr)]
xs)
foldExp CmmExpr -> z -> z
f (CmmAssign CmmReg
_ CmmExpr
e) z
z = CmmExpr -> z -> z
f CmmExpr
e z
z
foldExp CmmExpr -> z -> z
f (CmmStore CmmExpr
addr CmmExpr
e AlignmentSpec
_) z
z = CmmExpr -> z -> z
f CmmExpr
addr (z -> z) -> z -> z
forall a b. (a -> b) -> a -> b
$ CmmExpr -> z -> z
f CmmExpr
e z
z
foldExp CmmExpr -> z -> z
f (CmmUnsafeForeignCall ForeignTarget
t [CmmFormal]
_ [CmmExpr]
as) z
z = (CmmExpr -> z -> z) -> z -> [CmmExpr] -> z
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr CmmExpr -> z -> z
f ((CmmExpr -> z -> z) -> ForeignTarget -> z -> z
forall z. (CmmExpr -> z -> z) -> ForeignTarget -> z -> z
foldExpForeignTarget CmmExpr -> z -> z
f ForeignTarget
t z
z) [CmmExpr]
as
foldExp CmmExpr -> z -> z
_ (CmmBranch Label
_) z
z = z
z
foldExp CmmExpr -> z -> z
f (CmmCondBranch CmmExpr
e Label
_ Label
_ Maybe Bool
_) z
z = CmmExpr -> z -> z
f CmmExpr
e z
z
foldExp CmmExpr -> z -> z
f (CmmSwitch CmmExpr
e SwitchTargets
_) z
z = CmmExpr -> z -> z
f CmmExpr
e z
z
foldExp CmmExpr -> z -> z
f (CmmCall {cml_target :: CmmNode 'Open 'Closed -> CmmExpr
cml_target=CmmExpr
tgt}) z
z = CmmExpr -> z -> z
f CmmExpr
tgt z
z
foldExp CmmExpr -> z -> z
f (CmmForeignCall {tgt :: CmmNode 'Open 'Closed -> ForeignTarget
tgt=ForeignTarget
tgt, args :: CmmNode 'Open 'Closed -> [CmmExpr]
args=[CmmExpr]
args}) z
z = (CmmExpr -> z -> z) -> z -> [CmmExpr] -> z
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr CmmExpr -> z -> z
f ((CmmExpr -> z -> z) -> ForeignTarget -> z -> z
forall z. (CmmExpr -> z -> z) -> ForeignTarget -> z -> z
foldExpForeignTarget CmmExpr -> z -> z
f ForeignTarget
tgt z
z) [CmmExpr]
args
foldExpDeep :: (CmmExpr -> z -> z) -> CmmNode e x -> z -> z
foldExpDeep :: forall z (e :: Extensibility) (x :: Extensibility).
(CmmExpr -> z -> z) -> CmmNode e x -> z -> z
foldExpDeep CmmExpr -> z -> z
f = (CmmExpr -> z -> z) -> CmmNode e x -> z -> z
forall z (e :: Extensibility) (x :: Extensibility).
(CmmExpr -> z -> z) -> CmmNode e x -> z -> z
foldExp ((CmmExpr -> z -> z) -> CmmExpr -> z -> z
forall z. (CmmExpr -> z -> z) -> CmmExpr -> z -> z
wrapRecExpf CmmExpr -> z -> z
f)
mapSuccessors :: (Label -> Label) -> CmmNode O C -> CmmNode O C
mapSuccessors :: (Label -> Label) -> CmmNode 'Open 'Closed -> CmmNode 'Open 'Closed
mapSuccessors Label -> Label
f (CmmBranch Label
bid) = Label -> CmmNode 'Open 'Closed
CmmBranch (Label -> Label
f Label
bid)
mapSuccessors Label -> Label
f (CmmCondBranch CmmExpr
p Label
y Label
n Maybe Bool
l) = CmmExpr -> Label -> Label -> Maybe Bool -> CmmNode 'Open 'Closed
CmmCondBranch CmmExpr
p (Label -> Label
f Label
y) (Label -> Label
f Label
n) Maybe Bool
l
mapSuccessors Label -> Label
f (CmmSwitch CmmExpr
e SwitchTargets
ids) = CmmExpr -> SwitchTargets -> CmmNode 'Open 'Closed
CmmSwitch CmmExpr
e ((Label -> Label) -> SwitchTargets -> SwitchTargets
mapSwitchTargets Label -> Label
f SwitchTargets
ids)
mapSuccessors Label -> Label
_ CmmNode 'Open 'Closed
n = CmmNode 'Open 'Closed
n
mapCollectSuccessors :: forall a. (Label -> (Label,a)) -> CmmNode O C
-> (CmmNode O C, [a])
mapCollectSuccessors :: forall a.
(Label -> (Label, a))
-> CmmNode 'Open 'Closed -> (CmmNode 'Open 'Closed, [a])
mapCollectSuccessors Label -> (Label, a)
f (CmmBranch Label
bid)
= let (Label
bid', a
acc) = Label -> (Label, a)
f Label
bid in (Label -> CmmNode 'Open 'Closed
CmmBranch Label
bid', [a
acc])
mapCollectSuccessors Label -> (Label, a)
f (CmmCondBranch CmmExpr
p Label
y Label
n Maybe Bool
l)
= let (Label
bidt, a
acct) = Label -> (Label, a)
f Label
y
(Label
bidf, a
accf) = Label -> (Label, a)
f Label
n
in (CmmExpr -> Label -> Label -> Maybe Bool -> CmmNode 'Open 'Closed
CmmCondBranch CmmExpr
p Label
bidt Label
bidf Maybe Bool
l, [a
accf, a
acct])
mapCollectSuccessors Label -> (Label, a)
f (CmmSwitch CmmExpr
e SwitchTargets
ids)
= let lbls :: [Label]
lbls = SwitchTargets -> [Label]
switchTargetsToList SwitchTargets
ids :: [Label]
lblMap :: LabelMap (Label, a)
lblMap = [(KeyOf LabelMap, (Label, a))] -> LabelMap (Label, a)
forall a. [(KeyOf LabelMap, a)] -> LabelMap a
forall (map :: * -> *) a. IsMap map => [(KeyOf map, a)] -> map a
mapFromList ([(KeyOf LabelMap, (Label, a))] -> LabelMap (Label, a))
-> [(KeyOf LabelMap, (Label, a))] -> LabelMap (Label, a)
forall a b. (a -> b) -> a -> b
$ [Label] -> [(Label, a)] -> [(Label, (Label, a))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Label]
lbls ((Label -> (Label, a)) -> [Label] -> [(Label, a)]
forall a b. (a -> b) -> [a] -> [b]
map Label -> (Label, a)
f [Label]
lbls) :: LabelMap (Label, a)
in ( CmmExpr -> SwitchTargets -> CmmNode 'Open 'Closed
CmmSwitch CmmExpr
e
((Label -> Label) -> SwitchTargets -> SwitchTargets
mapSwitchTargets
(\Label
l -> (Label, a) -> Label
forall a b. (a, b) -> a
fst ((Label, a) -> Label) -> (Label, a) -> Label
forall a b. (a -> b) -> a -> b
$ (Label, a) -> KeyOf LabelMap -> LabelMap (Label, a) -> (Label, a)
forall a. a -> KeyOf LabelMap -> LabelMap a -> a
forall (map :: * -> *) a. IsMap map => a -> KeyOf map -> map a -> a
mapFindWithDefault (String -> (Label, a)
forall a. HasCallStack => String -> a
error String
"impossible") KeyOf LabelMap
Label
l LabelMap (Label, a)
lblMap) SwitchTargets
ids)
, ((Label, a) -> a) -> [(Label, a)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (Label, a) -> a
forall a b. (a, b) -> b
snd (LabelMap (Label, a) -> [(Label, a)]
forall a. LabelMap a -> [a]
forall (map :: * -> *) a. IsMap map => map a -> [a]
mapElems LabelMap (Label, a)
lblMap)
)
mapCollectSuccessors Label -> (Label, a)
_ CmmNode 'Open 'Closed
n = (CmmNode 'Open 'Closed
n, [])
data CmmTickScope
= GlobalScope
| SubScope !U.Unique CmmTickScope
| CombinedScope CmmTickScope CmmTickScope
scopeToPaths :: CmmTickScope -> [[U.Unique]]
scopeToPaths :: CmmTickScope -> [[Unique]]
scopeToPaths CmmTickScope
GlobalScope = [[]]
scopeToPaths (SubScope Unique
u CmmTickScope
s) = ([Unique] -> [Unique]) -> [[Unique]] -> [[Unique]]
forall a b. (a -> b) -> [a] -> [b]
map (Unique
uUnique -> [Unique] -> [Unique]
forall a. a -> [a] -> [a]
:) (CmmTickScope -> [[Unique]]
scopeToPaths CmmTickScope
s)
scopeToPaths (CombinedScope CmmTickScope
s1 CmmTickScope
s2) = CmmTickScope -> [[Unique]]
scopeToPaths CmmTickScope
s1 [[Unique]] -> [[Unique]] -> [[Unique]]
forall a. [a] -> [a] -> [a]
++ CmmTickScope -> [[Unique]]
scopeToPaths CmmTickScope
s2
scopeUniques :: CmmTickScope -> [U.Unique]
scopeUniques :: CmmTickScope -> [Unique]
scopeUniques CmmTickScope
GlobalScope = []
scopeUniques (SubScope Unique
u CmmTickScope
_) = [Unique
u]
scopeUniques (CombinedScope CmmTickScope
s1 CmmTickScope
s2) = CmmTickScope -> [Unique]
scopeUniques CmmTickScope
s1 [Unique] -> [Unique] -> [Unique]
forall a. [a] -> [a] -> [a]
++ CmmTickScope -> [Unique]
scopeUniques CmmTickScope
s2
instance Eq CmmTickScope where
CmmTickScope
GlobalScope == :: CmmTickScope -> CmmTickScope -> Bool
== CmmTickScope
GlobalScope = Bool
True
CmmTickScope
GlobalScope == CmmTickScope
_ = Bool
False
CmmTickScope
_ == CmmTickScope
GlobalScope = Bool
False
(SubScope Unique
u CmmTickScope
_) == (SubScope Unique
u' CmmTickScope
_) = Unique
u Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
u'
(SubScope Unique
_ CmmTickScope
_) == CmmTickScope
_ = Bool
False
CmmTickScope
_ == (SubScope Unique
_ CmmTickScope
_) = Bool
False
CmmTickScope
scope == CmmTickScope
scope' =
(Unique -> Unique -> Ordering) -> [Unique] -> [Unique]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy Unique -> Unique -> Ordering
nonDetCmpUnique (CmmTickScope -> [Unique]
scopeUniques CmmTickScope
scope) [Unique] -> [Unique] -> Bool
forall a. Eq a => a -> a -> Bool
==
(Unique -> Unique -> Ordering) -> [Unique] -> [Unique]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy Unique -> Unique -> Ordering
nonDetCmpUnique (CmmTickScope -> [Unique]
scopeUniques CmmTickScope
scope')
instance Ord CmmTickScope where
compare :: CmmTickScope -> CmmTickScope -> Ordering
compare CmmTickScope
GlobalScope CmmTickScope
GlobalScope = Ordering
EQ
compare CmmTickScope
GlobalScope CmmTickScope
_ = Ordering
LT
compare CmmTickScope
_ CmmTickScope
GlobalScope = Ordering
GT
compare (SubScope Unique
u CmmTickScope
_) (SubScope Unique
u' CmmTickScope
_) = Unique -> Unique -> Ordering
nonDetCmpUnique Unique
u Unique
u'
compare CmmTickScope
scope CmmTickScope
scope' = (Unique -> Unique -> Ordering) -> [Unique] -> [Unique] -> Ordering
forall a b. (a -> b -> Ordering) -> [a] -> [b] -> Ordering
forall (f :: * -> *) a b.
Ord1 f =>
(a -> b -> Ordering) -> f a -> f b -> Ordering
liftCompare Unique -> Unique -> Ordering
nonDetCmpUnique
((Unique -> Unique -> Ordering) -> [Unique] -> [Unique]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy Unique -> Unique -> Ordering
nonDetCmpUnique ([Unique] -> [Unique]) -> [Unique] -> [Unique]
forall a b. (a -> b) -> a -> b
$ CmmTickScope -> [Unique]
scopeUniques CmmTickScope
scope)
((Unique -> Unique -> Ordering) -> [Unique] -> [Unique]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy Unique -> Unique -> Ordering
nonDetCmpUnique ([Unique] -> [Unique]) -> [Unique] -> [Unique]
forall a b. (a -> b) -> a -> b
$ CmmTickScope -> [Unique]
scopeUniques CmmTickScope
scope')
instance Outputable CmmTickScope where
ppr :: CmmTickScope -> SDoc
ppr CmmTickScope
GlobalScope = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"global"
ppr (SubScope Unique
us CmmTickScope
GlobalScope)
= Unique -> SDoc
forall a. Outputable a => a -> SDoc
ppr Unique
us
ppr (SubScope Unique
us CmmTickScope
s) = CmmTickScope -> SDoc
forall a. Outputable a => a -> SDoc
ppr CmmTickScope
s SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'/' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Unique -> SDoc
forall a. Outputable a => a -> SDoc
ppr Unique
us
ppr CmmTickScope
combined = SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
forall doc. IsLine doc => doc -> [doc] -> [doc]
punctuate (Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'+') ([SDoc] -> [SDoc]) -> [SDoc] -> [SDoc]
forall a b. (a -> b) -> a -> b
$
([Unique] -> SDoc) -> [[Unique]] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map ([SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hcat ([SDoc] -> SDoc) -> ([Unique] -> [SDoc]) -> [Unique] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDoc -> [SDoc] -> [SDoc]
forall doc. IsLine doc => doc -> [doc] -> [doc]
punctuate (Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'/') ([SDoc] -> [SDoc]) -> ([Unique] -> [SDoc]) -> [Unique] -> [SDoc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Unique -> SDoc) -> [Unique] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Unique -> SDoc
forall a. Outputable a => a -> SDoc
ppr ([Unique] -> [SDoc])
-> ([Unique] -> [Unique]) -> [Unique] -> [SDoc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Unique] -> [Unique]
forall a. [a] -> [a]
reverse) ([[Unique]] -> [SDoc]) -> [[Unique]] -> [SDoc]
forall a b. (a -> b) -> a -> b
$
CmmTickScope -> [[Unique]]
scopeToPaths CmmTickScope
combined
isTickSubScope :: CmmTickScope -> CmmTickScope -> Bool
isTickSubScope :: CmmTickScope -> CmmTickScope -> Bool
isTickSubScope = CmmTickScope -> CmmTickScope -> Bool
cmp
where cmp :: CmmTickScope -> CmmTickScope -> Bool
cmp CmmTickScope
_ CmmTickScope
GlobalScope = Bool
True
cmp CmmTickScope
GlobalScope CmmTickScope
_ = Bool
False
cmp (CombinedScope CmmTickScope
s1 CmmTickScope
s2) CmmTickScope
s' = CmmTickScope -> CmmTickScope -> Bool
cmp CmmTickScope
s1 CmmTickScope
s' Bool -> Bool -> Bool
&& CmmTickScope -> CmmTickScope -> Bool
cmp CmmTickScope
s2 CmmTickScope
s'
cmp CmmTickScope
s (CombinedScope CmmTickScope
s1' CmmTickScope
s2') = CmmTickScope -> CmmTickScope -> Bool
cmp CmmTickScope
s CmmTickScope
s1' Bool -> Bool -> Bool
|| CmmTickScope -> CmmTickScope -> Bool
cmp CmmTickScope
s CmmTickScope
s2'
cmp (SubScope Unique
u CmmTickScope
s) s' :: CmmTickScope
s'@(SubScope Unique
u' CmmTickScope
_) = Unique
u Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
u' Bool -> Bool -> Bool
|| CmmTickScope -> CmmTickScope -> Bool
cmp CmmTickScope
s CmmTickScope
s'
combineTickScopes :: CmmTickScope -> CmmTickScope -> CmmTickScope
combineTickScopes :: CmmTickScope -> CmmTickScope -> CmmTickScope
combineTickScopes CmmTickScope
s1 CmmTickScope
s2
| CmmTickScope
s1 CmmTickScope -> CmmTickScope -> Bool
`isTickSubScope` CmmTickScope
s2 = CmmTickScope
s1
| CmmTickScope
s2 CmmTickScope -> CmmTickScope -> Bool
`isTickSubScope` CmmTickScope
s1 = CmmTickScope
s2
| Bool
otherwise = CmmTickScope -> CmmTickScope -> CmmTickScope
CombinedScope CmmTickScope
s1 CmmTickScope
s2