{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE BlockArguments #-}
module GHC.StgToJS.Apply
( genApp
, rtsApply
)
where
import GHC.Prelude hiding ((.|.))
import GHC.JS.Syntax
import GHC.JS.Make
import GHC.StgToJS.Arg
import GHC.StgToJS.Closure
import GHC.StgToJS.DataCon
import GHC.StgToJS.ExprCtx
import GHC.StgToJS.Heap
import GHC.StgToJS.Monad
import GHC.StgToJS.Types
import GHC.StgToJS.Profiling
import GHC.StgToJS.Regs
import GHC.StgToJS.CoreUtils
import GHC.StgToJS.Utils
import GHC.StgToJS.Rts.Types
import GHC.StgToJS.Stack
import GHC.StgToJS.Ids
import GHC.Types.Literal
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Types.CostCentre
import GHC.Stg.Syntax
import GHC.Builtin.Names
import GHC.Core.TyCon
import GHC.Core.DataCon
import GHC.Core.Type hiding (typeSize)
import GHC.Utils.Encoding
import GHC.Utils.Misc
import GHC.Utils.Monad
import GHC.Utils.Panic
import GHC.Utils.Outputable (vcat, ppr)
import GHC.Data.FastString
import qualified Data.Bits as Bits
import Data.Monoid
import Data.Array
rtsApply :: StgToJSConfig -> JStat
rtsApply :: StgToJSConfig -> JStat
rtsApply StgToJSConfig
cfg = [JStat] -> JStat
BlockStat forall a b. (a -> b) -> a -> b
$
forall a b. (a -> b) -> [a] -> [b]
map (StgToJSConfig -> ApplySpec -> JStat
specApply StgToJSConfig
cfg) [ApplySpec]
applySpec
forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map (StgToJSConfig -> Int -> JStat
pap StgToJSConfig
cfg) [Int]
specPap
forall a. [a] -> [a] -> [a]
++ [ JStat
mkApplyArr
, StgToJSConfig -> JStat
genericStackApply StgToJSConfig
cfg
, StgToJSConfig -> JStat
genericFastApply StgToJSConfig
cfg
, StgToJSConfig -> JStat
zeroApply StgToJSConfig
cfg
, StgToJSConfig -> JStat
updates StgToJSConfig
cfg
, StgToJSConfig -> JStat
papGen StgToJSConfig
cfg
, JStat
moveRegs2
, StgToJSConfig -> JStat
selectors StgToJSConfig
cfg
]
genApp
:: HasDebugCallStack
=> ExprCtx
-> Id
-> [StgArg]
-> G (JStat, ExprResult)
genApp :: HasDebugCallStack =>
ExprCtx -> Id -> [StgArg] -> G (JStat, ExprResult)
genApp ExprCtx
ctx Id
i [StgArg]
args
| [StgLitArg (LitString ByteString
bs), StgArg
x] <- [StgArg]
args
, [JExpr
top] <- forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TypedExpr -> [JExpr]
typex_expr (ExprCtx -> [TypedExpr]
ctxTarget ExprCtx
ctx)
, forall a. Uniquable a => a -> Unique
getUnique Id
i forall a. Eq a => a -> a -> Bool
== Unique
unpackCStringAppendIdKey
, [Char]
d <- ByteString -> [Char]
utf8DecodeByteString ByteString
bs
= do
Bool
prof <- StgToJSConfig -> Bool
csProf forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> G StgToJSConfig
getSettings
let profArg :: [JExpr]
profArg = if Bool
prof then [JExpr
jCafCCS] else []
[JExpr]
a <- HasDebugCallStack => StgArg -> G [JExpr]
genArg StgArg
x
forall (m :: * -> *) a. Monad m => a -> m a
return ( JExpr
top JExpr -> JExpr -> JStat
|= FastString -> [JExpr] -> JExpr
app FastString
"h$appendToHsStringA" ([forall a. ToJExpr a => a -> JExpr
toJExpr [Char]
d, forall a. ToJExpr a => a -> JExpr
toJExpr [JExpr]
a] forall a. [a] -> [a] -> [a]
++ [JExpr]
profArg)
, Maybe [JExpr] -> ExprResult
ExprInline forall a. Maybe a
Nothing
)
| Just Int
n <- ExprCtx -> Id -> Maybe Int
ctxLneBindingStackSize ExprCtx
ctx Id
i
= do
[JExpr]
as' <- forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Traversable f) =>
(a -> m [b]) -> f a -> m [b]
concatMapM HasDebugCallStack => StgArg -> G [JExpr]
genArg [StgArg]
args
JExpr
ei <- Id -> G JExpr
varForEntryId Id
i
let ra :: JStat
ra = forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\StgReg
r JExpr
a -> forall a. ToJExpr a => a -> JExpr
toJExpr StgReg
r JExpr -> JExpr -> JStat
|= JExpr
a) [StgReg
R1 ..] [JExpr]
as'
JStat
p <- HasDebugCallStack => Int -> ExprCtx -> G JStat
pushLneFrame Int
n ExprCtx
ctx
JStat
a <- Int -> G JStat
adjSp Int
1
forall (m :: * -> *) a. Monad m => a -> m a
return (JStat
ra forall a. Semigroup a => a -> a -> a
<> JStat
p forall a. Semigroup a => a -> a -> a
<> JStat
a forall a. Semigroup a => a -> a -> a
<> JExpr -> JStat
returnS JExpr
ei, ExprResult
ExprCont)
| [] <- [StgArg]
args
, forall a. Uniquable a => a -> Unique
getUnique Id
i forall a. Eq a => a -> a -> Bool
== Unique
proxyHashKey
, [JExpr
top] <- forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TypedExpr -> [JExpr]
typex_expr (ExprCtx -> [TypedExpr]
ctxTarget ExprCtx
ctx)
= forall (m :: * -> *) a. Monad m => a -> m a
return (JExpr
top JExpr -> JExpr -> JStat
|= JExpr
null_, Maybe [JExpr] -> ExprResult
ExprInline forall a. Maybe a
Nothing)
| [] <- [StgArg]
args
, Type -> Bool
isUnboxedTupleType (Id -> Type
idType Id
i) Bool -> Bool -> Bool
|| HasDebugCallStack => Type -> Bool
isStrictType (Id -> Type
idType Id
i)
= do
JStat
a <- Id -> [TypedExpr] -> G JStat
storeIdFields Id
i (ExprCtx -> [TypedExpr]
ctxTarget ExprCtx
ctx)
forall (m :: * -> *) a. Monad m => a -> m a
return (JStat
a, Maybe [JExpr] -> ExprResult
ExprInline forall a. Maybe a
Nothing)
| [] <- [StgArg]
args
, [VarType
vt] <- HasDebugCallStack => Id -> [VarType]
idVt Id
i
, VarType -> Bool
isUnboxable VarType
vt
, ExprCtx -> Id -> Bool
ctxIsEvaluated ExprCtx
ctx Id
i
= do
let c :: JExpr
c = forall a. [a] -> a
head (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TypedExpr -> [JExpr]
typex_expr forall a b. (a -> b) -> a -> b
$ ExprCtx -> [TypedExpr]
ctxTarget ExprCtx
ctx)
[JExpr]
is <- Id -> G [JExpr]
varsForId Id
i
case [JExpr]
is of
[JExpr
i'] ->
forall (m :: * -> *) a. Monad m => a -> m a
return ( JExpr
c JExpr -> JExpr -> JStat
|= JExpr -> JExpr -> JExpr -> JExpr
if_ (JExpr -> JExpr
isObject JExpr
i') (JExpr -> JExpr
closureField1 JExpr
i') JExpr
i'
, Maybe [JExpr] -> ExprResult
ExprInline forall a. Maybe a
Nothing
)
[JExpr]
_ -> forall a. HasCallStack => [Char] -> a
panic [Char]
"genApp: invalid size"
| [] <- [StgArg]
args
, ExprCtx -> Id -> Bool
ctxIsEvaluated ExprCtx
ctx Id
i Bool -> Bool -> Bool
|| HasDebugCallStack => Type -> Bool
isStrictType (Id -> Type
idType Id
i)
= do
JStat
a <- Id -> [TypedExpr] -> G JStat
storeIdFields Id
i (ExprCtx -> [TypedExpr]
ctxTarget ExprCtx
ctx)
StgToJSConfig
settings <- G StgToJSConfig
getSettings
let ww :: JStat
ww = case forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TypedExpr -> [JExpr]
typex_expr (ExprCtx -> [TypedExpr]
ctxTarget ExprCtx
ctx) of
[JExpr
t] | StgToJSConfig -> Bool
csAssertRts StgToJSConfig
settings ->
JExpr -> JStat -> JStat -> JStat
ifS (JExpr -> JExpr
isObject JExpr
t JExpr -> JExpr -> JExpr
.&&. JExpr -> JExpr
isThunk JExpr
t)
(FastString -> [JExpr] -> JStat
appS FastString
"throw" [FastString -> JExpr
String FastString
"unexpected thunk"])
forall a. Monoid a => a
mempty
[JExpr]
_ -> forall a. Monoid a => a
mempty
forall (m :: * -> *) a. Monad m => a -> m a
return (JStat
a forall a. Monoid a => a -> a -> a
`mappend` JStat
ww, Maybe [JExpr] -> ExprResult
ExprInline forall a. Maybe a
Nothing)
| DataConWrapId DataCon
dc <- Id -> IdDetails
idDetails Id
i
, TyCon -> Bool
isNewTyCon (DataCon -> TyCon
dataConTyCon DataCon
dc)
= do
[JExpr]
as <- forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Traversable f) =>
(a -> m [b]) -> f a -> m [b]
concatMapM HasDebugCallStack => StgArg -> G [JExpr]
genArg [StgArg]
args
case [JExpr]
as of
[JExpr
ai] -> do
let t :: JExpr
t = forall a. [a] -> a
head (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TypedExpr -> [JExpr]
typex_expr (ExprCtx -> [TypedExpr]
ctxTarget ExprCtx
ctx))
a' :: Id
a' = case [StgArg]
args of
[StgVarArg Id
a'] -> Id
a'
[StgArg]
_ -> forall a. HasCallStack => [Char] -> a
panic [Char]
"genApp: unexpected arg"
if Id -> Bool
isStrictId Id
a' Bool -> Bool -> Bool
|| ExprCtx -> Id -> Bool
ctxIsEvaluated ExprCtx
ctx Id
a'
then forall (m :: * -> *) a. Monad m => a -> m a
return (JExpr
t JExpr -> JExpr -> JStat
|= JExpr
ai, Maybe [JExpr] -> ExprResult
ExprInline forall a. Maybe a
Nothing)
else forall (m :: * -> *) a. Monad m => a -> m a
return (JExpr -> JStat
returnS (FastString -> [JExpr] -> JExpr
app FastString
"h$e" [JExpr
ai]), ExprResult
ExprCont)
[JExpr]
_ -> forall a. HasCallStack => [Char] -> a
panic [Char]
"genApp: invalid size"
| [] <- [StgArg]
args
, Id -> Int
idFunRepArity Id
i forall a. Eq a => a -> a -> Bool
== Int
0
, Bool -> Bool
not (HasDebugCallStack => Type -> Bool
might_be_a_function (Id -> Type
idType Id
i))
= do
JExpr
enter_id <- HasDebugCallStack => Id -> G [JExpr]
genIdArg Id
i forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
\case
[JExpr
x] -> forall (m :: * -> *) a. Monad m => a -> m a
return JExpr
x
[JExpr]
xs -> forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"genApp: unexpected multi-var argument"
(forall doc. IsDoc doc => [doc] -> doc
vcat [forall a. Outputable a => a -> SDoc
ppr (forall (t :: * -> *) a. Foldable t => t a -> Int
length [JExpr]
xs), forall a. Outputable a => a -> SDoc
ppr Id
i])
forall (m :: * -> *) a. Monad m => a -> m a
return (JExpr -> JStat
returnS (FastString -> [JExpr] -> JExpr
app FastString
"h$e" [JExpr
enter_id]), ExprResult
ExprCont)
| Int
n <- forall (t :: * -> *) a. Foldable t => t a -> Int
length [StgArg]
args
, Int
n forall a. Eq a => a -> a -> Bool
/= Int
0
, Id -> Int
idFunRepArity Id
i forall a. Eq a => a -> a -> Bool
== Int
n
, Bool -> Bool
not (Id -> Bool
isLocalId Id
i)
, Id -> Bool
isStrictId Id
i
= do
[JExpr]
as' <- forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Traversable f) =>
(a -> m [b]) -> f a -> m [b]
concatMapM HasDebugCallStack => StgArg -> G [JExpr]
genArg [StgArg]
args
JStat
is <- [JExpr] -> [JExpr] -> JStat
assignAll [JExpr]
jsRegsFromR1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> G [JExpr]
varsForId Id
i
JStat
jmp <- Id -> [JExpr] -> JStat -> G JStat
jumpToII Id
i [JExpr]
as' JStat
is
forall (m :: * -> *) a. Monad m => a -> m a
return (JStat
jmp, ExprResult
ExprCont)
| Id -> Int
idFunRepArity Id
i forall a. Ord a => a -> a -> Bool
< forall (t :: * -> *) a. Foldable t => t a -> Int
length [StgArg]
args
, Id -> Bool
isStrictId Id
i
, Id -> Int
idFunRepArity Id
i forall a. Ord a => a -> a -> Bool
> Int
0
= do
let ([StgArg]
reg,[StgArg]
over) = forall a. Int -> [a] -> ([a], [a])
splitAt (Id -> Int
idFunRepArity Id
i) [StgArg]
args
[JExpr]
reg' <- forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Traversable f) =>
(a -> m [b]) -> f a -> m [b]
concatMapM HasDebugCallStack => StgArg -> G [JExpr]
genArg [StgArg]
reg
JStat
pc <- HasDebugCallStack => [StgArg] -> G JStat
pushCont [StgArg]
over
JStat
is <- [JExpr] -> [JExpr] -> JStat
assignAll [JExpr]
jsRegsFromR1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> G [JExpr]
varsForId Id
i
JStat
jmp <- Id -> [JExpr] -> JStat -> G JStat
jumpToII Id
i [JExpr]
reg' JStat
is
forall (m :: * -> *) a. Monad m => a -> m a
return (JStat
pc forall a. Semigroup a => a -> a -> a
<> JStat
jmp, ExprResult
ExprCont)
| Bool
otherwise
= do
JStat
is <- [JExpr] -> [JExpr] -> JStat
assignAll [JExpr]
jsRegsFromR1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> G [JExpr]
varsForId Id
i
JStat
jmp <- HasDebugCallStack => [StgArg] -> JStat -> G JStat
jumpToFast [StgArg]
args JStat
is
forall (m :: * -> *) a. Monad m => a -> m a
return (JStat
jmp, ExprResult
ExprCont)
jumpToII :: Id -> [JExpr] -> JStat -> G JStat
jumpToII :: Id -> [JExpr] -> JStat -> G JStat
jumpToII Id
i [JExpr]
vars JStat
load_app_in_r1
| Id -> Bool
isLocalId Id
i = do
JExpr
ii <- Id -> G JExpr
varForId Id
i
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat
[ [JExpr] -> [JExpr] -> JStat
assignAllReverseOrder [JExpr]
jsRegsFromR2 [JExpr]
vars
, JStat
load_app_in_r1
, JExpr -> JStat
returnS (JExpr -> JExpr
closureEntry JExpr
ii)
]
| Bool
otherwise = do
JExpr
ei <- Id -> G JExpr
varForEntryId Id
i
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat
[ [JExpr] -> [JExpr] -> JStat
assignAllReverseOrder [JExpr]
jsRegsFromR2 [JExpr]
vars
, JStat
load_app_in_r1
, JExpr -> JStat
returnS JExpr
ei
]
jumpToFast :: HasDebugCallStack => [StgArg] -> JStat -> G JStat
jumpToFast :: HasDebugCallStack => [StgArg] -> JStat -> G JStat
jumpToFast [StgArg]
args JStat
load_app_in_r1 = do
[JExpr]
vars <- forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Traversable f) =>
(a -> m [b]) -> f a -> m [b]
concatMapM HasDebugCallStack => StgArg -> G [JExpr]
genArg [StgArg]
args
let spec :: ApplySpec
spec = ApplyConv -> [StgArg] -> [JExpr] -> ApplySpec
mkApplySpec ApplyConv
RegsConv [StgArg]
args [JExpr]
vars
Either JExpr JExpr
ap_fun <- ApplySpec -> G (Either JExpr JExpr)
selectApply ApplySpec
spec
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat
[ [JExpr] -> [JExpr] -> JStat
assignAllReverseOrder [JExpr]
jsRegsFromR2 [JExpr]
vars
, JStat
load_app_in_r1
, case Either JExpr JExpr
ap_fun of
Right JExpr
fun -> JExpr -> JStat
returnS (JExpr -> [JExpr] -> JExpr
ApplExpr JExpr
fun [])
Left JExpr
fun -> JExpr -> JStat
returnS (JExpr -> [JExpr] -> JExpr
ApplExpr JExpr
fun [ApplySpec -> JExpr
specTagExpr ApplySpec
spec])
]
data ApplyConv
= RegsConv
| StackConv
deriving (Int -> ApplyConv -> ShowS
[ApplyConv] -> ShowS
ApplyConv -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [ApplyConv] -> ShowS
$cshowList :: [ApplyConv] -> ShowS
show :: ApplyConv -> [Char]
$cshow :: ApplyConv -> [Char]
showsPrec :: Int -> ApplyConv -> ShowS
$cshowsPrec :: Int -> ApplyConv -> ShowS
Show,ApplyConv -> ApplyConv -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ApplyConv -> ApplyConv -> Bool
$c/= :: ApplyConv -> ApplyConv -> Bool
== :: ApplyConv -> ApplyConv -> Bool
$c== :: ApplyConv -> ApplyConv -> Bool
Eq,Eq ApplyConv
ApplyConv -> ApplyConv -> Bool
ApplyConv -> ApplyConv -> Ordering
ApplyConv -> ApplyConv -> ApplyConv
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ApplyConv -> ApplyConv -> ApplyConv
$cmin :: ApplyConv -> ApplyConv -> ApplyConv
max :: ApplyConv -> ApplyConv -> ApplyConv
$cmax :: ApplyConv -> ApplyConv -> ApplyConv
>= :: ApplyConv -> ApplyConv -> Bool
$c>= :: ApplyConv -> ApplyConv -> Bool
> :: ApplyConv -> ApplyConv -> Bool
$c> :: ApplyConv -> ApplyConv -> Bool
<= :: ApplyConv -> ApplyConv -> Bool
$c<= :: ApplyConv -> ApplyConv -> Bool
< :: ApplyConv -> ApplyConv -> Bool
$c< :: ApplyConv -> ApplyConv -> Bool
compare :: ApplyConv -> ApplyConv -> Ordering
$ccompare :: ApplyConv -> ApplyConv -> Ordering
Ord)
genericApplyName :: ApplyConv -> FastString
genericApplyName :: ApplyConv -> FastString
genericApplyName = \case
ApplyConv
RegsConv -> FastString
"h$ap_gen_fast"
ApplyConv
StackConv -> FastString
"h$ap_gen"
genericApplyExpr :: ApplyConv -> JExpr
genericApplyExpr :: ApplyConv -> JExpr
genericApplyExpr ApplyConv
conv = FastString -> JExpr
var (ApplyConv -> FastString
genericApplyName ApplyConv
conv)
specApplyName :: ApplySpec -> FastString
specApplyName :: ApplySpec -> FastString
specApplyName = \case
ApplySpec ApplyConv
RegsConv Int
0 Int
0 -> FastString
"h$ap_0_0_fast"
ApplySpec ApplyConv
StackConv Int
0 Int
0 -> FastString
"h$ap_0_0"
ApplySpec ApplyConv
RegsConv Int
1 Int
0 -> FastString
"h$ap_1_0_fast"
ApplySpec ApplyConv
StackConv Int
1 Int
0 -> FastString
"h$ap_1_0"
ApplySpec ApplyConv
RegsConv Int
1 Int
1 -> FastString
"h$ap_1_1_fast"
ApplySpec ApplyConv
StackConv Int
1 Int
1 -> FastString
"h$ap_1_1"
ApplySpec ApplyConv
RegsConv Int
1 Int
2 -> FastString
"h$ap_1_2_fast"
ApplySpec ApplyConv
StackConv Int
1 Int
2 -> FastString
"h$ap_1_2"
ApplySpec ApplyConv
RegsConv Int
2 Int
1 -> FastString
"h$ap_2_1_fast"
ApplySpec ApplyConv
StackConv Int
2 Int
1 -> FastString
"h$ap_2_1"
ApplySpec ApplyConv
RegsConv Int
2 Int
2 -> FastString
"h$ap_2_2_fast"
ApplySpec ApplyConv
StackConv Int
2 Int
2 -> FastString
"h$ap_2_2"
ApplySpec ApplyConv
RegsConv Int
2 Int
3 -> FastString
"h$ap_2_3_fast"
ApplySpec ApplyConv
StackConv Int
2 Int
3 -> FastString
"h$ap_2_3"
ApplySpec ApplyConv
conv Int
nargs Int
nvars -> [Char] -> FastString
mkFastString forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat
[ [Char]
"h$ap_", forall a. Show a => a -> [Char]
show Int
nargs
, [Char]
"_" , forall a. Show a => a -> [Char]
show Int
nvars
, case ApplyConv
conv of
ApplyConv
RegsConv -> [Char]
"_fast"
ApplyConv
StackConv -> [Char]
""
]
specApplyExpr :: ApplySpec -> JExpr
specApplyExpr :: ApplySpec -> JExpr
specApplyExpr ApplySpec
spec = FastString -> JExpr
var (ApplySpec -> FastString
specApplyName ApplySpec
spec)
specApplyExprMaybe :: ApplySpec -> Maybe JExpr
specApplyExprMaybe :: ApplySpec -> Maybe JExpr
specApplyExprMaybe ApplySpec
spec =
if ApplySpec
spec forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ApplySpec]
applySpec
then forall a. a -> Maybe a
Just (ApplySpec -> JExpr
specApplyExpr ApplySpec
spec)
else forall a. Maybe a
Nothing
mkApplySpec :: ApplyConv -> [StgArg] -> [JExpr] -> ApplySpec
mkApplySpec :: ApplyConv -> [StgArg] -> [JExpr] -> ApplySpec
mkApplySpec ApplyConv
conv [StgArg]
args [JExpr]
vars = ApplySpec
{ specConv :: ApplyConv
specConv = ApplyConv
conv
, specArgs :: Int
specArgs = forall (t :: * -> *) a. Foldable t => t a -> Int
length [StgArg]
args
, specVars :: Int
specVars = forall (t :: * -> *) a. Foldable t => t a -> Int
length [JExpr]
vars
}
selectApply
:: ApplySpec
-> G (Either JExpr JExpr)
selectApply :: ApplySpec -> G (Either JExpr JExpr)
selectApply ApplySpec
spec =
case ApplySpec -> Maybe JExpr
specApplyExprMaybe ApplySpec
spec of
Just JExpr
e -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right JExpr
e)
Maybe JExpr
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left (ApplyConv -> JExpr
genericApplyExpr (ApplySpec -> ApplyConv
specConv ApplySpec
spec)))
data ApplySpec = ApplySpec
{ ApplySpec -> ApplyConv
specConv :: !ApplyConv
, ApplySpec -> Int
specArgs :: !Int
, ApplySpec -> Int
specVars :: !Int
}
deriving (Int -> ApplySpec -> ShowS
[ApplySpec] -> ShowS
ApplySpec -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [ApplySpec] -> ShowS
$cshowList :: [ApplySpec] -> ShowS
show :: ApplySpec -> [Char]
$cshow :: ApplySpec -> [Char]
showsPrec :: Int -> ApplySpec -> ShowS
$cshowsPrec :: Int -> ApplySpec -> ShowS
Show,ApplySpec -> ApplySpec -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ApplySpec -> ApplySpec -> Bool
$c/= :: ApplySpec -> ApplySpec -> Bool
== :: ApplySpec -> ApplySpec -> Bool
$c== :: ApplySpec -> ApplySpec -> Bool
Eq,Eq ApplySpec
ApplySpec -> ApplySpec -> Bool
ApplySpec -> ApplySpec -> Ordering
ApplySpec -> ApplySpec -> ApplySpec
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ApplySpec -> ApplySpec -> ApplySpec
$cmin :: ApplySpec -> ApplySpec -> ApplySpec
max :: ApplySpec -> ApplySpec -> ApplySpec
$cmax :: ApplySpec -> ApplySpec -> ApplySpec
>= :: ApplySpec -> ApplySpec -> Bool
$c>= :: ApplySpec -> ApplySpec -> Bool
> :: ApplySpec -> ApplySpec -> Bool
$c> :: ApplySpec -> ApplySpec -> Bool
<= :: ApplySpec -> ApplySpec -> Bool
$c<= :: ApplySpec -> ApplySpec -> Bool
< :: ApplySpec -> ApplySpec -> Bool
$c< :: ApplySpec -> ApplySpec -> Bool
compare :: ApplySpec -> ApplySpec -> Ordering
$ccompare :: ApplySpec -> ApplySpec -> Ordering
Ord)
applySpec :: [ApplySpec]
applySpec :: [ApplySpec]
applySpec = [ ApplyConv -> Int -> Int -> ApplySpec
ApplySpec ApplyConv
conv Int
nargs Int
nvars
| ApplyConv
conv <- [ApplyConv
RegsConv, ApplyConv
StackConv]
, Int
nargs <- [Int
0..Int
4]
, Int
nvars <- [forall a. Ord a => a -> a -> a
max Int
0 (Int
nargsforall a. Num a => a -> a -> a
-Int
1)..(Int
nargsforall a. Num a => a -> a -> a
*Int
2)]
]
specTag :: ApplySpec -> Int
specTag :: ApplySpec -> Int
specTag ApplySpec
spec = forall a. Bits a => a -> Int -> a
Bits.shiftL (ApplySpec -> Int
specVars ApplySpec
spec) Int
8 forall a. Bits a => a -> a -> a
Bits..|. (ApplySpec -> Int
specArgs ApplySpec
spec)
specTagExpr :: ApplySpec -> JExpr
specTagExpr :: ApplySpec -> JExpr
specTagExpr = forall a. ToJExpr a => a -> JExpr
toJExpr forall b c a. (b -> c) -> (a -> b) -> a -> c
. ApplySpec -> Int
specTag
mkApplyArr :: JStat
mkApplyArr :: JStat
mkApplyArr = forall a. Monoid a => [a] -> a
mconcat
[ FastString -> Ident
TxtI FastString
"h$apply" Ident -> JExpr -> JStat
||= forall a. ToJExpr a => a -> JExpr
toJExpr ([JExpr] -> JVal
JList [])
, FastString -> Ident
TxtI FastString
"h$paps" Ident -> JExpr -> JStat
||= forall a. ToJExpr a => a -> JExpr
toJExpr ([JExpr] -> JVal
JList [])
, JExpr -> [JExpr] -> JStat
ApplStat (FastString -> JExpr
var FastString
"h$initStatic" JExpr -> FastString -> JExpr
.^ FastString
"push")
[ JVal -> JExpr
ValExpr forall a b. (a -> b) -> a -> b
$ [Ident] -> JStat -> JVal
JFunc [] forall a b. (a -> b) -> a -> b
$ forall a. ToSat a => a -> JStat
jVar \JExpr
i -> forall a. Monoid a => [a] -> a
mconcat
[ JExpr
i JExpr -> JExpr -> JStat
|= JExpr
zero_
, Bool -> JExpr -> JStat -> JStat
WhileStat Bool
False (JExpr
i JExpr -> JExpr -> JExpr
.<. Integer -> JExpr
Int Integer
65536) forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat
[ FastString -> JExpr
var FastString
"h$apply" JExpr -> JExpr -> JExpr
.! JExpr
i JExpr -> JExpr -> JStat
|= FastString -> JExpr
var FastString
"h$ap_gen"
, JExpr -> JStat
preIncrS JExpr
i
]
, JExpr
i JExpr -> JExpr -> JStat
|= JExpr
zero_
, Bool -> JExpr -> JStat -> JStat
WhileStat Bool
False (JExpr
i JExpr -> JExpr -> JExpr
.<. Integer -> JExpr
Int Integer
128) forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat
[ FastString -> JExpr
var FastString
"h$paps" JExpr -> JExpr -> JExpr
.! JExpr
i JExpr -> JExpr -> JStat
|= FastString -> JExpr
var FastString
"h$pap_gen"
, JExpr -> JStat
preIncrS JExpr
i
]
, forall a. Monoid a => [a] -> a
mconcat (forall a b. (a -> b) -> [a] -> [b]
map ApplySpec -> JStat
assignSpec [ApplySpec]
applySpec)
, forall a. Monoid a => [a] -> a
mconcat (forall a b. (a -> b) -> [a] -> [b]
map Int -> JStat
assignPap [Int]
specPap)
]
]
]
where
assignSpec :: ApplySpec -> JStat
assignSpec :: ApplySpec -> JStat
assignSpec ApplySpec
spec = case ApplySpec -> ApplyConv
specConv ApplySpec
spec of
ApplyConv
StackConv -> FastString -> JExpr
var FastString
"h$apply" JExpr -> JExpr -> JExpr
.! ApplySpec -> JExpr
specTagExpr ApplySpec
spec JExpr -> JExpr -> JStat
|= ApplySpec -> JExpr
specApplyExpr ApplySpec
spec
ApplyConv
RegsConv -> forall a. Monoid a => a
mempty
assignPap :: Int -> JStat
assignPap :: Int -> JStat
assignPap Int
p = FastString -> JExpr
var FastString
"h$paps" JExpr -> JExpr -> JExpr
.! forall a. ToJExpr a => a -> JExpr
toJExpr Int
p JExpr -> JExpr -> JStat
|=
(FastString -> JExpr
var ([Char] -> FastString
mkFastString forall a b. (a -> b) -> a -> b
$ ([Char]
"h$pap_" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int
p)))
pushCont :: HasDebugCallStack
=> [StgArg]
-> G JStat
pushCont :: HasDebugCallStack => [StgArg] -> G JStat
pushCont [StgArg]
args = do
[JExpr]
vars <- forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Traversable f) =>
(a -> m [b]) -> f a -> m [b]
concatMapM HasDebugCallStack => StgArg -> G [JExpr]
genArg [StgArg]
args
let spec :: ApplySpec
spec = ApplyConv -> [StgArg] -> [JExpr] -> ApplySpec
mkApplySpec ApplyConv
StackConv [StgArg]
args [JExpr]
vars
ApplySpec -> G (Either JExpr JExpr)
selectApply ApplySpec
spec forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Right JExpr
app -> [JExpr] -> G JStat
push forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ JExpr
app forall a. a -> [a] -> [a]
: [JExpr]
vars
Left JExpr
app -> [JExpr] -> G JStat
push forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ JExpr
app forall a. a -> [a] -> [a]
: ApplySpec -> JExpr
specTagExpr ApplySpec
spec forall a. a -> [a] -> [a]
: [JExpr]
vars
genericStackApply :: StgToJSConfig -> JStat
genericStackApply :: StgToJSConfig -> JStat
genericStackApply StgToJSConfig
cfg = ClosureInfo -> JStat -> JStat
closure ClosureInfo
info JStat
body
where
body :: JStat
body = forall a. ToSat a => a -> JStat
jVar \JExpr
cf ->
[ StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
cfg (FastString -> JExpr
jString FastString
"h$ap_gen")
, JExpr
cf JExpr -> JExpr -> JStat
|= JExpr -> JExpr
closureEntry JExpr
r1
, JExpr -> [(JExpr, JStat)] -> JStat -> JStat
SwitchStat (JExpr -> JExpr
entryClosureType JExpr
cf)
[ (forall a. ToJExpr a => a -> JExpr
toJExpr ClosureType
Thunk , StgToJSConfig -> JExpr -> JStat
thunk_case StgToJSConfig
cfg JExpr
cf)
, (forall a. ToJExpr a => a -> JExpr
toJExpr ClosureType
Fun , JExpr -> JExpr -> JStat
fun_case JExpr
cf (JExpr -> JExpr
funArity' JExpr
cf))
, (forall a. ToJExpr a => a -> JExpr
toJExpr ClosureType
Pap , JExpr -> JExpr -> JStat
fun_case JExpr
cf (JExpr -> JExpr
papArity JExpr
r1))
, (forall a. ToJExpr a => a -> JExpr
toJExpr ClosureType
Blackhole, StgToJSConfig -> JStat
blackhole_case StgToJSConfig
cfg)
]
(JExpr -> JStat
default_case JExpr
cf)
]
info :: ClosureInfo
info = ClosureInfo
{ ciVar :: Ident
ciVar = FastString -> Ident
TxtI FastString
"h$ap_gen"
, ciRegs :: CIRegs
ciRegs = Int -> [VarType] -> CIRegs
CIRegs Int
0 [VarType
PtrV]
, ciName :: FastString
ciName = FastString
"h$ap_gen"
, ciLayout :: CILayout
ciLayout = CILayout
CILayoutVariable
, ciType :: CIType
ciType = CIType
CIStackFrame
, ciStatic :: CIStatic
ciStatic = forall a. Monoid a => a
mempty
}
default_case :: JExpr -> JStat
default_case JExpr
cf = FastString -> [JExpr] -> JStat
appS FastString
"throw" [FastString -> JExpr
jString FastString
"h$ap_gen: unexpected closure type "
forall a. Num a => a -> a -> a
+ (JExpr -> JExpr
entryClosureType JExpr
cf)]
thunk_case :: StgToJSConfig -> JExpr -> JStat
thunk_case StgToJSConfig
cfg JExpr
cf = forall a. Monoid a => [a] -> a
mconcat
[ StgToJSConfig -> JStat -> JStat
profStat StgToJSConfig
cfg JStat
pushRestoreCCS
, JExpr -> JStat
returnS JExpr
cf
]
blackhole_case :: StgToJSConfig -> JStat
blackhole_case StgToJSConfig
cfg = forall a. Monoid a => [a] -> a
mconcat
[ StgToJSConfig -> [JExpr] -> JStat
push' StgToJSConfig
cfg [JExpr
r1, FastString -> JExpr
var FastString
"h$return"]
, JExpr -> JStat
returnS (FastString -> [JExpr] -> JExpr
app FastString
"h$blockOnBlackhole" [JExpr
r1])
]
fun_case :: JExpr -> JExpr -> JStat
fun_case JExpr
c JExpr
arity = forall a. ToSat a => a -> JStat
jVar \JExpr
tag JExpr
needed_args JExpr
needed_regs JExpr
given_args JExpr
given_regs JExpr
newTag JExpr
newAp JExpr
p JExpr
dat ->
[ JExpr
tag JExpr -> JExpr -> JStat
|= JExpr
stack JExpr -> JExpr -> JExpr
.! (JExpr
sp forall a. Num a => a -> a -> a
- JExpr
1)
, JExpr
given_args JExpr -> JExpr -> JStat
|= JExpr -> JExpr
mask8 JExpr
tag
, JExpr
given_regs JExpr -> JExpr -> JStat
|= JExpr
tag JExpr -> JExpr -> JExpr
.>>. JExpr
8
, JExpr
needed_args JExpr -> JExpr -> JStat
|= JExpr -> JExpr
mask8 JExpr
arity
, JExpr
needed_regs JExpr -> JExpr -> JStat
|= JExpr
arity JExpr -> JExpr -> JExpr
.>>. JExpr
8
, StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
cfg (FastString -> JExpr
jString FastString
"h$ap_gen: args: " forall a. Num a => a -> a -> a
+ JExpr
given_args
forall a. Num a => a -> a -> a
+ FastString -> JExpr
jString FastString
" regs: " forall a. Num a => a -> a -> a
+ JExpr
given_regs)
, JExpr -> [JStat] -> [JStat] -> JStat
ifBlockS (JExpr
given_args JExpr -> JExpr -> JExpr
.===. JExpr
needed_args)
[ StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
cfg (FastString -> JExpr
jString FastString
"h$ap_gen: exact")
, JExpr -> (JExpr -> JExpr) -> (JExpr -> JStat) -> JStat
loop JExpr
0 (JExpr -> JExpr -> JExpr
.<. JExpr
given_regs) \JExpr
i -> forall a. Monoid a => [a] -> a
mconcat
[ FastString -> [JExpr] -> JStat
appS FastString
"h$setReg" [JExpr
iforall a. Num a => a -> a -> a
+JExpr
2, JExpr
stack JExpr -> JExpr -> JExpr
.! (JExpr
spforall a. Num a => a -> a -> a
-JExpr
2forall a. Num a => a -> a -> a
-JExpr
i)]
, JExpr -> JStat
postIncrS JExpr
i
]
, JExpr
sp JExpr -> JExpr -> JStat
|= JExpr
sp forall a. Num a => a -> a -> a
- JExpr
given_regs forall a. Num a => a -> a -> a
- JExpr
2
, JExpr -> JStat
returnS JExpr
c
]
[ JExpr -> [JStat] -> [JStat] -> JStat
ifBlockS (JExpr
given_args JExpr -> JExpr -> JExpr
.>. JExpr
needed_args)
[ StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
cfg (FastString -> JExpr
jString FastString
"h$ap_gen: oversat: arity: " forall a. Num a => a -> a -> a
+ JExpr
needed_args
forall a. Num a => a -> a -> a
+ FastString -> JExpr
jString FastString
" regs: " forall a. Num a => a -> a -> a
+ JExpr
needed_regs)
, JExpr -> (JExpr -> JExpr) -> (JExpr -> JStat) -> JStat
loop JExpr
0 (JExpr -> JExpr -> JExpr
.<. JExpr
needed_regs) \JExpr
i -> forall a. Monoid a => [a] -> a
mconcat
[ StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
cfg (FastString -> JExpr
jString FastString
"h$ap_gen: loading register: " forall a. Num a => a -> a -> a
+ JExpr
i)
, FastString -> [JExpr] -> JStat
appS FastString
"h$setReg" [JExpr
iforall a. Num a => a -> a -> a
+JExpr
2, JExpr
stack JExpr -> JExpr -> JExpr
.! (JExpr
spforall a. Num a => a -> a -> a
-JExpr
2forall a. Num a => a -> a -> a
-JExpr
i)]
, JExpr -> JStat
postIncrS JExpr
i
]
, JExpr
newTag JExpr -> JExpr -> JStat
|= ((JExpr
given_regsforall a. Num a => a -> a -> a
-JExpr
needed_regs)JExpr -> JExpr -> JExpr
.<<.JExpr
8) JExpr -> JExpr -> JExpr
.|. (JExpr
given_args forall a. Num a => a -> a -> a
- JExpr
needed_args)
, JExpr
newAp JExpr -> JExpr -> JStat
|= FastString -> JExpr
var FastString
"h$apply" JExpr -> JExpr -> JExpr
.! JExpr
newTag
, StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
cfg (FastString -> JExpr
jString FastString
"h$ap_gen: next: " forall a. Num a => a -> a -> a
+ (JExpr
newAp JExpr -> FastString -> JExpr
.^ FastString
"n"))
, JExpr -> JStat -> JStat -> JStat
ifS (JExpr
newAp JExpr -> JExpr -> JExpr
.===. FastString -> JExpr
var FastString
"h$ap_gen")
((JExpr
sp JExpr -> JExpr -> JStat
|= JExpr
sp forall a. Num a => a -> a -> a
- JExpr
needed_regs) forall a. Semigroup a => a -> a -> a
<> (JExpr
stack JExpr -> JExpr -> JExpr
.! (JExpr
sp forall a. Num a => a -> a -> a
- JExpr
1) JExpr -> JExpr -> JStat
|= JExpr
newTag))
(JExpr
sp JExpr -> JExpr -> JStat
|= JExpr
sp forall a. Num a => a -> a -> a
- JExpr
needed_regs forall a. Num a => a -> a -> a
- JExpr
1)
, JExpr
stack JExpr -> JExpr -> JExpr
.! JExpr
sp JExpr -> JExpr -> JStat
|= JExpr
newAp
, StgToJSConfig -> JStat -> JStat
profStat StgToJSConfig
cfg JStat
pushRestoreCCS
, JExpr -> JStat
returnS JExpr
c
]
[ StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
cfg (FastString -> JExpr
jString FastString
"h$ap_gen: undersat")
, JExpr
p JExpr -> JExpr -> JStat
|= FastString -> JExpr
var FastString
"h$paps" JExpr -> JExpr -> JExpr
.! JExpr
given_regs
, JExpr
newTag JExpr -> JExpr -> JStat
|= ((JExpr
needed_regsforall a. Num a => a -> a -> a
-JExpr
given_regs) JExpr -> JExpr -> JExpr
.<<. JExpr
8) JExpr -> JExpr -> JExpr
.|. (JExpr
needed_argsforall a. Num a => a -> a -> a
-JExpr
given_args)
, JExpr
dat JExpr -> JExpr -> JStat
|= forall a. ToJExpr a => a -> JExpr
toJExpr [JExpr
r1, JExpr
newTag]
, JExpr -> (JExpr -> JExpr) -> (JExpr -> JStat) -> JStat
loop JExpr
0 (JExpr -> JExpr -> JExpr
.<. JExpr
given_regs) \JExpr
i -> forall a. Monoid a => [a] -> a
mconcat
[ (JExpr
dat JExpr -> FastString -> JExpr
.^ FastString
"push") JExpr -> [JExpr] -> JStat
`ApplStat` [JExpr
stack JExpr -> JExpr -> JExpr
.! (JExpr
sp forall a. Num a => a -> a -> a
- JExpr
i forall a. Num a => a -> a -> a
- JExpr
2)]
, JExpr -> JStat
postIncrS JExpr
i
]
, JExpr
sp JExpr -> JExpr -> JStat
|= JExpr
sp forall a. Num a => a -> a -> a
- JExpr
given_regs forall a. Num a => a -> a -> a
- JExpr
2
, JExpr
r1 JExpr -> JExpr -> JStat
|= StgToJSConfig -> JExpr -> JExpr -> JExpr -> JExpr
initClosure StgToJSConfig
cfg JExpr
p JExpr
dat JExpr
jCurrentCCS
, JStat
returnStack
]
]
]
genericFastApply :: StgToJSConfig -> JStat
genericFastApply :: StgToJSConfig -> JStat
genericFastApply StgToJSConfig
s =
FastString -> Ident
TxtI FastString
"h$ap_gen_fast" Ident -> JExpr -> JStat
||= forall a. ToSat a => a -> JExpr
jLam \JExpr
tag -> forall a. ToSat a => a -> JStat
jVar \JExpr
c ->
[StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (FastString -> JExpr
jString FastString
"h$ap_gen_fast: " forall a. Num a => a -> a -> a
+ JExpr
tag)
, JExpr
c JExpr -> JExpr -> JStat
|= JExpr -> JExpr
closureEntry JExpr
r1
, JExpr -> [(JExpr, JStat)] -> JStat -> JStat
SwitchStat (JExpr -> JExpr
entryClosureType JExpr
c)
[ (forall a. ToJExpr a => a -> JExpr
toJExpr ClosureType
Thunk, StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (FastString -> JExpr
jString FastString
"h$ap_gen_fast: thunk")
forall a. Semigroup a => a -> a -> a
<> JExpr -> JExpr -> JStat
pushStackApply JExpr
c JExpr
tag
forall a. Semigroup a => a -> a -> a
<> JExpr -> JStat
returnS JExpr
c)
, (forall a. ToJExpr a => a -> JExpr
toJExpr ClosureType
Fun, forall a. ToSat a => a -> JStat
jVar \JExpr
farity ->
[ JExpr
farity JExpr -> JExpr -> JStat
|= JExpr -> JExpr
funArity' JExpr
c
, StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (FastString -> JExpr
jString FastString
"h$ap_gen_fast: fun " forall a. Num a => a -> a -> a
+ JExpr
farity)
, JExpr -> JExpr -> JExpr -> JStat
funCase JExpr
c JExpr
tag JExpr
farity
])
, (forall a. ToJExpr a => a -> JExpr
toJExpr ClosureType
Pap, forall a. ToSat a => a -> JStat
jVar \JExpr
parity ->
[ JExpr
parity JExpr -> JExpr -> JStat
|= JExpr -> JExpr
papArity JExpr
r1
, StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (FastString -> JExpr
jString FastString
"h$ap_gen_fast: pap " forall a. Num a => a -> a -> a
+ JExpr
parity)
, JExpr -> JExpr -> JExpr -> JStat
funCase JExpr
c JExpr
tag JExpr
parity
])
, (forall a. ToJExpr a => a -> JExpr
toJExpr ClosureType
Con, StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (FastString -> JExpr
jString FastString
"h$ap_gen_fast: con")
forall a. Semigroup a => a -> a -> a
<> JExpr -> JStat -> JStat
jwhenS (JExpr
tag JExpr -> JExpr -> JExpr
.!=. JExpr
0)
(FastString -> [JExpr] -> JStat
appS FastString
"throw" [FastString -> JExpr
jString FastString
"h$ap_gen_fast: invalid apply"])
forall a. Semigroup a => a -> a -> a
<> JExpr -> JStat
returnS JExpr
c)
, (forall a. ToJExpr a => a -> JExpr
toJExpr ClosureType
Blackhole, StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (FastString -> JExpr
jString FastString
"h$ap_gen_fast: blackhole")
forall a. Semigroup a => a -> a -> a
<> JExpr -> JExpr -> JStat
pushStackApply JExpr
c JExpr
tag
forall a. Semigroup a => a -> a -> a
<> StgToJSConfig -> [JExpr] -> JStat
push' StgToJSConfig
s [JExpr
r1, FastString -> JExpr
var FastString
"h$return"]
forall a. Semigroup a => a -> a -> a
<> JExpr -> JStat
returnS (FastString -> [JExpr] -> JExpr
app FastString
"h$blockOnBlackhole" [JExpr
r1]))
] forall a b. (a -> b) -> a -> b
$ FastString -> [JExpr] -> JStat
appS FastString
"throw" [FastString -> JExpr
jString FastString
"h$ap_gen_fast: unexpected closure type: " forall a. Num a => a -> a -> a
+ JExpr -> JExpr
entryClosureType JExpr
c]
]
where
pushStackApply :: JExpr -> JExpr -> JStat
pushStackApply :: JExpr -> JExpr -> JStat
pushStackApply JExpr
_c JExpr
tag =
forall a. ToSat a => a -> JStat
jVar \JExpr
ap ->
[ JExpr -> JStat
pushAllRegs JExpr
tag
, JExpr
ap JExpr -> JExpr -> JStat
|= FastString -> JExpr
var FastString
"h$apply" JExpr -> JExpr -> JExpr
.! JExpr
tag
, JExpr -> JStat -> JStat -> JStat
ifS (JExpr
ap JExpr -> JExpr -> JExpr
.===. FastString -> JExpr
var FastString
"h$ap_gen")
((JExpr
sp JExpr -> JExpr -> JStat
|= JExpr
sp forall a. Num a => a -> a -> a
+ JExpr
2) forall a. Semigroup a => a -> a -> a
<> (JExpr
stack JExpr -> JExpr -> JExpr
.! (JExpr
spforall a. Num a => a -> a -> a
-JExpr
1) JExpr -> JExpr -> JStat
|= JExpr
tag))
(JExpr
sp JExpr -> JExpr -> JStat
|= JExpr
sp forall a. Num a => a -> a -> a
+ JExpr
1)
, JExpr
stack JExpr -> JExpr -> JExpr
.! JExpr
sp JExpr -> JExpr -> JStat
|= JExpr
ap
, StgToJSConfig -> JStat -> JStat
profStat StgToJSConfig
s JStat
pushRestoreCCS
]
funCase :: JExpr -> JExpr -> JExpr -> JStat
funCase :: JExpr -> JExpr -> JExpr -> JStat
funCase JExpr
c JExpr
tag JExpr
arity =
forall a. ToSat a => a -> JStat
jVar \JExpr
ar JExpr
myAr JExpr
myRegs JExpr
regsStart JExpr
newTag JExpr
newAp JExpr
dat JExpr
p ->
[ JExpr
ar JExpr -> JExpr -> JStat
|= JExpr -> JExpr
mask8 JExpr
arity
, JExpr
myAr JExpr -> JExpr -> JStat
|= JExpr -> JExpr
mask8 JExpr
tag
, JExpr
myRegs JExpr -> JExpr -> JStat
|= JExpr
tag JExpr -> JExpr -> JExpr
.>>. JExpr
8
, StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (FastString -> JExpr
jString FastString
"h$ap_gen_fast: args: " forall a. Num a => a -> a -> a
+ JExpr
myAr
forall a. Num a => a -> a -> a
+ FastString -> JExpr
jString FastString
" regs: " forall a. Num a => a -> a -> a
+ JExpr
myRegs)
, JExpr -> JStat -> JStat -> JStat
ifS (JExpr
myAr JExpr -> JExpr -> JExpr
.===. JExpr
ar)
(StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (FastString -> JExpr
jString FastString
"h$ap_gen_fast: exact") forall a. Semigroup a => a -> a -> a
<> JExpr -> JStat
returnS JExpr
c)
(JExpr -> [JStat] -> [JStat] -> JStat
ifBlockS (JExpr
myAr JExpr -> JExpr -> JExpr
.>. JExpr
ar)
[ StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (FastString -> JExpr
jString FastString
"h$ap_gen_fast: oversat " forall a. Num a => a -> a -> a
+ JExpr
sp)
, JExpr
regsStart JExpr -> JExpr -> JStat
|= (JExpr
arity JExpr -> JExpr -> JExpr
.>>. JExpr
8) forall a. Num a => a -> a -> a
+ JExpr
1
, JExpr
sp JExpr -> JExpr -> JStat
|= JExpr
sp forall a. Num a => a -> a -> a
+ JExpr
myRegs forall a. Num a => a -> a -> a
- JExpr
regsStart forall a. Num a => a -> a -> a
+ JExpr
1
, StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (FastString -> JExpr
jString FastString
"h$ap_gen_fast: oversat " forall a. Num a => a -> a -> a
+ JExpr
sp)
, JExpr -> JExpr -> JStat
pushArgs JExpr
regsStart JExpr
myRegs
, JExpr
newTag JExpr -> JExpr -> JStat
|= ((JExpr
myRegsforall a. Num a => a -> a -> a
-( JExpr
arityJExpr -> JExpr -> JExpr
.>>.JExpr
8))JExpr -> JExpr -> JExpr
.<<.JExpr
8)JExpr -> JExpr -> JExpr
.|.JExpr
myArforall a. Num a => a -> a -> a
-JExpr
ar
, JExpr
newAp JExpr -> JExpr -> JStat
|= FastString -> JExpr
var FastString
"h$apply" JExpr -> JExpr -> JExpr
.! JExpr
newTag
, JExpr -> JStat -> JStat -> JStat
ifS (JExpr
newAp JExpr -> JExpr -> JExpr
.===. FastString -> JExpr
var FastString
"h$ap_gen")
((JExpr
sp JExpr -> JExpr -> JStat
|= JExpr
sp forall a. Num a => a -> a -> a
+ JExpr
2) forall a. Semigroup a => a -> a -> a
<> (JExpr
stack JExpr -> JExpr -> JExpr
.! (JExpr
sp forall a. Num a => a -> a -> a
- JExpr
1) JExpr -> JExpr -> JStat
|= JExpr
newTag))
(JExpr
sp JExpr -> JExpr -> JStat
|= JExpr
sp forall a. Num a => a -> a -> a
+ JExpr
1)
, JExpr
stack JExpr -> JExpr -> JExpr
.! JExpr
sp JExpr -> JExpr -> JStat
|= JExpr
newAp
, StgToJSConfig -> JStat -> JStat
profStat StgToJSConfig
s JStat
pushRestoreCCS
, JExpr -> JStat
returnS JExpr
c
]
[StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (FastString -> JExpr
jString FastString
"h$ap_gen_fast: undersat: " forall a. Num a => a -> a -> a
+ JExpr
myRegs forall a. Num a => a -> a -> a
+ FastString -> JExpr
jString FastString
" " forall a. Num a => a -> a -> a
+ JExpr
tag)
, JExpr -> JStat -> JStat
jwhenS (JExpr
tag JExpr -> JExpr -> JExpr
.!=. JExpr
0) forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat
[ JExpr
p JExpr -> JExpr -> JStat
|= FastString -> JExpr
var FastString
"h$paps" JExpr -> JExpr -> JExpr
.! JExpr
myRegs
, JExpr
dat JExpr -> JExpr -> JStat
|= forall a. ToJExpr a => a -> JExpr
toJExpr [JExpr
r1, ((JExpr
arity JExpr -> JExpr -> JExpr
.>>. JExpr
8)forall a. Num a => a -> a -> a
-JExpr
myRegs)forall a. Num a => a -> a -> a
*JExpr
256forall a. Num a => a -> a -> a
+JExpr
arforall a. Num a => a -> a -> a
-JExpr
myAr]
, JExpr -> (JExpr -> JExpr) -> (JExpr -> JStat) -> JStat
loop JExpr
0 (JExpr -> JExpr -> JExpr
.<. JExpr
myRegs)
(\JExpr
i -> (JExpr
dat JExpr -> FastString -> JExpr
.^ FastString
"push")
JExpr -> [JExpr] -> JStat
`ApplStat` [FastString -> [JExpr] -> JExpr
app FastString
"h$getReg" [JExpr
iforall a. Num a => a -> a -> a
+JExpr
2]] forall a. Semigroup a => a -> a -> a
<> JExpr -> JStat
postIncrS JExpr
i)
, JExpr
r1 JExpr -> JExpr -> JStat
|= StgToJSConfig -> JExpr -> JExpr -> JExpr -> JExpr
initClosure StgToJSConfig
s JExpr
p JExpr
dat JExpr
jCurrentCCS
]
, JStat
returnStack
])
]
pushAllRegs :: JExpr -> JStat
pushAllRegs :: JExpr -> JStat
pushAllRegs JExpr
tag =
forall a. ToSat a => a -> JStat
jVar \JExpr
regs ->
[ JExpr
regs JExpr -> JExpr -> JStat
|= JExpr
tag JExpr -> JExpr -> JExpr
.>>. JExpr
8
, JExpr
sp JExpr -> JExpr -> JStat
|= JExpr
sp forall a. Num a => a -> a -> a
+ JExpr
regs
, JExpr -> [(JExpr, JStat)] -> JStat -> JStat
SwitchStat JExpr
regs (forall a b. (a -> b) -> [a] -> [b]
map Int -> (JExpr, JStat)
pushReg [Int
65,Int
64..Int
2]) forall a. Monoid a => a
mempty
]
where
pushReg :: Int -> (JExpr, JStat)
pushReg :: Int -> (JExpr, JStat)
pushReg Int
r = (forall a. ToJExpr a => a -> JExpr
toJExpr (Int
rforall a. Num a => a -> a -> a
-Int
1), JExpr
stack JExpr -> JExpr -> JExpr
.! (JExpr
sp forall a. Num a => a -> a -> a
- forall a. ToJExpr a => a -> JExpr
toJExpr (Int
r forall a. Num a => a -> a -> a
- Int
2)) JExpr -> JExpr -> JStat
|= Int -> JExpr
jsReg Int
r)
pushArgs :: JExpr -> JExpr -> JStat
pushArgs :: JExpr -> JExpr -> JStat
pushArgs JExpr
start JExpr
end =
JExpr -> (JExpr -> JExpr) -> (JExpr -> JStat) -> JStat
loop JExpr
end (JExpr -> JExpr -> JExpr
.>=.JExpr
start) (\JExpr
i -> StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (FastString -> JExpr
jString FastString
"pushing register: " forall a. Num a => a -> a -> a
+ JExpr
i)
forall a. Semigroup a => a -> a -> a
<> (JExpr
stack JExpr -> JExpr -> JExpr
.! (JExpr
sp forall a. Num a => a -> a -> a
+ JExpr
start forall a. Num a => a -> a -> a
- JExpr
i) JExpr -> JExpr -> JStat
|= FastString -> [JExpr] -> JExpr
app FastString
"h$getReg" [JExpr
iforall a. Num a => a -> a -> a
+JExpr
1])
forall a. Semigroup a => a -> a -> a
<> JExpr -> JStat
postDecrS JExpr
i
)
specApply :: StgToJSConfig -> ApplySpec -> JStat
specApply :: StgToJSConfig -> ApplySpec -> JStat
specApply StgToJSConfig
cfg spec :: ApplySpec
spec@(ApplySpec ApplyConv
conv Int
nargs Int
nvars) =
let fun_name :: FastString
fun_name = ApplySpec -> FastString
specApplyName ApplySpec
spec
in case ApplyConv
conv of
ApplyConv
RegsConv -> StgToJSConfig -> FastString -> Int -> Int -> JStat
fastApply StgToJSConfig
cfg FastString
fun_name Int
nargs Int
nvars
ApplyConv
StackConv -> StgToJSConfig -> FastString -> Int -> Int -> JStat
stackApply StgToJSConfig
cfg FastString
fun_name Int
nargs Int
nvars
stackApply
:: StgToJSConfig
-> FastString
-> Int
-> Int
-> JStat
stackApply :: StgToJSConfig -> FastString -> Int -> Int -> JStat
stackApply StgToJSConfig
s FastString
fun_name Int
nargs Int
nvars =
if Int
nargs forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
&& Int
nvars forall a. Eq a => a -> a -> Bool
== Int
0
then ClosureInfo -> JStat -> JStat
closure ClosureInfo
info0 JStat
body0
else ClosureInfo -> JStat -> JStat
closure ClosureInfo
info JStat
body
where
info :: ClosureInfo
info = Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo (FastString -> Ident
TxtI FastString
fun_name) (Int -> [VarType] -> CIRegs
CIRegs Int
0 [VarType
PtrV]) FastString
fun_name (Int -> CILayout
CILayoutUnknown Int
nvars) CIType
CIStackFrame forall a. Monoid a => a
mempty
info0 :: ClosureInfo
info0 = Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo (FastString -> Ident
TxtI FastString
fun_name) (Int -> [VarType] -> CIRegs
CIRegs Int
0 [VarType
PtrV]) FastString
fun_name (Int -> [VarType] -> CILayout
CILayoutFixed Int
0 []) CIType
CIStackFrame forall a. Monoid a => a
mempty
body0 :: JStat
body0 = Int -> JStat
adjSpN' Int
1 forall a. Semigroup a => a -> a -> a
<> StgToJSConfig -> JExpr -> JStat
enter StgToJSConfig
s JExpr
r1
body :: JStat
body = forall a. ToSat a => a -> JStat
jVar \JExpr
c ->
[ JExpr
c JExpr -> JExpr -> JStat
|= JExpr -> JExpr
closureEntry JExpr
r1
, StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (forall a. ToJExpr a => a -> JExpr
toJExpr FastString
fun_name
forall a. Num a => a -> a -> a
+ FastString -> JExpr
jString FastString
" "
forall a. Num a => a -> a -> a
+ (JExpr
c JExpr -> FastString -> JExpr
.^ FastString
"n")
forall a. Num a => a -> a -> a
+ FastString -> JExpr
jString FastString
" sp: " forall a. Num a => a -> a -> a
+ JExpr
sp
forall a. Num a => a -> a -> a
+ FastString -> JExpr
jString FastString
" a: " forall a. Num a => a -> a -> a
+ (JExpr
c JExpr -> FastString -> JExpr
.^ FastString
"a"))
, JExpr -> [(JExpr, JStat)] -> JStat -> JStat
SwitchStat (JExpr -> JExpr
entryClosureType JExpr
c)
[ (forall a. ToJExpr a => a -> JExpr
toJExpr ClosureType
Thunk, StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (forall a. ToJExpr a => a -> JExpr
toJExpr forall a b. (a -> b) -> a -> b
$ FastString
fun_name forall a. Semigroup a => a -> a -> a
<> FastString
": thunk") forall a. Semigroup a => a -> a -> a
<> StgToJSConfig -> JStat -> JStat
profStat StgToJSConfig
s JStat
pushRestoreCCS forall a. Semigroup a => a -> a -> a
<> JExpr -> JStat
returnS JExpr
c)
, (forall a. ToJExpr a => a -> JExpr
toJExpr ClosureType
Fun, StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (forall a. ToJExpr a => a -> JExpr
toJExpr forall a b. (a -> b) -> a -> b
$ FastString
fun_name forall a. Semigroup a => a -> a -> a
<> FastString
": fun") forall a. Semigroup a => a -> a -> a
<> JExpr -> JStat
funCase JExpr
c)
, (forall a. ToJExpr a => a -> JExpr
toJExpr ClosureType
Pap, StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (forall a. ToJExpr a => a -> JExpr
toJExpr forall a b. (a -> b) -> a -> b
$ FastString
fun_name forall a. Semigroup a => a -> a -> a
<> FastString
": pap") forall a. Semigroup a => a -> a -> a
<> JExpr -> JStat
papCase JExpr
c)
, (forall a. ToJExpr a => a -> JExpr
toJExpr ClosureType
Blackhole, StgToJSConfig -> [JExpr] -> JStat
push' StgToJSConfig
s [JExpr
r1, FastString -> JExpr
var FastString
"h$return"] forall a. Semigroup a => a -> a -> a
<> JExpr -> JStat
returnS (FastString -> [JExpr] -> JExpr
app FastString
"h$blockOnBlackhole" [JExpr
r1]))
] (FastString -> [JExpr] -> JStat
appS FastString
"throw" [forall a. ToJExpr a => a -> JExpr
toJExpr (FastString
"panic: " forall a. Semigroup a => a -> a -> a
<> FastString
fun_name forall a. Semigroup a => a -> a -> a
<> FastString
", unexpected closure type: ") forall a. Num a => a -> a -> a
+ (JExpr -> JExpr
entryClosureType JExpr
c)])
]
funExact :: JExpr -> JStat
funExact JExpr
c = Int -> [JExpr] -> JStat
popSkip Int
1 (forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
take Int
nvars [JExpr]
jsRegsFromR2) forall a. Semigroup a => a -> a -> a
<> JExpr -> JStat
returnS JExpr
c
stackArgs :: [JExpr]
stackArgs = forall a b. (a -> b) -> [a] -> [b]
map (\Int
x -> JExpr
stack JExpr -> JExpr -> JExpr
.! (JExpr
sp forall a. Num a => a -> a -> a
- forall a. ToJExpr a => a -> JExpr
toJExpr Int
x)) [Int
1..Int
nvars]
papCase :: JExpr -> JStat
papCase :: JExpr -> JStat
papCase JExpr
c = forall a. ToSat a => a -> JStat
jVar \JExpr
expr JExpr
arity0 JExpr
arity ->
case JExpr
expr of
ValExpr (JVar Ident
pap) -> [ JExpr
arity0 JExpr -> JExpr -> JStat
|= JExpr -> JExpr
papArity JExpr
r1
, JExpr
arity JExpr -> JExpr -> JStat
|= JExpr -> JExpr
mask8 JExpr
arity0
, StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (forall a. ToJExpr a => a -> JExpr
toJExpr (FastString
fun_name forall a. Semigroup a => a -> a -> a
<> FastString
": found pap, arity: ") forall a. Num a => a -> a -> a
+ JExpr
arity)
, JExpr -> JStat -> JStat -> JStat
ifS (forall a. ToJExpr a => a -> JExpr
toJExpr Int
nargs JExpr -> JExpr -> JExpr
.===. JExpr
arity)
(StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (forall a. ToJExpr a => a -> JExpr
toJExpr (FastString
fun_name forall a. Semigroup a => a -> a -> a
<> FastString
": exact")) forall a. Semigroup a => a -> a -> a
<> JExpr -> JStat
funExact JExpr
c)
(JExpr -> JStat -> JStat -> JStat
ifS (forall a. ToJExpr a => a -> JExpr
toJExpr Int
nargs JExpr -> JExpr -> JExpr
.>. JExpr
arity)
(StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (forall a. ToJExpr a => a -> JExpr
toJExpr (FastString
fun_name forall a. Semigroup a => a -> a -> a
<> FastString
": oversat")) forall a. Semigroup a => a -> a -> a
<> JExpr -> JExpr -> JExpr -> JStat
oversatCase JExpr
c JExpr
arity0 JExpr
arity)
(StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (forall a. ToJExpr a => a -> JExpr
toJExpr (FastString
fun_name forall a. Semigroup a => a -> a -> a
<> FastString
": undersat"))
forall a. Semigroup a => a -> a -> a
<> StgToJSConfig -> Ident -> JExpr -> JExpr -> [JExpr] -> JStat
mkPap StgToJSConfig
s Ident
pap JExpr
r1 (forall a. ToJExpr a => a -> JExpr
toJExpr Int
nargs) [JExpr]
stackArgs
forall a. Semigroup a => a -> a -> a
<> (JExpr
sp JExpr -> JExpr -> JStat
|= JExpr
sp forall a. Num a => a -> a -> a
- forall a. ToJExpr a => a -> JExpr
toJExpr (Int
nvars forall a. Num a => a -> a -> a
+ Int
1))
forall a. Semigroup a => a -> a -> a
<> (JExpr
r1 JExpr -> JExpr -> JStat
|= forall a. ToJExpr a => a -> JExpr
toJExpr Ident
pap)
forall a. Semigroup a => a -> a -> a
<> JStat
returnStack))
]
JExpr
_ -> forall a. Monoid a => a
mempty
funCase :: JExpr -> JStat
funCase :: JExpr -> JStat
funCase JExpr
c = forall a. ToSat a => a -> JStat
jVar \JExpr
expr JExpr
ar0 JExpr
ar ->
case JExpr
expr of
ValExpr (JVar Ident
pap) -> [ JExpr
ar0 JExpr -> JExpr -> JStat
|= JExpr -> JExpr
funArity' JExpr
c
, JExpr
ar JExpr -> JExpr -> JStat
|= JExpr -> JExpr
mask8 JExpr
ar0
, JExpr -> JStat -> JStat -> JStat
ifS (forall a. ToJExpr a => a -> JExpr
toJExpr Int
nargs JExpr -> JExpr -> JExpr
.===. JExpr
ar)
(StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (forall a. ToJExpr a => a -> JExpr
toJExpr (FastString
fun_name forall a. Semigroup a => a -> a -> a
<> FastString
": exact")) forall a. Semigroup a => a -> a -> a
<> JExpr -> JStat
funExact JExpr
c)
(JExpr -> JStat -> JStat -> JStat
ifS (forall a. ToJExpr a => a -> JExpr
toJExpr Int
nargs JExpr -> JExpr -> JExpr
.>. JExpr
ar)
(StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (forall a. ToJExpr a => a -> JExpr
toJExpr (FastString
fun_name forall a. Semigroup a => a -> a -> a
<> FastString
": oversat"))
forall a. Semigroup a => a -> a -> a
<> JExpr -> JExpr -> JExpr -> JStat
oversatCase JExpr
c JExpr
ar0 JExpr
ar)
(StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (forall a. ToJExpr a => a -> JExpr
toJExpr (FastString
fun_name forall a. Semigroup a => a -> a -> a
<> FastString
": undersat"))
forall a. Semigroup a => a -> a -> a
<> StgToJSConfig -> Ident -> JExpr -> JExpr -> [JExpr] -> JStat
mkPap StgToJSConfig
s Ident
pap (forall a. ToJExpr a => a -> JExpr
toJExpr StgReg
R1) (forall a. ToJExpr a => a -> JExpr
toJExpr Int
nargs) [JExpr]
stackArgs
forall a. Semigroup a => a -> a -> a
<> (JExpr
sp JExpr -> JExpr -> JStat
|= JExpr
sp forall a. Num a => a -> a -> a
- forall a. ToJExpr a => a -> JExpr
toJExpr (Int
nvarsforall a. Num a => a -> a -> a
+Int
1))
forall a. Semigroup a => a -> a -> a
<> (JExpr
r1 JExpr -> JExpr -> JStat
|= forall a. ToJExpr a => a -> JExpr
toJExpr Ident
pap)
forall a. Semigroup a => a -> a -> a
<> JStat
returnStack))
]
JExpr
_ -> forall a. Monoid a => a
mempty
oversatCase :: JExpr
-> JExpr
-> JExpr
-> JStat
oversatCase :: JExpr -> JExpr -> JExpr -> JStat
oversatCase JExpr
c JExpr
arity JExpr
arity0 =
forall a. ToSat a => a -> JStat
jVar \JExpr
rs JExpr
newAp ->
[ JExpr
rs JExpr -> JExpr -> JStat
|= (JExpr
arity JExpr -> JExpr -> JExpr
.>>. JExpr
8)
, JExpr -> JStat
loadRegs JExpr
rs
, JExpr
sp JExpr -> JExpr -> JStat
|= JExpr
sp forall a. Num a => a -> a -> a
- JExpr
rs
, JExpr
newAp JExpr -> JExpr -> JStat
|= (FastString -> JExpr
var FastString
"h$apply" JExpr -> JExpr -> JExpr
.! ((forall a. ToJExpr a => a -> JExpr
toJExpr Int
nargsforall a. Num a => a -> a -> a
-JExpr
arity0)JExpr -> JExpr -> JExpr
.|.((forall a. ToJExpr a => a -> JExpr
toJExpr Int
nvarsforall a. Num a => a -> a -> a
-JExpr
rs)JExpr -> JExpr -> JExpr
.<<.JExpr
8)))
, JExpr
stack JExpr -> JExpr -> JExpr
.! JExpr
sp JExpr -> JExpr -> JStat
|= JExpr
newAp
, StgToJSConfig -> JStat -> JStat
profStat StgToJSConfig
s JStat
pushRestoreCCS
, StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (forall a. ToJExpr a => a -> JExpr
toJExpr (FastString
fun_name forall a. Semigroup a => a -> a -> a
<> FastString
": new stack frame: ") forall a. Num a => a -> a -> a
+ (JExpr
newAp JExpr -> FastString -> JExpr
.^ FastString
"n"))
, JExpr -> JStat
returnS JExpr
c
]
where
loadRegs :: JExpr -> JStat
loadRegs JExpr
rs = JExpr -> [(JExpr, JStat)] -> JStat -> JStat
SwitchStat JExpr
rs [(JExpr, JStat)]
switchAlts forall a. Monoid a => a
mempty
where
switchAlts :: [(JExpr, JStat)]
switchAlts = forall a b. (a -> b) -> [a] -> [b]
map (\Int
x -> (forall a. ToJExpr a => a -> JExpr
toJExpr Int
x, Int -> JExpr
jsReg (Int
xforall a. Num a => a -> a -> a
+Int
1) JExpr -> JExpr -> JStat
|= JExpr
stack JExpr -> JExpr -> JExpr
.! (JExpr
sp forall a. Num a => a -> a -> a
- forall a. ToJExpr a => a -> JExpr
toJExpr Int
x))) [Int
nvars,Int
nvarsforall a. Num a => a -> a -> a
-Int
1..Int
1]
fastApply :: StgToJSConfig -> FastString -> Int -> Int -> JStat
fastApply :: StgToJSConfig -> FastString -> Int -> Int -> JStat
fastApply StgToJSConfig
s FastString
fun_name Int
nargs Int
nvars = Ident
func Ident -> JExpr -> JStat
||= JExpr
body0
where
body0 :: JExpr
body0 = if Int
nargs forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
&& Int
nvars forall a. Eq a => a -> a -> Bool
== Int
0
then forall a. ToSat a => a -> JExpr
jLam (StgToJSConfig -> JExpr -> JStat
enter StgToJSConfig
s JExpr
r1)
else forall a. ToJExpr a => a -> JExpr
toJExpr ([Ident] -> JStat -> JVal
JFunc forall a. [a]
myFunArgs JStat
body)
func :: Ident
func = FastString -> Ident
TxtI FastString
fun_name
myFunArgs :: [a]
myFunArgs = []
regArgs :: [JExpr]
regArgs = forall a. Int -> [a] -> [a]
take Int
nvars [JExpr]
jsRegsFromR2
mkAp :: Int -> Int -> [JExpr]
mkAp :: Int -> Int -> [JExpr]
mkAp Int
n' Int
r' = [ ApplySpec -> JExpr
specApplyExpr (ApplyConv -> Int -> Int -> ApplySpec
ApplySpec ApplyConv
StackConv Int
n' Int
r') ]
body :: JStat
body =
forall a. ToSat a => a -> JStat
jVar \JExpr
c JExpr
farity JExpr
arity ->
[ JExpr
c JExpr -> JExpr -> JStat
|= JExpr -> JExpr
closureEntry JExpr
r1
, StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (forall a. ToJExpr a => a -> JExpr
toJExpr (FastString
fun_name forall a. Semigroup a => a -> a -> a
<> FastString
": sp ") forall a. Num a => a -> a -> a
+ JExpr
sp)
, JExpr -> [(JExpr, JStat)] -> JStat -> JStat
SwitchStat (JExpr -> JExpr
entryClosureType JExpr
c)
[(forall a. ToJExpr a => a -> JExpr
toJExpr ClosureType
Fun, StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (forall a. ToJExpr a => a -> JExpr
toJExpr (FastString
fun_name forall a. Semigroup a => a -> a -> a
<> FastString
": ")
forall a. Num a => a -> a -> a
+ JExpr -> JExpr
clName JExpr
c
forall a. Num a => a -> a -> a
+ FastString -> JExpr
jString FastString
" (arity: " forall a. Num a => a -> a -> a
+ (JExpr
c JExpr -> FastString -> JExpr
.^ FastString
"a") forall a. Num a => a -> a -> a
+ FastString -> JExpr
jString FastString
")")
forall a. Semigroup a => a -> a -> a
<> (JExpr
farity JExpr -> JExpr -> JStat
|= JExpr -> JExpr
funArity' JExpr
c)
forall a. Semigroup a => a -> a -> a
<> JExpr -> JExpr -> JStat
funCase JExpr
c JExpr
farity)
,(forall a. ToJExpr a => a -> JExpr
toJExpr ClosureType
Pap, StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (forall a. ToJExpr a => a -> JExpr
toJExpr (FastString
fun_name forall a. Semigroup a => a -> a -> a
<> FastString
": pap")) forall a. Semigroup a => a -> a -> a
<> (JExpr
arity JExpr -> JExpr -> JStat
|= JExpr -> JExpr
papArity JExpr
r1) forall a. Semigroup a => a -> a -> a
<> JExpr -> JExpr -> JStat
funCase JExpr
c JExpr
arity)
,(forall a. ToJExpr a => a -> JExpr
toJExpr ClosureType
Thunk, StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (forall a. ToJExpr a => a -> JExpr
toJExpr (FastString
fun_name forall a. Semigroup a => a -> a -> a
<> FastString
": thunk")) forall a. Semigroup a => a -> a -> a
<> StgToJSConfig -> [JExpr] -> JStat
push' StgToJSConfig
s (forall a. [a] -> [a]
reverse [JExpr]
regArgs forall a. [a] -> [a] -> [a]
++ Int -> Int -> [JExpr]
mkAp Int
nargs Int
nvars) forall a. Semigroup a => a -> a -> a
<> StgToJSConfig -> JStat -> JStat
profStat StgToJSConfig
s JStat
pushRestoreCCS forall a. Semigroup a => a -> a -> a
<> JExpr -> JStat
returnS JExpr
c)
,(forall a. ToJExpr a => a -> JExpr
toJExpr ClosureType
Blackhole, StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (forall a. ToJExpr a => a -> JExpr
toJExpr (FastString
fun_name forall a. Semigroup a => a -> a -> a
<> FastString
": blackhole")) forall a. Semigroup a => a -> a -> a
<> StgToJSConfig -> [JExpr] -> JStat
push' StgToJSConfig
s (forall a. [a] -> [a]
reverse [JExpr]
regArgs forall a. [a] -> [a] -> [a]
++ Int -> Int -> [JExpr]
mkAp Int
nargs Int
nvars) forall a. Semigroup a => a -> a -> a
<> StgToJSConfig -> [JExpr] -> JStat
push' StgToJSConfig
s [JExpr
r1, FastString -> JExpr
var FastString
"h$return"] forall a. Semigroup a => a -> a -> a
<> JExpr -> JStat
returnS (FastString -> [JExpr] -> JExpr
app FastString
"h$blockOnBlackhole" [JExpr
r1]))]
(FastString -> [JExpr] -> JStat
appS FastString
"throw" [forall a. ToJExpr a => a -> JExpr
toJExpr (FastString
fun_name forall a. Semigroup a => a -> a -> a
<> FastString
": unexpected closure type: ") forall a. Num a => a -> a -> a
+ JExpr -> JExpr
entryClosureType JExpr
c])
]
funCase :: JExpr -> JExpr -> JStat
funCase :: JExpr -> JExpr -> JStat
funCase JExpr
c JExpr
arity = forall a. ToSat a => a -> JStat
jVar \JExpr
arg JExpr
ar -> case JExpr
arg of
ValExpr (JVar Ident
pap) -> [ JExpr
ar JExpr -> JExpr -> JStat
|= JExpr -> JExpr
mask8 JExpr
arity
, JExpr -> JStat -> JStat -> JStat
ifS (forall a. ToJExpr a => a -> JExpr
toJExpr Int
nargs JExpr -> JExpr -> JExpr
.===. JExpr
ar)
(StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (forall a. ToJExpr a => a -> JExpr
toJExpr (FastString
fun_name forall a. Semigroup a => a -> a -> a
<> FastString
": exact")) forall a. Semigroup a => a -> a -> a
<> JExpr -> JStat
returnS JExpr
c)
(JExpr -> JStat -> JStat -> JStat
ifS (forall a. ToJExpr a => a -> JExpr
toJExpr Int
nargs JExpr -> JExpr -> JExpr
.>. JExpr
ar)
(StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (forall a. ToJExpr a => a -> JExpr
toJExpr (FastString
fun_name forall a. Semigroup a => a -> a -> a
<> FastString
": oversat")) forall a. Semigroup a => a -> a -> a
<> JExpr -> JExpr -> JStat
oversatCase JExpr
c JExpr
arity)
(StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (forall a. ToJExpr a => a -> JExpr
toJExpr (FastString
fun_name forall a. Semigroup a => a -> a -> a
<> FastString
": undersat"))
forall a. Semigroup a => a -> a -> a
<> StgToJSConfig -> Ident -> JExpr -> JExpr -> [JExpr] -> JStat
mkPap StgToJSConfig
s Ident
pap JExpr
r1 (forall a. ToJExpr a => a -> JExpr
toJExpr Int
nargs) [JExpr]
regArgs
forall a. Semigroup a => a -> a -> a
<> (JExpr
r1 JExpr -> JExpr -> JStat
|= forall a. ToJExpr a => a -> JExpr
toJExpr Ident
pap)
forall a. Semigroup a => a -> a -> a
<> JStat
returnStack))
]
JExpr
_ -> forall a. Monoid a => a
mempty
oversatCase :: JExpr -> JExpr -> JStat
oversatCase :: JExpr -> JExpr -> JStat
oversatCase JExpr
c JExpr
arity =
forall a. ToSat a => a -> JStat
jVar \JExpr
rs JExpr
rsRemain ->
[ JExpr
rs JExpr -> JExpr -> JStat
|= JExpr
arity JExpr -> JExpr -> JExpr
.>>. JExpr
8
, JExpr
rsRemain JExpr -> JExpr -> JStat
|= forall a. ToJExpr a => a -> JExpr
toJExpr Int
nvars forall a. Num a => a -> a -> a
- JExpr
rs
, StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (forall a. ToJExpr a => a -> JExpr
toJExpr
(FastString
fun_name forall a. Semigroup a => a -> a -> a
<> FastString
" regs oversat ")
forall a. Num a => a -> a -> a
+ JExpr
rs
forall a. Num a => a -> a -> a
+ FastString -> JExpr
jString FastString
" remain: "
forall a. Num a => a -> a -> a
+ JExpr
rsRemain)
, JExpr -> JStat
saveRegs JExpr
rs
, JExpr
sp JExpr -> JExpr -> JStat
|= JExpr
sp forall a. Num a => a -> a -> a
+ JExpr
rsRemain forall a. Num a => a -> a -> a
+ JExpr
1
, JExpr
stack JExpr -> JExpr -> JExpr
.! JExpr
sp JExpr -> JExpr -> JStat
|= FastString -> JExpr
var FastString
"h$apply" JExpr -> JExpr -> JExpr
.! ((JExpr
rsRemainJExpr -> JExpr -> JExpr
.<<.JExpr
8)JExpr -> JExpr -> JExpr
.|. (forall a. ToJExpr a => a -> JExpr
toJExpr Int
nargs forall a. Num a => a -> a -> a
- JExpr -> JExpr
mask8 JExpr
arity))
, StgToJSConfig -> JStat -> JStat
profStat StgToJSConfig
s JStat
pushRestoreCCS
, JExpr -> JStat
returnS JExpr
c
]
where
saveRegs :: JExpr -> JStat
saveRegs JExpr
n = JExpr -> [(JExpr, JStat)] -> JStat -> JStat
SwitchStat JExpr
n [(JExpr, JStat)]
switchAlts forall a. Monoid a => a
mempty
where
switchAlts :: [(JExpr, JStat)]
switchAlts = forall a b. (a -> b) -> [a] -> [b]
map (\Int
x -> (forall a. ToJExpr a => a -> JExpr
toJExpr Int
x, JExpr
stack JExpr -> JExpr -> JExpr
.! (JExpr
sp forall a. Num a => a -> a -> a
+ forall a. ToJExpr a => a -> JExpr
toJExpr (Int
nvarsforall a. Num a => a -> a -> a
-Int
x)) JExpr -> JExpr -> JStat
|= Int -> JExpr
jsReg (Int
xforall a. Num a => a -> a -> a
+Int
2))) [Int
0..Int
nvarsforall a. Num a => a -> a -> a
-Int
1]
zeroApply :: StgToJSConfig -> JStat
zeroApply :: StgToJSConfig -> JStat
zeroApply StgToJSConfig
s = forall a. Monoid a => [a] -> a
mconcat
[ FastString -> Ident
TxtI FastString
"h$e" Ident -> JExpr -> JStat
||= forall a. ToSat a => a -> JExpr
jLam (\JExpr
c -> (JExpr
r1 JExpr -> JExpr -> JStat
|= JExpr
c) forall a. Semigroup a => a -> a -> a
<> StgToJSConfig -> JExpr -> JStat
enter StgToJSConfig
s JExpr
c)
]
enter :: StgToJSConfig -> JExpr -> JStat
enter :: StgToJSConfig -> JExpr -> JStat
enter StgToJSConfig
s JExpr
ex = forall a. ToSat a => a -> JStat
jVar \JExpr
c ->
[ JExpr -> JStat -> JStat
jwhenS (FastString -> [JExpr] -> JExpr
app FastString
"typeof" [JExpr
ex] JExpr -> JExpr -> JExpr
.!==. JExpr
jTyObject) JStat
returnStack
, JExpr
c JExpr -> JExpr -> JStat
|= JExpr -> JExpr
closureEntry JExpr
ex
, JExpr -> JStat -> JStat
jwhenS (JExpr
c JExpr -> JExpr -> JExpr
.===. FastString -> JExpr
var FastString
"h$unbox_e") ((JExpr
r1 JExpr -> JExpr -> JStat
|= JExpr -> JExpr
closureField1 JExpr
ex) forall a. Semigroup a => a -> a -> a
<> JStat
returnStack)
, JExpr -> [(JExpr, JStat)] -> JStat -> JStat
SwitchStat (JExpr -> JExpr
entryClosureType JExpr
c)
[ (forall a. ToJExpr a => a -> JExpr
toJExpr ClosureType
Con, forall a. Monoid a => a
mempty)
, (forall a. ToJExpr a => a -> JExpr
toJExpr ClosureType
Fun, forall a. Monoid a => a
mempty)
, (forall a. ToJExpr a => a -> JExpr
toJExpr ClosureType
Pap, JStat
returnStack)
, (forall a. ToJExpr a => a -> JExpr
toJExpr ClosureType
Blackhole, StgToJSConfig -> [JExpr] -> JStat
push' StgToJSConfig
s [FastString -> JExpr
var FastString
"h$ap_0_0", JExpr
ex, FastString -> JExpr
var FastString
"h$return"]
forall a. Semigroup a => a -> a -> a
<> JExpr -> JStat
returnS (FastString -> [JExpr] -> JExpr
app FastString
"h$blockOnBlackhole" [JExpr
ex]))
] (JExpr -> JStat
returnS JExpr
c)
]
updates :: StgToJSConfig -> JStat
updates :: StgToJSConfig -> JStat
updates StgToJSConfig
s = [JStat] -> JStat
BlockStat
[ ClosureInfo -> JStat -> JStat
closure
(Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo (FastString -> Ident
TxtI FastString
"h$upd_frame") (Int -> [VarType] -> CIRegs
CIRegs Int
0 [VarType
PtrV]) FastString
"h$upd_frame" (Int -> [VarType] -> CILayout
CILayoutFixed Int
1 [VarType
PtrV]) CIType
CIStackFrame forall a. Monoid a => a
mempty)
forall a b. (a -> b) -> a -> b
$ forall a. ToSat a => a -> JStat
jVar \JExpr
updatee JExpr
waiters JExpr
ss JExpr
si JExpr
sir ->
let unbox_closure :: Closure
unbox_closure = Closure
{ clEntry :: JExpr
clEntry = FastString -> JExpr
var FastString
"h$unbox_e"
, clField1 :: JExpr
clField1 = JExpr
sir
, clField2 :: JExpr
clField2 = JExpr
null_
, clMeta :: JExpr
clMeta = JExpr
0
, clCC :: Maybe JExpr
clCC = forall a. Maybe a
Nothing
}
updateCC :: JExpr -> JStat
updateCC JExpr
updatee = JExpr -> JExpr
closureCC JExpr
updatee JExpr -> JExpr -> JStat
|= JExpr
jCurrentCCS
in [ JExpr
updatee JExpr -> JExpr -> JStat
|= JExpr
stack JExpr -> JExpr -> JExpr
.! (JExpr
sp forall a. Num a => a -> a -> a
- JExpr
1)
, StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (FastString -> JExpr
jString FastString
"h$upd_frame updatee alloc: " forall a. Num a => a -> a -> a
+ JExpr
updatee JExpr -> FastString -> JExpr
.^ FastString
"alloc")
,
JExpr
waiters JExpr -> JExpr -> JStat
|= JExpr -> JExpr
closureField2 JExpr
updatee
, JExpr -> JStat -> JStat
jwhenS (JExpr
waiters JExpr -> JExpr -> JExpr
.!==. JExpr
null_)
(JExpr -> (JExpr -> JExpr) -> (JExpr -> JStat) -> JStat
loop JExpr
0 (JExpr -> JExpr -> JExpr
.<. JExpr
waiters JExpr -> FastString -> JExpr
.^ FastString
"length")
(\JExpr
i -> FastString -> [JExpr] -> JStat
appS FastString
"h$wakeupThread" [JExpr
waiters JExpr -> JExpr -> JExpr
.! JExpr
i] forall a. Semigroup a => a -> a -> a
<> JExpr -> JStat
postIncrS JExpr
i))
,
JExpr -> JStat -> JStat
jwhenS ((FastString -> [JExpr] -> JExpr
app FastString
"typeof" [JExpr -> JExpr
closureMeta JExpr
updatee] JExpr -> JExpr -> JExpr
.===. JExpr
jTyObject) JExpr -> JExpr -> JExpr
.&&. (JExpr -> JExpr
closureMeta JExpr
updatee JExpr -> FastString -> JExpr
.^ FastString
"sel"))
((JExpr
ss JExpr -> JExpr -> JStat
|= JExpr -> JExpr
closureMeta JExpr
updatee JExpr -> FastString -> JExpr
.^ FastString
"sel")
forall a. Semigroup a => a -> a -> a
<> JExpr -> (JExpr -> JExpr) -> (JExpr -> JStat) -> JStat
loop JExpr
0 (JExpr -> JExpr -> JExpr
.<. JExpr
ss JExpr -> FastString -> JExpr
.^ FastString
"length") \JExpr
i -> forall a. Monoid a => [a] -> a
mconcat
[ JExpr
si JExpr -> JExpr -> JStat
|= JExpr
ss JExpr -> JExpr -> JExpr
.! JExpr
i
, JExpr
sir JExpr -> JExpr -> JStat
|= (JExpr -> JExpr
closureField2 JExpr
si) JExpr -> [JExpr] -> JExpr
`ApplExpr` [JExpr
r1]
, JExpr -> JStat -> JStat -> JStat
ifS (FastString -> [JExpr] -> JExpr
app FastString
"typeof" [JExpr
sir] JExpr -> JExpr -> JExpr
.===. JExpr
jTyObject)
(CopyCC -> JExpr -> JExpr -> JStat
copyClosure CopyCC
DontCopyCC JExpr
si JExpr
sir)
(JExpr -> Closure -> JStat
assignClosure JExpr
si Closure
unbox_closure)
, JExpr -> JStat
postIncrS JExpr
i
])
,
JExpr -> JStat -> JStat -> JStat
ifS (FastString -> [JExpr] -> JExpr
app FastString
"typeof" [JExpr
r1] JExpr -> JExpr -> JExpr
.===. JExpr
jTyObject)
(forall a. Monoid a => [a] -> a
mconcat [ StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (FastString -> JExpr
jString FastString
"$upd_frame: boxed: " forall a. Num a => a -> a -> a
+ ((JExpr -> JExpr
closureEntry JExpr
r1) JExpr -> FastString -> JExpr
.^ FastString
"n"))
, CopyCC -> JExpr -> JExpr -> JStat
copyClosure CopyCC
DontCopyCC JExpr
updatee JExpr
r1
])
(JExpr -> Closure -> JStat
assignClosure JExpr
updatee (Closure
unbox_closure { clField1 :: JExpr
clField1 = JExpr
r1 }))
, StgToJSConfig -> JStat -> JStat
profStat StgToJSConfig
s (JExpr -> JStat
updateCC JExpr
updatee)
, Int -> JStat
adjSpN' Int
2
, StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (FastString -> JExpr
jString FastString
"h$upd_frame: updating: "
forall a. Num a => a -> a -> a
+ JExpr
updatee
forall a. Num a => a -> a -> a
+ FastString -> JExpr
jString FastString
" -> "
forall a. Num a => a -> a -> a
+ JExpr
r1)
, JStat
returnStack
]
, ClosureInfo -> JStat -> JStat
closure
(Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo (FastString -> Ident
TxtI FastString
"h$upd_frame_lne") (Int -> [VarType] -> CIRegs
CIRegs Int
0 [VarType
PtrV]) FastString
"h$upd_frame_lne" (Int -> [VarType] -> CILayout
CILayoutFixed Int
1 [VarType
PtrV]) CIType
CIStackFrame forall a. Monoid a => a
mempty)
forall a b. (a -> b) -> a -> b
$ forall a. ToSat a => a -> JStat
jVar \JExpr
updateePos ->
[ JExpr
updateePos JExpr -> JExpr -> JStat
|= JExpr
stack JExpr -> JExpr -> JExpr
.! (JExpr
sp forall a. Num a => a -> a -> a
- JExpr
1)
, (JExpr
stack JExpr -> JExpr -> JExpr
.! JExpr
updateePos JExpr -> JExpr -> JStat
|= JExpr
r1)
, Int -> JStat
adjSpN' Int
2
, StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (FastString -> JExpr
jString FastString
"h$upd_frame_lne: updating: "
forall a. Num a => a -> a -> a
+ JExpr
updateePos
forall a. Num a => a -> a -> a
+ FastString -> JExpr
jString FastString
" -> "
forall a. Num a => a -> a -> a
+ JExpr
r1)
, JStat
returnStack
]
]
selectors :: StgToJSConfig -> JStat
selectors :: StgToJSConfig -> JStat
selectors StgToJSConfig
s =
FastString -> (JExpr -> JExpr) -> JStat
mkSel FastString
"1" JExpr -> JExpr
closureField1
forall a. Semigroup a => a -> a -> a
<> FastString -> (JExpr -> JExpr) -> JStat
mkSel FastString
"2a" JExpr -> JExpr
closureField2
forall a. Semigroup a => a -> a -> a
<> FastString -> (JExpr -> JExpr) -> JStat
mkSel FastString
"2b" (JExpr -> JExpr
closureField1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. JExpr -> JExpr
closureField2)
forall a. Semigroup a => a -> a -> a
<> forall a. Monoid a => [a] -> a
mconcat (forall a b. (a -> b) -> [a] -> [b]
map Int -> JStat
mkSelN [Int
3..Int
16])
where
mkSelN :: Int -> JStat
mkSelN :: Int -> JStat
mkSelN Int
x = FastString -> (JExpr -> JExpr) -> JStat
mkSel ([Char] -> FastString
mkFastString forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show Int
x)
(\JExpr
e -> JExpr -> Ident -> JExpr
SelExpr (JExpr -> JExpr
closureField2 (forall a. ToJExpr a => a -> JExpr
toJExpr JExpr
e))
(FastString -> Ident
TxtI forall a b. (a -> b) -> a -> b
$ [Char] -> FastString
mkFastString ([Char]
"d" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (Int
xforall a. Num a => a -> a -> a
-Int
1))))
mkSel :: FastString -> (JExpr -> JExpr) -> JStat
mkSel :: FastString -> (JExpr -> JExpr) -> JStat
mkSel FastString
name JExpr -> JExpr
sel = forall a. Monoid a => [a] -> a
mconcat
[FastString -> Ident
TxtI FastString
createName Ident -> JExpr -> JStat
||= forall a. ToSat a => a -> JExpr
jLam \JExpr
r -> forall a. Monoid a => [a] -> a
mconcat
[ StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (forall a. ToJExpr a => a -> JExpr
toJExpr (FastString
"selector create: " forall a. Semigroup a => a -> a -> a
<> FastString
name forall a. Semigroup a => a -> a -> a
<> FastString
" for ") forall a. Num a => a -> a -> a
+ (JExpr
r JExpr -> FastString -> JExpr
.^ FastString
"alloc"))
, JExpr -> JStat -> JStat -> JStat
ifS (JExpr -> JExpr
isThunk JExpr
r JExpr -> JExpr -> JExpr
.||. JExpr -> JExpr
isBlackhole JExpr
r)
(JExpr -> JStat
returnS (FastString -> [JExpr] -> JExpr
app FastString
"h$mkSelThunk" [JExpr
r, forall a. ToJExpr a => a -> JExpr
toJExpr (FastString -> JVal
v FastString
entryName), forall a. ToJExpr a => a -> JExpr
toJExpr (FastString -> JVal
v FastString
resName)]))
(JExpr -> JStat
returnS (JExpr -> JExpr
sel JExpr
r))
]
, FastString -> Ident
TxtI FastString
resName Ident -> JExpr -> JStat
||= forall a. ToSat a => a -> JExpr
jLam \JExpr
r -> forall a. Monoid a => [a] -> a
mconcat
[ StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (forall a. ToJExpr a => a -> JExpr
toJExpr (FastString
"selector result: " forall a. Semigroup a => a -> a -> a
<> FastString
name forall a. Semigroup a => a -> a -> a
<> FastString
" for ") forall a. Num a => a -> a -> a
+ (JExpr
r JExpr -> FastString -> JExpr
.^ FastString
"alloc"))
, JExpr -> JStat
returnS (JExpr -> JExpr
sel JExpr
r)
]
, ClosureInfo -> JStat -> JStat
closure
(Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo (FastString -> Ident
TxtI FastString
entryName) (Int -> [VarType] -> CIRegs
CIRegs Int
0 [VarType
PtrV]) (FastString
"select " forall a. Semigroup a => a -> a -> a
<> FastString
name) (Int -> [VarType] -> CILayout
CILayoutFixed Int
1 [VarType
PtrV]) CIType
CIThunk forall a. Monoid a => a
mempty)
(forall a. ToSat a => a -> JStat
jVar \JExpr
tgt ->
[ JExpr
tgt JExpr -> JExpr -> JStat
|= JExpr -> JExpr
closureField1 JExpr
r1
, StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (forall a. ToJExpr a => a -> JExpr
toJExpr (FastString
"selector entry: " forall a. Semigroup a => a -> a -> a
<> FastString
name forall a. Semigroup a => a -> a -> a
<> FastString
" for ") forall a. Num a => a -> a -> a
+ (JExpr
tgt JExpr -> FastString -> JExpr
.^ FastString
"alloc"))
, JExpr -> JStat -> JStat -> JStat
ifS (JExpr -> JExpr
isThunk JExpr
tgt JExpr -> JExpr -> JExpr
.||. JExpr -> JExpr
isBlackhole JExpr
tgt)
(JExpr -> JStat
preIncrS JExpr
sp
forall a. Semigroup a => a -> a -> a
<> (JExpr
stack JExpr -> JExpr -> JExpr
.! JExpr
sp JExpr -> JExpr -> JStat
|= FastString -> JExpr
var FastString
frameName)
forall a. Semigroup a => a -> a -> a
<> JExpr -> JStat
returnS (FastString -> [JExpr] -> JExpr
app FastString
"h$e" [JExpr
tgt]))
(JExpr -> JStat
returnS (FastString -> [JExpr] -> JExpr
app FastString
"h$e" [JExpr -> JExpr
sel JExpr
tgt]))
])
, ClosureInfo -> JStat -> JStat
closure
(Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo (FastString -> Ident
TxtI FastString
frameName) (Int -> [VarType] -> CIRegs
CIRegs Int
0 [VarType
PtrV]) (FastString
"select " forall a. Semigroup a => a -> a -> a
<> FastString
name forall a. Semigroup a => a -> a -> a
<> FastString
" frame") (Int -> [VarType] -> CILayout
CILayoutFixed Int
0 []) CIType
CIStackFrame forall a. Monoid a => a
mempty)
forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat [ StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (forall a. ToJExpr a => a -> JExpr
toJExpr (FastString
"selector frame: " forall a. Semigroup a => a -> a -> a
<> FastString
name))
, JExpr -> JStat
postDecrS JExpr
sp
, JExpr -> JStat
returnS (FastString -> [JExpr] -> JExpr
app FastString
"h$e" [JExpr -> JExpr
sel JExpr
r1])
]
]
where
v :: FastString -> JVal
v FastString
x = Ident -> JVal
JVar (FastString -> Ident
TxtI FastString
x)
n :: FastString -> FastString
n FastString
ext = FastString
"h$c_sel_" forall a. Semigroup a => a -> a -> a
<> FastString
name forall a. Semigroup a => a -> a -> a
<> FastString
ext
createName :: FastString
createName = FastString -> FastString
n FastString
""
resName :: FastString
resName = FastString -> FastString
n FastString
"_res"
entryName :: FastString
entryName = FastString -> FastString
n FastString
"_e"
frameName :: FastString
frameName = FastString -> FastString
n FastString
"_frame_e"
mkPap :: StgToJSConfig
-> Ident
-> JExpr
-> JExpr
-> [JExpr]
-> JStat
mkPap :: StgToJSConfig -> Ident -> JExpr -> JExpr -> [JExpr] -> JStat
mkPap StgToJSConfig
s Ident
tgt JExpr
fun JExpr
n [JExpr]
values =
StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (forall a. ToJExpr a => a -> JExpr
toJExpr forall a b. (a -> b) -> a -> b
$ [Char]
"making pap with: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [JExpr]
values) forall a. [a] -> [a] -> [a]
++ [Char]
" items")
forall a. Monoid a => a -> a -> a
`mappend`
StgToJSConfig
-> Bool -> Ident -> JExpr -> [JExpr] -> Maybe JExpr -> JStat
allocDynamic StgToJSConfig
s Bool
True Ident
tgt (forall a. ToJExpr a => a -> JExpr
toJExpr Ident
entry) (JExpr
funforall a. a -> [a] -> [a]
:JExpr
papArforall a. a -> [a] -> [a]
:forall a b. (a -> b) -> [a] -> [b]
map forall a. ToJExpr a => a -> JExpr
toJExpr [JExpr]
values')
(if StgToJSConfig -> Bool
csProf StgToJSConfig
s then forall a. a -> Maybe a
Just JExpr
jCurrentCCS else forall a. Maybe a
Nothing)
where
papAr :: JExpr
papAr = JExpr -> Maybe JExpr -> JExpr
funOrPapArity JExpr
fun forall a. Maybe a
Nothing forall a. Num a => a -> a -> a
- forall a. ToJExpr a => a -> JExpr
toJExpr (forall (t :: * -> *) a. Foldable t => t a -> Int
length [JExpr]
values forall a. Num a => a -> a -> a
* Int
256) forall a. Num a => a -> a -> a
- JExpr
n
values' :: [JExpr]
values' | forall (t :: * -> *) a. Foldable t => t a -> Bool
GHC.Prelude.null [JExpr]
values = [JExpr
null_]
| Bool
otherwise = [JExpr]
values
entry :: Ident
entry | forall (t :: * -> *) a. Foldable t => t a -> Int
length [JExpr]
values forall a. Ord a => a -> a -> Bool
> Int
numSpecPap = FastString -> Ident
TxtI FastString
"h$pap_gen"
| Bool
otherwise = Array Int Ident
specPapIdents forall i e. Ix i => Array i e -> i -> e
! forall (t :: * -> *) a. Foldable t => t a -> Int
length [JExpr]
values
numSpecPap :: Int
numSpecPap :: Int
numSpecPap = Int
6
specPap :: [Int]
specPap :: [Int]
specPap = [Int
0..Int
numSpecPap]
specPapIdents :: Array Int Ident
specPapIdents :: Array Int Ident
specPapIdents = forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0,Int
numSpecPap) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (FastString -> Ident
TxtI forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> FastString
mkFastString forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
"h$pap_"forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show) [Int]
specPap
pap :: StgToJSConfig
-> Int
-> JStat
pap :: StgToJSConfig -> Int -> JStat
pap StgToJSConfig
s Int
r = ClosureInfo -> JStat -> JStat
closure (Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo Ident
funcIdent CIRegs
CIRegsUnknown FastString
funcName (Int -> CILayout
CILayoutUnknown (Int
rforall a. Num a => a -> a -> a
+Int
2)) CIType
CIPap forall a. Monoid a => a
mempty) JStat
body
where
funcIdent :: Ident
funcIdent = FastString -> Ident
TxtI FastString
funcName
funcName :: FastString
funcName = [Char] -> FastString
mkFastString ([Char]
"h$pap_" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int
r)
body :: JStat
body = forall a. ToSat a => a -> JStat
jVar \JExpr
c JExpr
d JExpr
f JExpr
extra ->
[ JExpr
c JExpr -> JExpr -> JStat
|= JExpr -> JExpr
closureField1 JExpr
r1
, JExpr
d JExpr -> JExpr -> JStat
|= JExpr -> JExpr
closureField2 JExpr
r1
, JExpr
f JExpr -> JExpr -> JStat
|= JExpr -> JExpr
closureEntry JExpr
c
, forall a. ToJExpr a => StgToJSConfig -> JExpr -> a -> JStat
assertRts StgToJSConfig
s (JExpr -> JExpr
isFun' JExpr
f JExpr -> JExpr -> JExpr
.||. JExpr -> JExpr
isPap' JExpr
f) (FastString
funcName forall a. Semigroup a => a -> a -> a
<> FastString
": expected function or pap")
, StgToJSConfig -> JStat -> JStat
profStat StgToJSConfig
s (CostCentreStack -> JStat
enterCostCentreFun CostCentreStack
currentCCS)
, JExpr
extra JExpr -> JExpr -> JStat
|= (JExpr -> Maybe JExpr -> JExpr
funOrPapArity JExpr
c (forall a. a -> Maybe a
Just JExpr
f) JExpr -> JExpr -> JExpr
.>>. JExpr
8) forall a. Num a => a -> a -> a
- forall a. ToJExpr a => a -> JExpr
toJExpr Int
r
, StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (forall a. ToJExpr a => a -> JExpr
toJExpr (FastString
funcName forall a. Semigroup a => a -> a -> a
<> FastString
": pap extra args moving: ") forall a. Num a => a -> a -> a
+ JExpr
extra)
, JExpr -> JStat
moveBy JExpr
extra
, JExpr -> JStat
loadOwnArgs JExpr
d
, JExpr
r1 JExpr -> JExpr -> JStat
|= JExpr
c
, JExpr -> JStat
returnS JExpr
f
]
moveBy :: JExpr -> JStat
moveBy JExpr
extra = JExpr -> [(JExpr, JStat)] -> JStat -> JStat
SwitchStat JExpr
extra
(forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Int -> (JExpr, JStat)
moveCase [Int
1..Int
maxRegforall a. Num a => a -> a -> a
-Int
rforall a. Num a => a -> a -> a
-Int
1]) forall a. Monoid a => a
mempty
moveCase :: Int -> (JExpr, JStat)
moveCase Int
m = (forall a. ToJExpr a => a -> JExpr
toJExpr Int
m, Int -> JExpr
jsReg (Int
mforall a. Num a => a -> a -> a
+Int
rforall a. Num a => a -> a -> a
+Int
1) JExpr -> JExpr -> JStat
|= Int -> JExpr
jsReg (Int
mforall a. Num a => a -> a -> a
+Int
1))
loadOwnArgs :: JExpr -> JStat
loadOwnArgs JExpr
d = forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\Int
r ->
Int -> JExpr
jsReg (Int
rforall a. Num a => a -> a -> a
+Int
1) JExpr -> JExpr -> JStat
|= forall {a}. (Show a, Num a) => JExpr -> a -> JExpr
dField JExpr
d (Int
rforall a. Num a => a -> a -> a
+Int
2)) [Int
1..Int
r]
dField :: JExpr -> a -> JExpr
dField JExpr
d a
n = JExpr -> Ident -> JExpr
SelExpr JExpr
d (FastString -> Ident
TxtI forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> FastString
mkFastString forall a b. (a -> b) -> a -> b
$ (Char
'd'forall a. a -> [a] -> [a]
:forall a. Show a => a -> [Char]
show (a
nforall a. Num a => a -> a -> a
-a
1)))
papGen :: StgToJSConfig -> JStat
papGen :: StgToJSConfig -> JStat
papGen StgToJSConfig
cfg =
ClosureInfo -> JStat -> JStat
closure (Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo Ident
funcIdent CIRegs
CIRegsUnknown FastString
funcName CILayout
CILayoutVariable CIType
CIPap forall a. Monoid a => a
mempty)
(forall a. ToSat a => a -> JStat
jVar \JExpr
c JExpr
f JExpr
d JExpr
pr JExpr
or JExpr
r ->
[ JExpr
c JExpr -> JExpr -> JStat
|= JExpr -> JExpr
closureField1 JExpr
r1
, JExpr
d JExpr -> JExpr -> JStat
|= JExpr -> JExpr
closureField2 JExpr
r1
, JExpr
f JExpr -> JExpr -> JStat
|= JExpr -> JExpr
closureEntry JExpr
c
, JExpr
pr JExpr -> JExpr -> JStat
|= JExpr -> Maybe JExpr -> JExpr
funOrPapArity JExpr
c (forall a. a -> Maybe a
Just JExpr
f) JExpr -> JExpr -> JExpr
.>>. JExpr
8
, JExpr
or JExpr -> JExpr -> JStat
|= JExpr -> JExpr
papArity JExpr
r1 JExpr -> JExpr -> JExpr
.>>. JExpr
8
, JExpr
r JExpr -> JExpr -> JStat
|= JExpr
pr forall a. Num a => a -> a -> a
- JExpr
or
, forall a. ToJExpr a => StgToJSConfig -> JExpr -> a -> JStat
assertRts StgToJSConfig
cfg
(JExpr -> JExpr
isFun' JExpr
f JExpr -> JExpr -> JExpr
.||. JExpr -> JExpr
isPap' JExpr
f)
(FastString -> JExpr
jString FastString
"h$pap_gen: expected function or pap")
, StgToJSConfig -> JStat -> JStat
profStat StgToJSConfig
cfg (CostCentreStack -> JStat
enterCostCentreFun CostCentreStack
currentCCS)
, StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
cfg (FastString -> JExpr
jString FastString
"h$pap_gen: generic pap extra args moving: " forall a. Num a => a -> a -> a
+ JExpr
or)
, FastString -> [JExpr] -> JStat
appS FastString
"h$moveRegs2" [JExpr
or, JExpr
r]
, JExpr -> JExpr -> JStat
loadOwnArgs JExpr
d JExpr
r
, JExpr
r1 JExpr -> JExpr -> JStat
|= JExpr
c
, JExpr -> JStat
returnS JExpr
f
])
where
funcIdent :: Ident
funcIdent = FastString -> Ident
TxtI FastString
funcName
funcName :: FastString
funcName = FastString
"h$pap_gen"
loadOwnArgs :: JExpr -> JExpr -> JStat
loadOwnArgs JExpr
d JExpr
r =
let prop :: Int -> JExpr
prop Int
n = JExpr
d JExpr -> FastString -> JExpr
.^ (FastString
"d" forall a. Semigroup a => a -> a -> a
<> [Char] -> FastString
mkFastString (forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$ Int
nforall a. Num a => a -> a -> a
+Int
1))
loadOwnArg :: Int -> (JExpr, JStat)
loadOwnArg Int
n = (forall a. ToJExpr a => a -> JExpr
toJExpr Int
n, Int -> JExpr
jsReg (Int
nforall a. Num a => a -> a -> a
+Int
1) JExpr -> JExpr -> JStat
|= Int -> JExpr
prop Int
n)
in JExpr -> [(JExpr, JStat)] -> JStat -> JStat
SwitchStat JExpr
r (forall a b. (a -> b) -> [a] -> [b]
map Int -> (JExpr, JStat)
loadOwnArg [Int
127,Int
126..Int
1]) forall a. Monoid a => a
mempty
moveRegs2 :: JStat
moveRegs2 :: JStat
moveRegs2 = FastString -> Ident
TxtI FastString
"h$moveRegs2" Ident -> JExpr -> JStat
||= forall a. ToSat a => a -> JExpr
jLam JExpr -> JExpr -> JStat
moveSwitch
where
moveSwitch :: JExpr -> JExpr -> JStat
moveSwitch JExpr
n JExpr
m = JExpr -> [(JExpr, JStat)] -> JStat -> JStat
SwitchStat ((JExpr
n JExpr -> JExpr -> JExpr
.<<. JExpr
8) JExpr -> JExpr -> JExpr
.|. JExpr
m) [(JExpr, JStat)]
switchCases (JExpr -> JExpr -> JStat
defaultCase JExpr
n JExpr
m)
switchCases :: [(JExpr, JStat)]
switchCases = [Int -> Int -> (JExpr, JStat)
switchCase Int
n Int
m | Int
n <- [Int
1..Int
5], Int
m <- [Int
1..Int
4]]
switchCase :: Int -> Int -> (JExpr, JStat)
switchCase :: Int -> Int -> (JExpr, JStat)
switchCase Int
n Int
m = (forall a. ToJExpr a => a -> JExpr
toJExpr forall a b. (a -> b) -> a -> b
$
(Int
n forall a. Bits a => a -> Int -> a
`Bits.shiftL` Int
8) forall a. Bits a => a -> a -> a
Bits..|. Int
m
, forall a. Monoid a => [a] -> a
mconcat (forall a b. (a -> b) -> [a] -> [b]
map (Int -> Int -> JStat
`moveRegFast` Int
m) [Int
nforall a. Num a => a -> a -> a
+Int
1,Int
n..Int
2])
forall a. Semigroup a => a -> a -> a
<> Maybe JsLabel -> JStat
BreakStat forall a. Maybe a
Nothing )
moveRegFast :: Int -> Int -> JStat
moveRegFast Int
n Int
m = Int -> JExpr
jsReg (Int
nforall a. Num a => a -> a -> a
+Int
m) JExpr -> JExpr -> JStat
|= Int -> JExpr
jsReg Int
n
defaultCase :: JExpr -> JExpr -> JStat
defaultCase JExpr
n JExpr
m =
JExpr -> (JExpr -> JExpr) -> (JExpr -> JStat) -> JStat
loop JExpr
n (JExpr -> JExpr -> JExpr
.>.JExpr
0) (\JExpr
i -> FastString -> [JExpr] -> JStat
appS FastString
"h$setReg" [JExpr
iforall a. Num a => a -> a -> a
+JExpr
1forall a. Num a => a -> a -> a
+JExpr
m, FastString -> [JExpr] -> JExpr
app FastString
"h$getReg" [JExpr
iforall a. Num a => a -> a -> a
+JExpr
1]] forall a. Monoid a => a -> a -> a
`mappend` JExpr -> JStat
postDecrS JExpr
i)
initClosure :: StgToJSConfig -> JExpr -> JExpr -> JExpr -> JExpr
initClosure :: StgToJSConfig -> JExpr -> JExpr -> JExpr -> JExpr
initClosure StgToJSConfig
cfg JExpr
entry JExpr
values JExpr
ccs = FastString -> [JExpr] -> JExpr
app FastString
"h$init_closure"
[ Closure -> JExpr
newClosure forall a b. (a -> b) -> a -> b
$ Closure
{ clEntry :: JExpr
clEntry = JExpr
entry
, clField1 :: JExpr
clField1 = JExpr
null_
, clField2 :: JExpr
clField2 = JExpr
null_
, clMeta :: JExpr
clMeta = JExpr
0
, clCC :: Maybe JExpr
clCC = if StgToJSConfig -> Bool
csProf StgToJSConfig
cfg then forall a. a -> Maybe a
Just JExpr
ccs else forall a. Maybe a
Nothing
}
, JExpr
values
]
getIdFields :: Id -> G [TypedExpr]
getIdFields :: Id -> G [TypedExpr]
getIdFields Id
i = Id -> [JExpr] -> [TypedExpr]
assocIdExprs Id
i forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> G [JExpr]
varsForId Id
i
storeIdFields :: Id -> [TypedExpr] -> G JStat
storeIdFields :: Id -> [TypedExpr] -> G JStat
storeIdFields Id
i [TypedExpr]
dst = do
[TypedExpr]
fields <- Id -> G [TypedExpr]
getIdFields Id
i
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HasDebugCallStack => [TypedExpr] -> [TypedExpr] -> JStat
assignCoerce1 [TypedExpr]
dst [TypedExpr]
fields)