{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE ViewPatterns #-}
module GHC.StgToJS.Apply
( genApp
, rtsApply
)
where
import GHC.Prelude hiding ((.|.))
import GHC.JS.JStg.Syntax
import GHC.JS.JStg.Monad
import GHC.JS.Ident
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.Ids
import GHC.StgToJS.Monad
import GHC.StgToJS.Profiling
import GHC.StgToJS.Regs
import GHC.StgToJS.Rts.Types
import GHC.StgToJS.Stack
import GHC.StgToJS.Symbols
import GHC.StgToJS.Types
import GHC.StgToJS.Utils
import GHC.StgToJS.Linker.Utils (decodeModifiedUTF8)
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Types.CostCentre
import GHC.Types.RepType (mightBeFunTy)
import GHC.Types.Literal
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.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 -> JSM JStgStat
rtsApply :: StgToJSConfig -> JSM JStgStat
rtsApply StgToJSConfig
cfg = [JSM JStgStat] -> JSM JStgStat
forall a. Monoid a => [JSM a] -> JSM a
jBlock
[ [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat ([JStgStat] -> JStgStat)
-> StateT JEnv Identity [JStgStat] -> JSM JStgStat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ApplySpec -> JSM JStgStat)
-> [ApplySpec] -> StateT JEnv Identity [JStgStat]
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 (StgToJSConfig -> ApplySpec -> JSM JStgStat
specApply StgToJSConfig
cfg) [ApplySpec]
applySpec
, [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat ([JStgStat] -> JStgStat)
-> StateT JEnv Identity [JStgStat] -> JSM JStgStat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> JSM JStgStat) -> [Int] -> StateT JEnv Identity [JStgStat]
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 (StgToJSConfig -> Int -> JSM JStgStat
pap StgToJSConfig
cfg) [Int]
specPap
, JSM JStgStat
mkApplyArr
, StgToJSConfig -> JSM JStgStat
genericStackApply StgToJSConfig
cfg
, StgToJSConfig -> JSM JStgStat
genericFastApply StgToJSConfig
cfg
, StgToJSConfig -> JSM JStgStat
zeroApply StgToJSConfig
cfg
, StgToJSConfig -> JSM JStgStat
updates StgToJSConfig
cfg
, StgToJSConfig -> JSM JStgStat
papGen StgToJSConfig
cfg
, StgToJSConfig -> JSM JStgStat
selectors StgToJSConfig
cfg
, JSM JStgStat
moveRegs2
]
genApp
:: HasDebugCallStack
=> ExprCtx
-> Id
-> [StgArg]
-> G (JStgStat, ExprResult)
genApp :: HasDebugCallStack =>
ExprCtx -> Id -> [StgArg] -> G (JStgStat, ExprResult)
genApp ExprCtx
ctx Id
i [StgArg]
args
| [StgVarArg Id
v] <- [StgArg]
args
, Id -> Name
idName Id
i Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
unsafeUnpackJSStringUtf8ShShName
, [JStgExpr
top] <- (TypedExpr -> [JStgExpr]) -> [TypedExpr] -> [JStgExpr]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TypedExpr -> [JStgExpr]
typex_expr (ExprCtx -> [TypedExpr]
ctxTarget ExprCtx
ctx)
= (,ExprResult
ExprInline) (JStgStat -> (JStgStat, ExprResult))
-> ([JStgExpr] -> JStgStat) -> [JStgExpr] -> (JStgStat, ExprResult)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JStgExpr -> JStgExpr -> JStgStat
(|=) JStgExpr
top (JStgExpr -> JStgStat)
-> ([JStgExpr] -> JStgExpr) -> [JStgExpr] -> JStgStat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FastString -> [JStgExpr] -> JStgExpr
app FastString
hdDecodeUtf8Z ([JStgExpr] -> (JStgStat, ExprResult))
-> StateT GenState IO [JStgExpr] -> G (JStgStat, ExprResult)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> StateT GenState IO [JStgExpr]
varsForId Id
v
| [StgLitArg (LitString ByteString
bs)] <- [StgArg]
args
, Just FastString
d <- ByteString -> Maybe FastString
decodeModifiedUTF8 ByteString
bs
, Id -> Name
idName Id
i Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
unsafeUnpackJSStringUtf8ShShName
, [JStgExpr
top] <- (TypedExpr -> [JStgExpr]) -> [TypedExpr] -> [JStgExpr]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TypedExpr -> [JStgExpr]
typex_expr (ExprCtx -> [TypedExpr]
ctxTarget ExprCtx
ctx)
= (JStgStat, ExprResult) -> G (JStgStat, ExprResult)
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((JStgStat, ExprResult) -> G (JStgStat, ExprResult))
-> (JStgStat -> (JStgStat, ExprResult))
-> JStgStat
-> G (JStgStat, ExprResult)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,ExprResult
ExprInline) (JStgStat -> G (JStgStat, ExprResult))
-> JStgStat -> G (JStgStat, ExprResult)
forall a b. (a -> b) -> a -> b
$ JStgExpr
top JStgExpr -> JStgExpr -> JStgStat
|= FastString -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr FastString
d
| [StgLitArg (LitString ByteString
bs), StgArg
x] <- [StgArg]
args
, Just FastString
d <- ByteString -> Maybe FastString
decodeModifiedUTF8 ByteString
bs
, Id -> Unique
forall a. Uniquable a => a -> Unique
getUnique Id
i Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
unpackCStringAppendIdKey
, [JStgExpr
top] <- (TypedExpr -> [JStgExpr]) -> [TypedExpr] -> [JStgExpr]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TypedExpr -> [JStgExpr]
typex_expr (ExprCtx -> [TypedExpr]
ctxTarget ExprCtx
ctx)
= do
prof <- StgToJSConfig -> Bool
csProf (StgToJSConfig -> Bool)
-> StateT GenState IO StgToJSConfig -> StateT GenState IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT GenState IO StgToJSConfig
getSettings
let profArg = if Bool
prof then [JStgExpr
jCafCCS] else []
a <- genArg x
return ( top |= app "h$appendToHsStringA" (toJExpr d : a ++ profArg)
, ExprInline
)
| [StgLitArg (LitString ByteString
bs), StgArg
x] <- [StgArg]
args
, Just FastString
d <- ByteString -> Maybe FastString
decodeModifiedUTF8 ByteString
bs
, Id -> Unique
forall a. Uniquable a => a -> Unique
getUnique Id
i Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
unpackCStringAppendUtf8IdKey
, [JStgExpr
top] <- (TypedExpr -> [JStgExpr]) -> [TypedExpr] -> [JStgExpr]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TypedExpr -> [JStgExpr]
typex_expr (ExprCtx -> [TypedExpr]
ctxTarget ExprCtx
ctx)
= do
prof <- StgToJSConfig -> Bool
csProf (StgToJSConfig -> Bool)
-> StateT GenState IO StgToJSConfig -> StateT GenState IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT GenState IO StgToJSConfig
getSettings
let profArg = if Bool
prof then [JStgExpr
jCafCCS] else []
a <- genArg x
return ( top |= app "h$appendToHsString" (toJExpr d : a ++ profArg)
, ExprInline
)
| Just Int
n <- ExprCtx -> Id -> Maybe Int
ctxLneBindingStackSize ExprCtx
ctx Id
i
= do
as' <- (StgArg -> StateT GenState IO [JStgExpr])
-> [StgArg] -> StateT GenState IO [JStgExpr]
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Traversable f) =>
(a -> m [b]) -> f a -> m [b]
concatMapM HasDebugCallStack => StgArg -> StateT GenState IO [JStgExpr]
StgArg -> StateT GenState IO [JStgExpr]
genArg [StgArg]
args
ei <- varForEntryId i
let ra = [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat ([JStgStat] -> JStgStat)
-> ([JStgStat] -> [JStgStat]) -> [JStgStat] -> JStgStat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [JStgStat] -> [JStgStat]
forall a. [a] -> [a]
reverse ([JStgStat] -> JStgStat) -> [JStgStat] -> JStgStat
forall a b. (a -> b) -> a -> b
$
(StgReg -> JStgExpr -> JStgStat)
-> [StgReg] -> [JStgExpr] -> [JStgStat]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\StgReg
r JStgExpr
a -> StgReg -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr StgReg
r JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
a) [StgReg
R1 ..] [JStgExpr]
as'
p <- pushLneFrame n ctx
a <- adjSp 1
return (ra <> p <> a <> returnS ei, ExprCont)
| [] <- [StgArg]
args
, Id -> Unique
forall a. Uniquable a => a -> Unique
getUnique Id
i Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
proxyHashKey
, [JStgExpr
top] <- (TypedExpr -> [JStgExpr]) -> [TypedExpr] -> [JStgExpr]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TypedExpr -> [JStgExpr]
typex_expr (ExprCtx -> [TypedExpr]
ctxTarget ExprCtx
ctx)
= (JStgStat, ExprResult) -> G (JStgStat, ExprResult)
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStgExpr
top JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
null_, ExprResult
ExprInline)
| [] <- [StgArg]
args
, Type -> Bool
isUnboxedTupleType (Id -> Type
idType Id
i) Bool -> Bool -> Bool
|| HasDebugCallStack => Type -> Bool
Type -> Bool
isStrictType (Id -> Type
idType Id
i)
= do
a <- Id -> [TypedExpr] -> G JStgStat
storeIdFields Id
i (ExprCtx -> [TypedExpr]
ctxTarget ExprCtx
ctx)
return (a, ExprInline)
| [] <- [StgArg]
args
, [JSRep
vt] <- HasDebugCallStack => Id -> [JSRep]
Id -> [JSRep]
idJSRep Id
i
, JSRep -> Bool
isUnboxable JSRep
vt
, Id -> Bool
ctxIsEvaluated Id
i
= do
let c :: JStgExpr
c = [JStgExpr] -> JStgExpr
forall a. HasCallStack => [a] -> a
head ((TypedExpr -> [JStgExpr]) -> [TypedExpr] -> [JStgExpr]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TypedExpr -> [JStgExpr]
typex_expr ([TypedExpr] -> [JStgExpr]) -> [TypedExpr] -> [JStgExpr]
forall a b. (a -> b) -> a -> b
$ ExprCtx -> [TypedExpr]
ctxTarget ExprCtx
ctx)
is <- Id -> StateT GenState IO [JStgExpr]
varsForId Id
i
case is of
[JStgExpr
i'] ->
(JStgStat, ExprResult) -> G (JStgStat, ExprResult)
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ( JStgExpr
c JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr -> JStgExpr -> JStgExpr -> JStgExpr
if_ (JStgExpr -> JStgExpr
isObject JStgExpr
i') (JStgExpr -> JStgExpr
closureField1 JStgExpr
i') JStgExpr
i'
, ExprResult
ExprInline
)
[JStgExpr]
_ -> [Char] -> G (JStgStat, ExprResult)
forall a. HasCallStack => [Char] -> a
panic [Char]
"genApp: invalid size"
| [] <- [StgArg]
args
, Id -> Bool
ctxIsEvaluated Id
i Bool -> Bool -> Bool
|| HasDebugCallStack => Type -> Bool
Type -> Bool
isStrictType (Id -> Type
idType Id
i)
= do
a <- Id -> [TypedExpr] -> G JStgStat
storeIdFields Id
i (ExprCtx -> [TypedExpr]
ctxTarget ExprCtx
ctx)
settings <- getSettings
let ww = case (TypedExpr -> [JStgExpr]) -> [TypedExpr] -> [JStgExpr]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TypedExpr -> [JStgExpr]
typex_expr (ExprCtx -> [TypedExpr]
ctxTarget ExprCtx
ctx) of
[JStgExpr
t] | StgToJSConfig -> Bool
csAssertRts StgToJSConfig
settings ->
JStgExpr -> JStgStat -> JStgStat -> JStgStat
ifS (JStgExpr -> JStgExpr
isObject JStgExpr
t JStgExpr -> JStgExpr -> JStgExpr
.&&. JStgExpr -> JStgExpr
isThunk JStgExpr
t)
(FastString -> [JStgExpr] -> JStgStat
appS FastString
throwStr [FastString -> JStgExpr
String FastString
"unexpected thunk"])
JStgStat
forall a. Monoid a => a
mempty
[JStgExpr]
_ -> JStgStat
forall a. Monoid a => a
mempty
return (a `mappend` ww, ExprInline)
| DataConWrapId DataCon
dc <- Id -> IdDetails
idDetails Id
i
, TyCon -> Bool
isNewTyCon (DataCon -> TyCon
dataConTyCon DataCon
dc)
= do
as <- (StgArg -> StateT GenState IO [JStgExpr])
-> [StgArg] -> StateT GenState IO [JStgExpr]
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Traversable f) =>
(a -> m [b]) -> f a -> m [b]
concatMapM HasDebugCallStack => StgArg -> StateT GenState IO [JStgExpr]
StgArg -> StateT GenState IO [JStgExpr]
genArg [StgArg]
args
case as of
[JStgExpr
ai] -> do
let t :: JStgExpr
t = [JStgExpr] -> JStgExpr
forall a. HasCallStack => [a] -> a
head ((TypedExpr -> [JStgExpr]) -> [TypedExpr] -> [JStgExpr]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TypedExpr -> [JStgExpr]
typex_expr (ExprCtx -> [TypedExpr]
ctxTarget ExprCtx
ctx))
a' :: Id
a' = case [StgArg]
args of
[StgVarArg Id
a'] -> Id
a'
[StgArg]
_ -> [Char] -> Id
forall a. HasCallStack => [Char] -> a
panic [Char]
"genApp: unexpected arg"
if Id -> Bool
isStrictId Id
a' Bool -> Bool -> Bool
|| Id -> Bool
ctxIsEvaluated Id
a'
then (JStgStat, ExprResult) -> G (JStgStat, ExprResult)
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStgExpr
t JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
ai, ExprResult
ExprInline)
else (JStgStat, ExprResult) -> G (JStgStat, ExprResult)
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStgExpr -> JStgStat
returnS (FastString -> [JStgExpr] -> JStgExpr
app (Ident -> FastString
identFS Ident
hdEntry) [JStgExpr
ai]), ExprResult
ExprCont)
[JStgExpr]
_ -> [Char] -> G (JStgStat, ExprResult)
forall a. HasCallStack => [Char] -> a
panic [Char]
"genApp: invalid size"
| [] <- [StgArg]
args
, Id -> Int
idFunRepArity Id
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
, Bool -> Bool
not (Type -> Bool
mightBeFunTy (Id -> Type
idType Id
i))
= do
enter_id <- HasDebugCallStack => Id -> StateT GenState IO [JStgExpr]
Id -> StateT GenState IO [JStgExpr]
genIdArg Id
i StateT GenState IO [JStgExpr]
-> ([JStgExpr] -> G JStgExpr) -> G JStgExpr
forall a b.
StateT GenState IO a
-> (a -> StateT GenState IO b) -> StateT GenState IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
\case
[JStgExpr
x] -> JStgExpr -> G JStgExpr
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return JStgExpr
x
[JStgExpr]
xs -> [Char] -> SDoc -> G JStgExpr
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"genApp: unexpected multi-var argument"
([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr ([JStgExpr] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [JStgExpr]
xs), Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
i])
return (returnS (app (identFS hdEntry) [enter_id]), ExprCont)
| Int
n <- [StgArg] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [StgArg]
args
, Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0
, Id -> Int
idFunRepArity Id
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n
, Bool -> Bool
not (Id -> Bool
isLocalId Id
i)
, Id -> Bool
isStrictId Id
i
= do
as' <- (StgArg -> StateT GenState IO [JStgExpr])
-> [StgArg] -> StateT GenState IO [JStgExpr]
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Traversable f) =>
(a -> m [b]) -> f a -> m [b]
concatMapM HasDebugCallStack => StgArg -> StateT GenState IO [JStgExpr]
StgArg -> StateT GenState IO [JStgExpr]
genArg [StgArg]
args
is <- assignAll jsRegsFromR1 <$> varsForId i
jmp <- jumpToII i as' is
return (jmp, ExprCont)
| Id -> Int
idFunRepArity Id
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< [StgArg] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [StgArg]
args
, Id -> Bool
isStrictId Id
i
, Id -> Int
idFunRepArity Id
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
= do
let ([StgArg]
reg,[StgArg]
over) = Int -> [StgArg] -> ([StgArg], [StgArg])
forall a. Int -> [a] -> ([a], [a])
splitAt (Id -> Int
idFunRepArity Id
i) [StgArg]
args
reg' <- (StgArg -> StateT GenState IO [JStgExpr])
-> [StgArg] -> StateT GenState IO [JStgExpr]
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Traversable f) =>
(a -> m [b]) -> f a -> m [b]
concatMapM HasDebugCallStack => StgArg -> StateT GenState IO [JStgExpr]
StgArg -> StateT GenState IO [JStgExpr]
genArg [StgArg]
reg
pc <- pushCont over
is <- assignAll jsRegsFromR1 <$> varsForId i
jmp <- jumpToII i reg' is
return (pc <> jmp, ExprCont)
| Bool
otherwise
= do
is <- [JStgExpr] -> [JStgExpr] -> JStgStat
assignAll [JStgExpr]
jsRegsFromR1 ([JStgExpr] -> JStgStat)
-> StateT GenState IO [JStgExpr] -> G JStgStat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> StateT GenState IO [JStgExpr]
varsForId Id
i
jmp <- jumpToFast args is
return (jmp, ExprCont)
jumpToII :: Id -> [JStgExpr] -> JStgStat -> G JStgStat
jumpToII :: Id -> [JStgExpr] -> JStgStat -> G JStgStat
jumpToII Id
i [JStgExpr]
vars JStgStat
load_app_in_r1
| Id -> Bool
isLocalId Id
i = do
ii <- Id -> G JStgExpr
varForId Id
i
return $ mconcat
[ assignAllReverseOrder jsRegsFromR2 vars
, load_app_in_r1
, returnS (closureInfo ii)
]
| Bool
otherwise = do
ei <- Id -> G JStgExpr
varForEntryId Id
i
return $ mconcat
[ assignAllReverseOrder jsRegsFromR2 vars
, load_app_in_r1
, returnS ei
]
jumpToFast :: HasDebugCallStack => [StgArg] -> JStgStat -> G JStgStat
jumpToFast :: HasDebugCallStack => [StgArg] -> JStgStat -> G JStgStat
jumpToFast [StgArg]
args JStgStat
load_app_in_r1 = do
vars <- (StgArg -> StateT GenState IO [JStgExpr])
-> [StgArg] -> StateT GenState IO [JStgExpr]
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Traversable f) =>
(a -> m [b]) -> f a -> m [b]
concatMapM HasDebugCallStack => StgArg -> StateT GenState IO [JStgExpr]
StgArg -> StateT GenState IO [JStgExpr]
genArg [StgArg]
args
let spec = ApplyConv -> [StgArg] -> [JStgExpr] -> ApplySpec
mkApplySpec ApplyConv
RegsConv [StgArg]
args [JStgExpr]
vars
ap_fun <- selectApply spec
pure $ mconcat
[ assignAllReverseOrder jsRegsFromR2 vars
, load_app_in_r1
, case ap_fun of
Right JStgExpr
fun -> JStgExpr -> JStgStat
returnS (JStgExpr -> [JStgExpr] -> JStgExpr
ApplExpr JStgExpr
fun [])
Left JStgExpr
fun -> JStgExpr -> JStgStat
returnS (JStgExpr -> [JStgExpr] -> JStgExpr
ApplExpr JStgExpr
fun [ApplySpec -> JStgExpr
specTagExpr ApplySpec
spec])
]
data ApplyConv
= RegsConv
| StackConv
deriving (Int -> ApplyConv -> ShowS
[ApplyConv] -> ShowS
ApplyConv -> [Char]
(Int -> ApplyConv -> ShowS)
-> (ApplyConv -> [Char])
-> ([ApplyConv] -> ShowS)
-> Show ApplyConv
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ApplyConv -> ShowS
showsPrec :: Int -> ApplyConv -> ShowS
$cshow :: ApplyConv -> [Char]
show :: ApplyConv -> [Char]
$cshowList :: [ApplyConv] -> ShowS
showList :: [ApplyConv] -> ShowS
Show,ApplyConv -> ApplyConv -> Bool
(ApplyConv -> ApplyConv -> Bool)
-> (ApplyConv -> ApplyConv -> Bool) -> Eq ApplyConv
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ApplyConv -> ApplyConv -> Bool
== :: ApplyConv -> ApplyConv -> Bool
$c/= :: ApplyConv -> ApplyConv -> Bool
/= :: ApplyConv -> ApplyConv -> Bool
Eq,Eq ApplyConv
Eq ApplyConv =>
(ApplyConv -> ApplyConv -> Ordering)
-> (ApplyConv -> ApplyConv -> Bool)
-> (ApplyConv -> ApplyConv -> Bool)
-> (ApplyConv -> ApplyConv -> Bool)
-> (ApplyConv -> ApplyConv -> Bool)
-> (ApplyConv -> ApplyConv -> ApplyConv)
-> (ApplyConv -> ApplyConv -> ApplyConv)
-> Ord 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
$ccompare :: ApplyConv -> ApplyConv -> Ordering
compare :: ApplyConv -> ApplyConv -> Ordering
$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
>= :: ApplyConv -> ApplyConv -> Bool
$cmax :: ApplyConv -> ApplyConv -> ApplyConv
max :: ApplyConv -> ApplyConv -> ApplyConv
$cmin :: ApplyConv -> ApplyConv -> ApplyConv
min :: ApplyConv -> ApplyConv -> ApplyConv
Ord)
genericApplyName :: ApplyConv -> FastString
genericApplyName :: ApplyConv -> FastString
genericApplyName = \case
ApplyConv
RegsConv -> Ident -> FastString
identFS Ident
hdApGenFastStr
ApplyConv
StackConv -> Ident -> FastString
identFS Ident
hdApGenStr
genericApplyExpr :: ApplyConv -> JStgExpr
genericApplyExpr :: ApplyConv -> JStgExpr
genericApplyExpr ApplyConv
conv = FastString -> JStgExpr
global (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 ([Char] -> FastString) -> [Char] -> FastString
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
forall a. Monoid a => [a] -> a
mconcat
[ [Char]
"h$ap_", Int -> [Char]
forall a. Show a => a -> [Char]
show Int
nargs
, [Char]
"_" , Int -> [Char]
forall a. Show a => a -> [Char]
show Int
nvars
, case ApplyConv
conv of
ApplyConv
RegsConv -> [Char]
"_fast"
ApplyConv
StackConv -> [Char]
""
]
specApplyExpr :: ApplySpec -> JStgExpr
specApplyExpr :: ApplySpec -> JStgExpr
specApplyExpr ApplySpec
spec = FastString -> JStgExpr
global (ApplySpec -> FastString
specApplyName ApplySpec
spec)
specApplyExprMaybe :: ApplySpec -> Maybe JStgExpr
specApplyExprMaybe :: ApplySpec -> Maybe JStgExpr
specApplyExprMaybe ApplySpec
spec =
if ApplySpec
spec ApplySpec -> [ApplySpec] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ApplySpec]
applySpec
then JStgExpr -> Maybe JStgExpr
forall a. a -> Maybe a
Just (ApplySpec -> JStgExpr
specApplyExpr ApplySpec
spec)
else Maybe JStgExpr
forall a. Maybe a
Nothing
mkApplySpec :: ApplyConv -> [StgArg] -> [JStgExpr] -> ApplySpec
mkApplySpec :: ApplyConv -> [StgArg] -> [JStgExpr] -> ApplySpec
mkApplySpec ApplyConv
conv [StgArg]
args [JStgExpr]
vars = ApplySpec
{ specConv :: ApplyConv
specConv = ApplyConv
conv
, specArgs :: Int
specArgs = [StgArg] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [StgArg]
args
, specVars :: Int
specVars = [JStgExpr] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [JStgExpr]
vars
}
selectApply
:: ApplySpec
-> G (Either JStgExpr JStgExpr)
selectApply :: ApplySpec -> G (Either JStgExpr JStgExpr)
selectApply ApplySpec
spec =
case ApplySpec -> Maybe JStgExpr
specApplyExprMaybe ApplySpec
spec of
Just JStgExpr
e -> Either JStgExpr JStgExpr -> G (Either JStgExpr JStgExpr)
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStgExpr -> Either JStgExpr JStgExpr
forall a b. b -> Either a b
Right JStgExpr
e)
Maybe JStgExpr
Nothing -> Either JStgExpr JStgExpr -> G (Either JStgExpr JStgExpr)
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStgExpr -> Either JStgExpr JStgExpr
forall a b. a -> Either a b
Left (ApplyConv -> JStgExpr
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]
(Int -> ApplySpec -> ShowS)
-> (ApplySpec -> [Char])
-> ([ApplySpec] -> ShowS)
-> Show ApplySpec
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ApplySpec -> ShowS
showsPrec :: Int -> ApplySpec -> ShowS
$cshow :: ApplySpec -> [Char]
show :: ApplySpec -> [Char]
$cshowList :: [ApplySpec] -> ShowS
showList :: [ApplySpec] -> ShowS
Show,ApplySpec -> ApplySpec -> Bool
(ApplySpec -> ApplySpec -> Bool)
-> (ApplySpec -> ApplySpec -> Bool) -> Eq ApplySpec
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ApplySpec -> ApplySpec -> Bool
== :: ApplySpec -> ApplySpec -> Bool
$c/= :: ApplySpec -> ApplySpec -> Bool
/= :: ApplySpec -> ApplySpec -> Bool
Eq,Eq ApplySpec
Eq ApplySpec =>
(ApplySpec -> ApplySpec -> Ordering)
-> (ApplySpec -> ApplySpec -> Bool)
-> (ApplySpec -> ApplySpec -> Bool)
-> (ApplySpec -> ApplySpec -> Bool)
-> (ApplySpec -> ApplySpec -> Bool)
-> (ApplySpec -> ApplySpec -> ApplySpec)
-> (ApplySpec -> ApplySpec -> ApplySpec)
-> Ord 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
$ccompare :: ApplySpec -> ApplySpec -> Ordering
compare :: ApplySpec -> ApplySpec -> Ordering
$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
>= :: ApplySpec -> ApplySpec -> Bool
$cmax :: ApplySpec -> ApplySpec -> ApplySpec
max :: ApplySpec -> ApplySpec -> ApplySpec
$cmin :: ApplySpec -> ApplySpec -> ApplySpec
min :: ApplySpec -> ApplySpec -> ApplySpec
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 <- [Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int
nargsInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)..(Int
nargsInt -> Int -> Int
forall a. Num a => a -> a -> a
*Int
2)]
]
specTag :: ApplySpec -> Int
specTag :: ApplySpec -> Int
specTag ApplySpec
spec = Int -> Int -> Int
forall a. Bits a => a -> Int -> a
Bits.shiftL (ApplySpec -> Int
specVars ApplySpec
spec) Int
8 Int -> Int -> Int
forall a. Bits a => a -> a -> a
Bits..|. ApplySpec -> Int
specArgs ApplySpec
spec
specTagExpr :: ApplySpec -> JStgExpr
specTagExpr :: ApplySpec -> JStgExpr
specTagExpr = Int -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr (Int -> JStgExpr) -> (ApplySpec -> Int) -> ApplySpec -> JStgExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ApplySpec -> Int
specTag
mkApplyArr :: JSM JStgStat
mkApplyArr :: JSM JStgStat
mkApplyArr =
do mk_ap_gens <- (JStgExpr -> JStgStat)
-> (JStgExpr -> JStgExpr)
-> (JStgExpr -> JStgStat)
-> (JStgExpr -> JStgStat)
-> JSM JStgStat
jFor (JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
zero_) (JStgExpr -> JStgExpr -> JStgExpr
.<. Integer -> JStgExpr
Int Integer
65536) JStgExpr -> JStgStat
preIncrS
\JStgExpr
j -> JStgExpr
hdApply JStgExpr -> JStgExpr -> JStgExpr
.! JStgExpr
j JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
hdApGen
mk_pap_gens <- jFor (|= zero_) (.<. Int 128) preIncrS
\JStgExpr
j -> JStgExpr
hdPaps JStgExpr -> JStgExpr -> JStgExpr
.! JStgExpr
j JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
hdPapGen
return $ mconcat
[ name hdApplyStr ||= toJExpr (JList [])
, name hdPapsStr ||= toJExpr (JList [])
, ApplStat (hdInitStatic .^ "push")
[ jLam' $
mconcat
[ mk_ap_gens
, mk_pap_gens
, mconcat (map assignSpec applySpec)
, mconcat (map assignPap specPap)
]
]
]
where
assignSpec :: ApplySpec -> JStgStat
assignSpec :: ApplySpec -> JStgStat
assignSpec ApplySpec
spec = case ApplySpec -> ApplyConv
specConv ApplySpec
spec of
ApplyConv
StackConv -> JStgExpr
hdApply JStgExpr -> JStgExpr -> JStgExpr
.! ApplySpec -> JStgExpr
specTagExpr ApplySpec
spec JStgExpr -> JStgExpr -> JStgStat
|= ApplySpec -> JStgExpr
specApplyExpr ApplySpec
spec
ApplyConv
RegsConv -> JStgStat
forall a. Monoid a => a
mempty
hdPap_ :: [Char]
hdPap_ = FastString -> [Char]
unpackFS FastString
hdPapStr_
assignPap :: Int -> JStgStat
assignPap :: Int -> JStgStat
assignPap Int
p = JStgExpr
hdPaps JStgExpr -> JStgExpr -> JStgExpr
.! Int -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr Int
p JStgExpr -> JStgExpr -> JStgStat
|= FastString -> JStgExpr
global ([Char] -> FastString
mkFastString ([Char]
hdPap_ [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
p))
pushCont :: HasDebugCallStack
=> [StgArg]
-> G JStgStat
pushCont :: HasDebugCallStack => [StgArg] -> G JStgStat
pushCont [StgArg]
args = do
vars <- (StgArg -> StateT GenState IO [JStgExpr])
-> [StgArg] -> StateT GenState IO [JStgExpr]
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Traversable f) =>
(a -> m [b]) -> f a -> m [b]
concatMapM HasDebugCallStack => StgArg -> StateT GenState IO [JStgExpr]
StgArg -> StateT GenState IO [JStgExpr]
genArg [StgArg]
args
let spec = ApplyConv -> [StgArg] -> [JStgExpr] -> ApplySpec
mkApplySpec ApplyConv
StackConv [StgArg]
args [JStgExpr]
vars
selectApply spec >>= \case
Right JStgExpr
app -> [JStgExpr] -> G JStgStat
push ([JStgExpr] -> G JStgStat) -> [JStgExpr] -> G JStgStat
forall a b. (a -> b) -> a -> b
$ [JStgExpr] -> [JStgExpr]
forall a. [a] -> [a]
reverse ([JStgExpr] -> [JStgExpr]) -> [JStgExpr] -> [JStgExpr]
forall a b. (a -> b) -> a -> b
$ JStgExpr
app JStgExpr -> [JStgExpr] -> [JStgExpr]
forall a. a -> [a] -> [a]
: [JStgExpr]
vars
Left JStgExpr
app -> [JStgExpr] -> G JStgStat
push ([JStgExpr] -> G JStgStat) -> [JStgExpr] -> G JStgStat
forall a b. (a -> b) -> a -> b
$ [JStgExpr] -> [JStgExpr]
forall a. [a] -> [a]
reverse ([JStgExpr] -> [JStgExpr]) -> [JStgExpr] -> [JStgExpr]
forall a b. (a -> b) -> a -> b
$ JStgExpr
app JStgExpr -> [JStgExpr] -> [JStgExpr]
forall a. a -> [a] -> [a]
: ApplySpec -> JStgExpr
specTagExpr ApplySpec
spec JStgExpr -> [JStgExpr] -> [JStgExpr]
forall a. a -> [a] -> [a]
: [JStgExpr]
vars
genericStackApply :: StgToJSConfig -> JSM JStgStat
genericStackApply :: StgToJSConfig -> JSM JStgStat
genericStackApply StgToJSConfig
cfg = ClosureInfo -> JSM JStgStat -> JSM JStgStat
closure ClosureInfo
info JSM JStgStat
body
where
body :: JSM JStgStat
body = (JStgExpr -> JSM JStgStat) -> JSM JStgStat
forall t.
(JVarMagic t, ToJExpr t) =>
(t -> JSM JStgStat) -> JSM JStgStat
jVar ((JStgExpr -> JSM JStgStat) -> JSM JStgStat)
-> (JStgExpr -> JSM JStgStat) -> JSM JStgStat
forall a b. (a -> b) -> a -> b
$ \JStgExpr
cf ->
do fun <- JStgExpr -> JStgExpr -> JSM JStgStat
fun_case JStgExpr
cf (JStgExpr -> JStgExpr
infoFunArity JStgExpr
cf)
pap <- fun_case cf (papArity r1)
return $
mconcat $
[ traceRts cfg (jString $ identFS hdApGenStr)
, cf |= closureInfo r1
, SwitchStat (infoClosureType cf)
[ (toJExpr Thunk , thunk_case cfg cf)
, (toJExpr Fun , fun)
, (toJExpr Pap , pap)
, (toJExpr Blackhole, blackhole_case cfg)
]
(default_case cf)
]
info :: ClosureInfo
info = ClosureInfo
{ ciVar :: Ident
ciVar = Ident
hdApGenStr
, ciRegs :: CIRegs
ciRegs = Int -> [JSRep] -> CIRegs
CIRegs Int
0 [JSRep
PtrV]
, ciName :: FastString
ciName = Ident -> FastString
identFS Ident
hdApGenStr
, ciLayout :: CILayout
ciLayout = CILayout
CILayoutVariable
, ciType :: CIType
ciType = CIType
CIStackFrame
, ciStatic :: CIStatic
ciStatic = CIStatic
forall a. Monoid a => a
mempty
}
default_case :: JStgExpr -> JStgStat
default_case JStgExpr
cf = FastString -> [JStgExpr] -> JStgStat
appS FastString
throwStr [FastString -> JStgExpr
jString FastString
"h$ap_gen: unexpected closure type "
JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
+ (JStgExpr -> JStgExpr
infoClosureType JStgExpr
cf)]
thunk_case :: StgToJSConfig -> JStgExpr -> JStgStat
thunk_case StgToJSConfig
cfg JStgExpr
cf = [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat
[ StgToJSConfig -> JStgStat -> JStgStat
profStat StgToJSConfig
cfg JStgStat
pushRestoreCCS
, JStgExpr -> JStgStat
returnS JStgExpr
cf
]
blackhole_case :: StgToJSConfig -> JStgStat
blackhole_case StgToJSConfig
cfg = [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat
[ StgToJSConfig -> [JStgExpr] -> JStgStat
push' StgToJSConfig
cfg [JStgExpr
r1, JStgExpr
hdReturn]
, JStgExpr -> JStgStat
returnS (FastString -> [JStgExpr] -> JStgExpr
app FastString
hdBlockOnBlackHoleStr [JStgExpr
r1])
]
fun_case :: JStgExpr -> JStgExpr -> JSM JStgStat
fun_case JStgExpr
c JStgExpr
arity = ((JStgExpr, JStgExpr, JStgExpr, JStgExpr, JStgExpr, JStgExpr,
JStgExpr, JStgExpr, JStgExpr)
-> JSM JStgStat)
-> JSM JStgStat
forall args.
JSArgument args =>
(args -> JSM JStgStat) -> JSM JStgStat
jVars \(JStgExpr
tag, JStgExpr
needed_args, JStgExpr
needed_regs, JStgExpr
given_args, JStgExpr
given_regs, JStgExpr
newTag, JStgExpr
newAp, JStgExpr
p, JStgExpr
dat) ->
do build_pap_payload <- JStgExpr
-> (JStgExpr -> JStgExpr)
-> (JStgExpr -> JSM JStgStat)
-> JSM JStgStat
loop JStgExpr
0 (JStgExpr -> JStgExpr -> JStgExpr
.<. JStgExpr
given_regs)
\JStgExpr
i -> JStgStat -> JSM JStgStat
forall a. a -> StateT JEnv Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStgStat -> JSM JStgStat) -> JStgStat -> JSM JStgStat
forall a b. (a -> b) -> a -> b
$ [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat [ (JStgExpr
dat JStgExpr -> FastString -> JStgExpr
.^ FastString
"push") JStgExpr -> [JStgExpr] -> JStgStat
`ApplStat` [JStgExpr
stack JStgExpr -> JStgExpr -> JStgExpr
.! (JStgExpr
sp JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
- JStgExpr
i JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
- JStgExpr
2)]
, JStgExpr -> JStgStat
postIncrS JStgExpr
i
]
load_reg_values <- loop 0 (.<. needed_regs)
\JStgExpr
i -> JStgStat -> JSM JStgStat
forall a. a -> StateT JEnv Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStgStat -> JSM JStgStat) -> JStgStat -> JSM JStgStat
forall a b. (a -> b) -> a -> b
$
[JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat [ StgToJSConfig -> JStgExpr -> JStgStat
traceRts StgToJSConfig
cfg (FastString -> JStgExpr
jString FastString
"h$ap_gen: loading register: " JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
+ JStgExpr
i)
, FastString -> [JStgExpr] -> JStgStat
appS FastString
hdSetRegStr [ JStgExpr
iJStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
+JStgExpr
2 , JStgExpr
stack JStgExpr -> JStgExpr -> JStgExpr
.! (JStgExpr
spJStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
-JStgExpr
2JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
-JStgExpr
i)]
, JStgExpr -> JStgStat
postIncrS JStgExpr
i
]
set_reg_values <- loop 0 (.<. given_regs)
\JStgExpr
i -> JStgStat -> JSM JStgStat
forall a. a -> StateT JEnv Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStgStat -> JSM JStgStat) -> JStgStat -> JSM JStgStat
forall a b. (a -> b) -> a -> b
$
[JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat [ FastString -> [JStgExpr] -> JStgStat
appS FastString
hdSetRegStr [ JStgExpr
iJStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
+JStgExpr
2, JStgExpr
stack JStgExpr -> JStgExpr -> JStgExpr
.! (JStgExpr
spJStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
-JStgExpr
2JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
-JStgExpr
i)]
, JStgExpr -> JStgStat
postIncrS JStgExpr
i
]
return $
mconcat $ [ tag |= stack .! (sp - 1)
, given_args |= mask8 tag
, given_regs |= tag .>>. 8
, needed_args |= mask8 arity
, needed_regs |= arity .>>. 8
, traceRts cfg (jString "h$ap_gen: args: " + given_args
+ jString " regs: " + given_regs)
, ifBlockS (given_args .===. needed_args)
[ traceRts cfg (jString "h$ap_gen: exact")
, set_reg_values
, sp |= sp - given_regs - 2
, returnS c
]
[ ifBlockS (given_args .>. needed_args)
[ traceRts cfg (jString "h$ap_gen: oversat: arity: " + needed_args
+ jString " regs: " + needed_regs)
, load_reg_values
, newTag |= ((given_regs-needed_regs).<<.8) .|. (given_args - needed_args)
, newAp |= hdApply .! newTag
, traceRts cfg (jString "h$ap_gen: next: " + (newAp .^ "n"))
, ifS (newAp .===. hdApGen )
((sp |= sp - needed_regs) <> (stack .! (sp - 1) |= newTag))
(sp |= sp - needed_regs - 1)
, stack .! sp |= newAp
, profStat cfg pushRestoreCCS
, returnS c
]
[ traceRts cfg (jString "h$ap_gen: undersat")
, p |= hdPaps .! given_regs
, newTag |= ((needed_regs-given_regs) .<<. 8) .|. (needed_args-given_args)
, dat |= toJExpr [r1, newTag]
, build_pap_payload
, sp |= sp - given_regs - 2
, r1 |= initClosure cfg p dat jCurrentCCS
, returnStack
]
]
]
genericFastApply :: StgToJSConfig -> JSM JStgStat
genericFastApply :: StgToJSConfig -> JSM JStgStat
genericFastApply StgToJSConfig
s =
Ident -> (Solo JStgExpr -> JSM JStgStat) -> JSM JStgStat
forall args.
JSArgument args =>
Ident -> (args -> JSM JStgStat) -> JSM JStgStat
jFunction (FastString -> Ident
name FastString
"h$ap_gen_fast")
\(MkSolo JStgExpr
tag) -> (JStgExpr -> JSM JStgStat) -> JSM JStgStat
forall t.
(JVarMagic t, ToJExpr t) =>
(t -> JSM JStgStat) -> JSM JStgStat
jVar ((JStgExpr -> JSM JStgStat) -> JSM JStgStat)
-> (JStgExpr -> JSM JStgStat) -> JSM JStgStat
forall a b. (a -> b) -> a -> b
$ \JStgExpr
c ->
do push_stk_app <- JStgExpr -> JStgExpr -> JSM JStgStat
pushStackApply JStgExpr
c JStgExpr
tag
fast_fun <- jVar \JStgExpr
farity ->
do fast_fun <- JStgExpr -> JStgExpr -> JStgExpr -> JSM JStgStat
funCase JStgExpr
c JStgExpr
tag JStgExpr
farity
return $ mconcat $
[ farity |= infoFunArity c
, traceRts s (jString "h$ap_gen_fast: fun " + farity)
, fast_fun]
fast_pap <- jVar \JStgExpr
parity ->
do fast_pap <- JStgExpr -> JStgExpr -> JStgExpr -> JSM JStgStat
funCase JStgExpr
c JStgExpr
tag JStgExpr
parity
return $ mconcat $
[ parity |= papArity r1
, traceRts s (jString "h$ap_gen_fast: pap " + parity)
, fast_pap
]
return $ mconcat $
[traceRts s (jString "h$ap_gen_fast: " + tag)
, c |= closureInfo r1
, SwitchStat (infoClosureType c)
[ (toJExpr Thunk, traceRts s (jString "h$ap_gen_fast: thunk")
<> push_stk_app
<> returnS c)
, (toJExpr Fun, fast_fun)
, (toJExpr Pap, fast_pap)
, (toJExpr Con, traceRts s (jString "h$ap_gen_fast: con")
<> jwhenS (tag .!=. 0)
(appS throwStr [jString "h$ap_gen_fast: invalid apply"])
<> returnS c)
, (toJExpr Blackhole, traceRts s (jString "h$ap_gen_fast: blackhole")
<> push_stk_app
<> push' s [r1, hdReturn]
<> returnS (app hdBlockOnBlackHoleStr [r1]))
] $ appS throwStr [jString "h$ap_gen_fast: unexpected closure type: " + infoClosureType c]
]
where
pushStackApply :: JStgExpr -> JStgExpr -> JSM JStgStat
pushStackApply :: JStgExpr -> JStgExpr -> JSM JStgStat
pushStackApply JStgExpr
_c JStgExpr
tag =
(JStgExpr -> JSM JStgStat) -> JSM JStgStat
forall t.
(JVarMagic t, ToJExpr t) =>
(t -> JSM JStgStat) -> JSM JStgStat
jVar \JStgExpr
ap ->
do push_all_regs <- JStgExpr -> JSM JStgStat
pushAllRegs JStgExpr
tag
return $ mconcat $
[ push_all_regs
, ap |= hdApply .! tag
, ifS (ap .===. hdApGen)
((sp |= sp + 2) <> (stack .! (sp-1) |= tag))
(sp |= sp + 1)
, stack .! sp |= ap
, profStat s pushRestoreCCS
]
funCase :: JStgExpr -> JStgExpr -> JStgExpr -> JSM JStgStat
funCase :: JStgExpr -> JStgExpr -> JStgExpr -> JSM JStgStat
funCase JStgExpr
c JStgExpr
tag JStgExpr
arity = ((JStgExpr, JStgExpr, JStgExpr, JStgExpr, JStgExpr, JStgExpr,
JStgExpr, JStgExpr)
-> JSM JStgStat)
-> JSM JStgStat
forall args.
JSArgument args =>
(args -> JSM JStgStat) -> JSM JStgStat
jVars (((JStgExpr, JStgExpr, JStgExpr, JStgExpr, JStgExpr, JStgExpr,
JStgExpr, JStgExpr)
-> JSM JStgStat)
-> JSM JStgStat)
-> ((JStgExpr, JStgExpr, JStgExpr, JStgExpr, JStgExpr, JStgExpr,
JStgExpr, JStgExpr)
-> JSM JStgStat)
-> JSM JStgStat
forall a b. (a -> b) -> a -> b
$
\(JStgExpr
ar, JStgExpr
myAr, JStgExpr
myRegs, JStgExpr
regsStart, JStgExpr
newTag, JStgExpr
newAp, JStgExpr
dat, JStgExpr
p) ->
do get_regs <- JStgExpr
-> (JStgExpr -> JStgExpr)
-> (JStgExpr -> JSM JStgStat)
-> JSM JStgStat
loop JStgExpr
0 (JStgExpr -> JStgExpr -> JStgExpr
.<. JStgExpr
myRegs) ((JStgExpr -> JSM JStgStat) -> JSM JStgStat)
-> (JStgExpr -> JSM JStgStat) -> JSM JStgStat
forall a b. (a -> b) -> a -> b
$
\JStgExpr
i -> JStgStat -> JSM JStgStat
forall a. a -> StateT JEnv Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStgStat -> JSM JStgStat) -> JStgStat -> JSM JStgStat
forall a b. (a -> b) -> a -> b
$
(JStgExpr
dat JStgExpr -> FastString -> JStgExpr
.^ FastString
"push") JStgExpr -> [JStgExpr] -> JStgStat
`ApplStat` [FastString -> [JStgExpr] -> JStgExpr
app FastString
hdGetRegStr [JStgExpr
iJStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
+JStgExpr
2]] JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> JStgExpr -> JStgStat
postIncrS JStgExpr
i
push_args <- pushArgs regsStart myRegs
return $ mconcat $
[ ar |= mask8 arity
, myAr |= mask8 tag
, myRegs |= tag .>>. 8
, traceRts s (jString "h$ap_gen_fast: args: " + myAr
+ jString " regs: " + myRegs)
, ifS (myAr .===. ar)
(traceRts s (jString "h$ap_gen_fast: exact") <> returnS c)
(ifBlockS (myAr .>. ar)
[ traceRts s (jString "h$ap_gen_fast: oversat " + sp)
, regsStart |= (arity .>>. 8) + 1
, sp |= sp + myRegs - regsStart + 1
, traceRts s (jString "h$ap_gen_fast: oversat " + sp)
, push_args
, newTag |= ((myRegs-( arity.>>.8)).<<.8).|.myAr-ar
, newAp |= hdApply .! newTag
, ifS (newAp .===. hdApGen)
((sp |= sp + 2) <> (stack .! (sp - 1) |= newTag))
(sp |= sp + 1)
, stack .! sp |= newAp
, profStat s pushRestoreCCS
, returnS c
]
[traceRts s (jString "h$ap_gen_fast: undersat: " + myRegs + jString " " + tag)
, jwhenS (tag .!=. 0) $ mconcat
[ p |= hdPaps .! myRegs
, dat |= toJExpr [r1, ((arity .>>. 8)-myRegs)*256+ar-myAr]
, get_regs
, r1 |= initClosure s p dat jCurrentCCS
]
, returnStack
])
]
pushAllRegs :: JStgExpr -> JSM JStgStat
pushAllRegs :: JStgExpr -> JSM JStgStat
pushAllRegs JStgExpr
tag =
(JStgExpr -> JSM JStgStat) -> JSM JStgStat
forall t.
(JVarMagic t, ToJExpr t) =>
(t -> JSM JStgStat) -> JSM JStgStat
jVar \JStgExpr
regs ->
JStgStat -> JSM JStgStat
forall a. a -> StateT JEnv Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStgStat -> JSM JStgStat) -> JStgStat -> JSM JStgStat
forall a b. (a -> b) -> a -> b
$ [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat ([JStgStat] -> JStgStat) -> [JStgStat] -> JStgStat
forall a b. (a -> b) -> a -> b
$
[ JStgExpr
regs JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
tag JStgExpr -> JStgExpr -> JStgExpr
.>>. JStgExpr
8
, JStgExpr
sp JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
sp JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
+ JStgExpr
regs
, JStgExpr -> [(JStgExpr, JStgStat)] -> JStgStat -> JStgStat
SwitchStat JStgExpr
regs ((Int -> (JStgExpr, JStgStat)) -> [Int] -> [(JStgExpr, JStgStat)]
forall a b. (a -> b) -> [a] -> [b]
map Int -> (JStgExpr, JStgStat)
pushReg [Int
65,Int
64..Int
2]) JStgStat
forall a. Monoid a => a
mempty
]
where
pushReg :: Int -> (JStgExpr, JStgStat)
pushReg :: Int -> (JStgExpr, JStgStat)
pushReg Int
r = (Int -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr (Int
rInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1), JStgExpr
stack JStgExpr -> JStgExpr -> JStgExpr
.! (JStgExpr
sp JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
- Int -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr (Int
r Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2)) JStgExpr -> JStgExpr -> JStgStat
|= Int -> JStgExpr
jsReg Int
r)
pushArgs :: JStgExpr -> JStgExpr -> JSM JStgStat
pushArgs :: JStgExpr -> JStgExpr -> JSM JStgStat
pushArgs JStgExpr
start JStgExpr
end =
JStgExpr
-> (JStgExpr -> JStgExpr)
-> (JStgExpr -> JSM JStgStat)
-> JSM JStgStat
loop JStgExpr
end (JStgExpr -> JStgExpr -> JStgExpr
.>=.JStgExpr
start)
\JStgExpr
i -> JStgStat -> JSM JStgStat
forall a. a -> StateT JEnv Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStgStat -> JSM JStgStat) -> JStgStat -> JSM JStgStat
forall a b. (a -> b) -> a -> b
$
StgToJSConfig -> JStgExpr -> JStgStat
traceRts StgToJSConfig
s (FastString -> JStgExpr
jString FastString
"pushing register: " JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
+ JStgExpr
i)
JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> (JStgExpr
stack JStgExpr -> JStgExpr -> JStgExpr
.! (JStgExpr
sp JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
+ JStgExpr
start JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
- JStgExpr
i) JStgExpr -> JStgExpr -> JStgStat
|= FastString -> [JStgExpr] -> JStgExpr
app FastString
hdGetRegStr [JStgExpr
iJStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
+JStgExpr
1])
JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> JStgExpr -> JStgStat
postDecrS JStgExpr
i
specApply :: StgToJSConfig -> ApplySpec -> JSM JStgStat
specApply :: StgToJSConfig -> ApplySpec -> JSM JStgStat
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 -> JSM JStgStat
fastApply StgToJSConfig
cfg FastString
fun_name Int
nargs Int
nvars
ApplyConv
StackConv -> StgToJSConfig -> FastString -> Int -> Int -> JSM JStgStat
stackApply StgToJSConfig
cfg FastString
fun_name Int
nargs Int
nvars
stackApply
:: StgToJSConfig
-> FastString
-> Int
-> Int
-> JSM JStgStat
stackApply :: StgToJSConfig -> FastString -> Int -> Int -> JSM JStgStat
stackApply StgToJSConfig
s FastString
fun_name Int
nargs Int
nvars =
if Int
nargs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
&& Int
nvars Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
then ClosureInfo -> JSM JStgStat -> JSM JStgStat
closure ClosureInfo
info0 JSM JStgStat
body0
else ClosureInfo -> JSM JStgStat -> JSM JStgStat
closure ClosureInfo
info JSM JStgStat
body
where
info :: ClosureInfo
info = ClosureInfo
{ ciVar :: Ident
ciVar = FastString -> Ident
name FastString
fun_name
, ciRegs :: CIRegs
ciRegs = Int -> [JSRep] -> CIRegs
CIRegs Int
0 [JSRep
PtrV]
, ciName :: FastString
ciName = FastString
fun_name
, ciLayout :: CILayout
ciLayout = Int -> CILayout
CILayoutUnknown Int
nvars
, ciType :: CIType
ciType = CIType
CIStackFrame
, ciStatic :: CIStatic
ciStatic = CIStatic
forall a. Monoid a => a
mempty
}
info0 :: ClosureInfo
info0 = ClosureInfo
{ ciVar :: Ident
ciVar = FastString -> Ident
name FastString
fun_name
, ciRegs :: CIRegs
ciRegs = Int -> [JSRep] -> CIRegs
CIRegs Int
0 [JSRep
PtrV]
, ciName :: FastString
ciName = FastString
fun_name
, ciLayout :: CILayout
ciLayout = Int -> [JSRep] -> CILayout
CILayoutFixed Int
0 []
, ciType :: CIType
ciType = CIType
CIStackFrame
, ciStatic :: CIStatic
ciStatic = CIStatic
forall a. Monoid a => a
mempty
}
body0 :: JSM JStgStat
body0 = (Int -> JStgStat
adjSpN' Int
1 JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<>) (JStgStat -> JStgStat) -> JSM JStgStat -> JSM JStgStat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StgToJSConfig -> JStgExpr -> JSM JStgStat
enter StgToJSConfig
s JStgExpr
r1
body :: JSM JStgStat
body = (JStgExpr -> JSM JStgStat) -> JSM JStgStat
forall t.
(JVarMagic t, ToJExpr t) =>
(t -> JSM JStgStat) -> JSM JStgStat
jVar ((JStgExpr -> JSM JStgStat) -> JSM JStgStat)
-> (JStgExpr -> JSM JStgStat) -> JSM JStgStat
forall a b. (a -> b) -> a -> b
$ \JStgExpr
c ->
do fun_case <- JStgExpr -> JSM JStgStat
funCase JStgExpr
c
pap_case <- papCase c
return $ mconcat
[ c |= closureInfo r1
, traceRts s (toJExpr fun_name
+ jString " "
+ (c .^ "n")
+ jString " sp: " + sp
+ jString " a: " + (c .^ "a"))
, SwitchStat (infoClosureType c)
[ (toJExpr Thunk, traceRts s (toJExpr $ fun_name <> ": thunk") <> profStat s pushRestoreCCS <> returnS c)
, (toJExpr Fun, traceRts s (toJExpr $ fun_name <> ": fun") <> fun_case)
, (toJExpr Pap, traceRts s (toJExpr $ fun_name <> ": pap") <> pap_case)
, (toJExpr Blackhole, push' s [r1, hdReturn] <> returnS (app hdBlockOnBlackHoleStr [r1]))
] (appS throwStr [toJExpr ("panic: " <> fun_name <> ", unexpected closure type: ") + (infoClosureType c)])
]
funExact :: JStgExpr -> JStgStat
funExact JStgExpr
c = Int -> [JStgExpr] -> JStgStat
popSkip Int
1 ([JStgExpr] -> [JStgExpr]
forall a. [a] -> [a]
reverse ([JStgExpr] -> [JStgExpr]) -> [JStgExpr] -> [JStgExpr]
forall a b. (a -> b) -> a -> b
$ Int -> [JStgExpr] -> [JStgExpr]
forall a. Int -> [a] -> [a]
take Int
nvars [JStgExpr]
jsRegsFromR2) JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> JStgExpr -> JStgStat
returnS JStgExpr
c
stackArgs :: [JStgExpr]
stackArgs = (Int -> JStgExpr) -> [Int] -> [JStgExpr]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
x -> JStgExpr
stack JStgExpr -> JStgExpr -> JStgExpr
.! (JStgExpr
sp JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
- Int -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr Int
x)) [Int
1..Int
nvars]
papCase :: JStgExpr -> JSM JStgStat
papCase :: JStgExpr -> JSM JStgStat
papCase JStgExpr
c = ((JStgExpr, JStgExpr, JStgExpr) -> JSM JStgStat) -> JSM JStgStat
forall args.
JSArgument args =>
(args -> JSM JStgStat) -> JSM JStgStat
jVars \(JStgExpr
expr, JStgExpr
arity0, JStgExpr
arity) ->
do oversat_case <- JStgExpr -> JStgExpr -> JStgExpr -> JSM JStgStat
oversatCase JStgExpr
c JStgExpr
arity0 JStgExpr
arity
return $ mconcat $
case expr of
ValExpr (JVar Ident
pap) -> [ JStgExpr
arity0 JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr -> JStgExpr
papArity JStgExpr
r1
, JStgExpr
arity JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr -> JStgExpr
mask8 JStgExpr
arity0
, StgToJSConfig -> JStgExpr -> JStgStat
traceRts StgToJSConfig
s (FastString -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr (FastString
fun_name FastString -> FastString -> FastString
forall a. Semigroup a => a -> a -> a
<> FastString
": found pap, arity: ") JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
+ JStgExpr
arity)
, JStgExpr -> JStgStat -> JStgStat -> JStgStat
ifS (Int -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr Int
nargs JStgExpr -> JStgExpr -> JStgExpr
.===. JStgExpr
arity)
(StgToJSConfig -> JStgExpr -> JStgStat
traceRts StgToJSConfig
s (FastString -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr (FastString
fun_name FastString -> FastString -> FastString
forall a. Semigroup a => a -> a -> a
<> FastString
": exact")) JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> JStgExpr -> JStgStat
funExact JStgExpr
c)
(JStgExpr -> JStgStat -> JStgStat -> JStgStat
ifS (Int -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr Int
nargs JStgExpr -> JStgExpr -> JStgExpr
.>. JStgExpr
arity)
(StgToJSConfig -> JStgExpr -> JStgStat
traceRts StgToJSConfig
s (FastString -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr (FastString
fun_name FastString -> FastString -> FastString
forall a. Semigroup a => a -> a -> a
<> FastString
": oversat")) JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> JStgStat
oversat_case)
(StgToJSConfig -> JStgExpr -> JStgStat
traceRts StgToJSConfig
s (FastString -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr (FastString
fun_name FastString -> FastString -> FastString
forall a. Semigroup a => a -> a -> a
<> FastString
": undersat"))
JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> StgToJSConfig
-> Ident -> JStgExpr -> JStgExpr -> [JStgExpr] -> JStgStat
mkPap StgToJSConfig
s Ident
pap JStgExpr
r1 (Int -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr Int
nargs) [JStgExpr]
stackArgs
JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> (JStgExpr
sp JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
sp JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
- Int -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr (Int
nvars Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1))
JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> (JStgExpr
r1 JStgExpr -> JStgExpr -> JStgStat
|= Ident -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr Ident
pap)
JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> JStgStat
returnStack))
]
JStgExpr
_ -> [JStgStat]
forall a. Monoid a => a
mempty
funCase :: JStgExpr -> JSM JStgStat
funCase :: JStgExpr -> JSM JStgStat
funCase JStgExpr
c = ((JStgExpr, JStgExpr, JStgExpr) -> JSM JStgStat) -> JSM JStgStat
forall args.
JSArgument args =>
(args -> JSM JStgStat) -> JSM JStgStat
jVars \(JStgExpr
expr, JStgExpr
ar0, JStgExpr
ar) ->
do oversat_case <- JStgExpr -> JStgExpr -> JStgExpr -> JSM JStgStat
oversatCase JStgExpr
c JStgExpr
ar0 JStgExpr
ar
return $ mconcat $
case expr of
ValExpr (JVar Ident
pap) -> [ JStgExpr
ar0 JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr -> JStgExpr
infoFunArity JStgExpr
c
, JStgExpr
ar JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr -> JStgExpr
mask8 JStgExpr
ar0
, JStgExpr -> JStgStat -> JStgStat -> JStgStat
ifS (Int -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr Int
nargs JStgExpr -> JStgExpr -> JStgExpr
.===. JStgExpr
ar)
(StgToJSConfig -> JStgExpr -> JStgStat
traceRts StgToJSConfig
s (FastString -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr (FastString
fun_name FastString -> FastString -> FastString
forall a. Semigroup a => a -> a -> a
<> FastString
": exact")) JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> JStgExpr -> JStgStat
funExact JStgExpr
c)
(JStgExpr -> JStgStat -> JStgStat -> JStgStat
ifS (Int -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr Int
nargs JStgExpr -> JStgExpr -> JStgExpr
.>. JStgExpr
ar)
(StgToJSConfig -> JStgExpr -> JStgStat
traceRts StgToJSConfig
s (FastString -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr (FastString
fun_name FastString -> FastString -> FastString
forall a. Semigroup a => a -> a -> a
<> FastString
": oversat"))
JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> JStgStat
oversat_case)
(StgToJSConfig -> JStgExpr -> JStgStat
traceRts StgToJSConfig
s (FastString -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr (FastString
fun_name FastString -> FastString -> FastString
forall a. Semigroup a => a -> a -> a
<> FastString
": undersat"))
JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> StgToJSConfig
-> Ident -> JStgExpr -> JStgExpr -> [JStgExpr] -> JStgStat
mkPap StgToJSConfig
s Ident
pap (StgReg -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr StgReg
R1) (Int -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr Int
nargs) [JStgExpr]
stackArgs
JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> (JStgExpr
sp JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
sp JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
- Int -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr (Int
nvarsInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1))
JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> (JStgExpr
r1 JStgExpr -> JStgExpr -> JStgStat
|= Ident -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr Ident
pap)
JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> JStgStat
returnStack))
]
JStgExpr
_ -> [JStgStat]
forall a. Monoid a => a
mempty
oversatCase :: JStgExpr
-> JStgExpr
-> JStgExpr
-> JSM JStgStat
oversatCase :: JStgExpr -> JStgExpr -> JStgExpr -> JSM JStgStat
oversatCase JStgExpr
c JStgExpr
arity JStgExpr
arity0 =
((JStgExpr, JStgExpr) -> JSM JStgStat) -> JSM JStgStat
forall args.
JSArgument args =>
(args -> JSM JStgStat) -> JSM JStgStat
jVars \(JStgExpr
rs, JStgExpr
newAp) ->
JStgStat -> JSM JStgStat
forall a. a -> StateT JEnv Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStgStat -> JSM JStgStat) -> JStgStat -> JSM JStgStat
forall a b. (a -> b) -> a -> b
$ [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat ([JStgStat] -> JStgStat) -> [JStgStat] -> JStgStat
forall a b. (a -> b) -> a -> b
$
[ JStgExpr
rs JStgExpr -> JStgExpr -> JStgStat
|= (JStgExpr
arity JStgExpr -> JStgExpr -> JStgExpr
.>>. JStgExpr
8)
, JStgExpr -> JStgStat
loadRegs JStgExpr
rs
, JStgExpr
sp JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
sp JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
- JStgExpr
rs
, JStgExpr
newAp JStgExpr -> JStgExpr -> JStgStat
|= (JStgExpr
hdApply JStgExpr -> JStgExpr -> JStgExpr
.! ((Int -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr Int
nargsJStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
-JStgExpr
arity0)JStgExpr -> JStgExpr -> JStgExpr
.|.((Int -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr Int
nvarsJStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
-JStgExpr
rs)JStgExpr -> JStgExpr -> JStgExpr
.<<.JStgExpr
8)))
, JStgExpr
stack JStgExpr -> JStgExpr -> JStgExpr
.! JStgExpr
sp JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
newAp
, StgToJSConfig -> JStgStat -> JStgStat
profStat StgToJSConfig
s JStgStat
pushRestoreCCS
, StgToJSConfig -> JStgExpr -> JStgStat
traceRts StgToJSConfig
s (FastString -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr (FastString
fun_name FastString -> FastString -> FastString
forall a. Semigroup a => a -> a -> a
<> FastString
": new stack frame: ") JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
+ (JStgExpr
newAp JStgExpr -> FastString -> JStgExpr
.^ FastString
"n"))
, JStgExpr -> JStgStat
returnS JStgExpr
c
]
where
loadRegs :: JStgExpr -> JStgStat
loadRegs JStgExpr
rs = JStgExpr -> [(JStgExpr, JStgStat)] -> JStgStat -> JStgStat
SwitchStat JStgExpr
rs [(JStgExpr, JStgStat)]
switchAlts JStgStat
forall a. Monoid a => a
mempty
where
switchAlts :: [(JStgExpr, JStgStat)]
switchAlts = (Int -> (JStgExpr, JStgStat)) -> [Int] -> [(JStgExpr, JStgStat)]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
x -> (Int -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr Int
x, Int -> JStgExpr
jsReg (Int
xInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
stack JStgExpr -> JStgExpr -> JStgExpr
.! (JStgExpr
sp JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
- Int -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr Int
x))) [Int
nvars,Int
nvarsInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1..Int
1]
fastApply :: StgToJSConfig -> FastString -> Int -> Int -> JSM JStgStat
fastApply :: StgToJSConfig -> FastString -> Int -> Int -> JSM JStgStat
fastApply StgToJSConfig
s FastString
fun_name Int
nargs Int
nvars = if Int
nargs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
&& Int
nvars Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
then Ident -> JSM JStgStat -> JSM JStgStat
jFunction' Ident
func JSM JStgStat
ap_fast
else Ident -> JSM JStgStat -> JSM JStgStat
jFunction' Ident
func JSM JStgStat
body
where
func :: Ident
func = FastString -> Ident
name FastString
fun_name
ap_fast :: JSM JStgStat
ap_fast :: JSM JStgStat
ap_fast = StgToJSConfig -> JStgExpr -> JSM JStgStat
enter StgToJSConfig
s JStgExpr
r1
regArgs :: [JStgExpr]
regArgs = Int -> [JStgExpr] -> [JStgExpr]
forall a. Int -> [a] -> [a]
take Int
nvars [JStgExpr]
jsRegsFromR2
mkAp :: Int -> Int -> [JStgExpr]
mkAp :: Int -> Int -> [JStgExpr]
mkAp Int
n' Int
r' = [ ApplySpec -> JStgExpr
specApplyExpr (ApplyConv -> Int -> Int -> ApplySpec
ApplySpec ApplyConv
StackConv Int
n' Int
r') ]
body :: JSM JStgStat
body = ((JStgExpr, JStgExpr, JStgExpr) -> JSM JStgStat) -> JSM JStgStat
forall args.
JSArgument args =>
(args -> JSM JStgStat) -> JSM JStgStat
jVars (((JStgExpr, JStgExpr, JStgExpr) -> JSM JStgStat) -> JSM JStgStat)
-> ((JStgExpr, JStgExpr, JStgExpr) -> JSM JStgStat) -> JSM JStgStat
forall a b. (a -> b) -> a -> b
$ \(JStgExpr
c, JStgExpr
farity, JStgExpr
arity) ->
do fun_case_fun <- JStgExpr -> JStgExpr -> JSM JStgStat
funCase JStgExpr
c JStgExpr
farity
fun_case_pap <- funCase c arity
return $ mconcat $
[ c |= closureInfo r1
, traceRts s (toJExpr (fun_name <> ": sp ") + sp)
, SwitchStat (infoClosureType c)
[(toJExpr Fun, traceRts s (toJExpr (fun_name <> ": ")
+ clName c
+ jString " (arity: " + (c .^ "a") + jString ")")
<> (farity |= infoFunArity c)
<> fun_case_fun)
,(toJExpr Pap, traceRts s (toJExpr (fun_name <> ": pap")) <> (arity |= papArity r1) <> fun_case_pap)
,(toJExpr Thunk, traceRts s (toJExpr (fun_name <> ": thunk")) <> push' s (reverse regArgs ++ mkAp nargs nvars) <> profStat s pushRestoreCCS <> returnS c)
,(toJExpr Blackhole, traceRts s (toJExpr (fun_name <> ": blackhole")) <> push' s (reverse regArgs ++ mkAp nargs nvars) <> push' s [r1, global "h$return"] <> returnS (app "h$blockOnBlackhole" [r1]))]
(appS throwStr [toJExpr (fun_name <> ": unexpected closure type: ") + infoClosureType c])
]
funCase :: JStgExpr -> JStgExpr -> JSM JStgStat
funCase :: JStgExpr -> JStgExpr -> JSM JStgStat
funCase JStgExpr
c JStgExpr
arity = ((JStgExpr, JStgExpr) -> JSM JStgStat) -> JSM JStgStat
forall args.
JSArgument args =>
(args -> JSM JStgStat) -> JSM JStgStat
jVars \(JStgExpr
arg, JStgExpr
ar) ->
do oversat_case <- JStgExpr -> JStgExpr -> JSM JStgStat
oversatCase JStgExpr
c JStgExpr
arity
return $ mconcat $
case arg of
ValExpr (JVar Ident
pap) -> [ JStgExpr
ar JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr -> JStgExpr
mask8 JStgExpr
arity
, JStgExpr -> JStgStat -> JStgStat -> JStgStat
ifS (Int -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr Int
nargs JStgExpr -> JStgExpr -> JStgExpr
.===. JStgExpr
ar)
(StgToJSConfig -> JStgExpr -> JStgStat
traceRts StgToJSConfig
s (FastString -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr (FastString
fun_name FastString -> FastString -> FastString
forall a. Semigroup a => a -> a -> a
<> FastString
": exact")) JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> JStgExpr -> JStgStat
returnS JStgExpr
c)
(JStgExpr -> JStgStat -> JStgStat -> JStgStat
ifS (Int -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr Int
nargs JStgExpr -> JStgExpr -> JStgExpr
.>. JStgExpr
ar)
(StgToJSConfig -> JStgExpr -> JStgStat
traceRts StgToJSConfig
s (FastString -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr (FastString
fun_name FastString -> FastString -> FastString
forall a. Semigroup a => a -> a -> a
<> FastString
": oversat")) JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> JStgStat
oversat_case)
(StgToJSConfig -> JStgExpr -> JStgStat
traceRts StgToJSConfig
s (FastString -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr (FastString
fun_name FastString -> FastString -> FastString
forall a. Semigroup a => a -> a -> a
<> FastString
": undersat"))
JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> StgToJSConfig
-> Ident -> JStgExpr -> JStgExpr -> [JStgExpr] -> JStgStat
mkPap StgToJSConfig
s Ident
pap JStgExpr
r1 (Int -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr Int
nargs) [JStgExpr]
regArgs
JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> (JStgExpr
r1 JStgExpr -> JStgExpr -> JStgStat
|= Ident -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr Ident
pap)
JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> JStgStat
returnStack))
]
JStgExpr
_ -> [JStgStat]
forall a. Monoid a => a
mempty
oversatCase :: JStgExpr -> JStgExpr -> JSM JStgStat
oversatCase :: JStgExpr -> JStgExpr -> JSM JStgStat
oversatCase JStgExpr
c JStgExpr
arity =
((JStgExpr, JStgExpr) -> JSM JStgStat) -> JSM JStgStat
forall args.
JSArgument args =>
(args -> JSM JStgStat) -> JSM JStgStat
jVars \(JStgExpr
rs, JStgExpr
rsRemain) ->
JStgStat -> JSM JStgStat
forall a. a -> StateT JEnv Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStgStat -> JSM JStgStat) -> JStgStat -> JSM JStgStat
forall a b. (a -> b) -> a -> b
$ [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat ([JStgStat] -> JStgStat) -> [JStgStat] -> JStgStat
forall a b. (a -> b) -> a -> b
$
[ JStgExpr
rs JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
arity JStgExpr -> JStgExpr -> JStgExpr
.>>. JStgExpr
8
, JStgExpr
rsRemain JStgExpr -> JStgExpr -> JStgStat
|= Int -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr Int
nvars JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
- JStgExpr
rs
, StgToJSConfig -> JStgExpr -> JStgStat
traceRts StgToJSConfig
s (FastString -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr
(FastString
fun_name FastString -> FastString -> FastString
forall a. Semigroup a => a -> a -> a
<> FastString
" regs oversat ")
JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
+ JStgExpr
rs
JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
+ FastString -> JStgExpr
jString FastString
" remain: "
JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
+ JStgExpr
rsRemain)
, JStgExpr -> JStgStat
saveRegs JStgExpr
rs
, JStgExpr
sp JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
sp JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
+ JStgExpr
rsRemain JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
+ JStgExpr
1
, JStgExpr
stack JStgExpr -> JStgExpr -> JStgExpr
.! JStgExpr
sp JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
hdApply JStgExpr -> JStgExpr -> JStgExpr
.! ((JStgExpr
rsRemainJStgExpr -> JStgExpr -> JStgExpr
.<<.JStgExpr
8)JStgExpr -> JStgExpr -> JStgExpr
.|. (Int -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr Int
nargs JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
- JStgExpr -> JStgExpr
mask8 JStgExpr
arity))
, StgToJSConfig -> JStgStat -> JStgStat
profStat StgToJSConfig
s JStgStat
pushRestoreCCS
, JStgExpr -> JStgStat
returnS JStgExpr
c
]
where
saveRegs :: JStgExpr -> JStgStat
saveRegs JStgExpr
n = JStgExpr -> [(JStgExpr, JStgStat)] -> JStgStat -> JStgStat
SwitchStat JStgExpr
n [(JStgExpr, JStgStat)]
switchAlts JStgStat
forall a. Monoid a => a
mempty
where
switchAlts :: [(JStgExpr, JStgStat)]
switchAlts = (Int -> (JStgExpr, JStgStat)) -> [Int] -> [(JStgExpr, JStgStat)]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
x -> (Int -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr Int
x, JStgExpr
stack JStgExpr -> JStgExpr -> JStgExpr
.! (JStgExpr
sp JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
+ Int -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr (Int
nvarsInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
x)) JStgExpr -> JStgExpr -> JStgStat
|= Int -> JStgExpr
jsReg (Int
xInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
2))) [Int
0..Int
nvarsInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]
zeroApply :: StgToJSConfig -> JSM JStgStat
zeroApply :: StgToJSConfig -> JSM JStgStat
zeroApply StgToJSConfig
s = Ident -> (Solo JStgExpr -> JSM JStgStat) -> JSM JStgStat
forall args.
JSArgument args =>
Ident -> (args -> JSM JStgStat) -> JSM JStgStat
jFunction Ident
hdEntry
((Solo JStgExpr -> JSM JStgStat) -> JSM JStgStat)
-> (Solo JStgExpr -> JSM JStgStat) -> JSM JStgStat
forall a b. (a -> b) -> a -> b
$ \(MkSolo JStgExpr
c) -> (JStgStat -> JStgStat) -> JSM JStgStat -> JSM JStgStat
forall a b.
(a -> b) -> StateT JEnv Identity a -> StateT JEnv Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((JStgExpr
r1 JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
c) JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<>) (JSM JStgStat -> JSM JStgStat) -> JSM JStgStat -> JSM JStgStat
forall a b. (a -> b) -> a -> b
$ StgToJSConfig -> JStgExpr -> JSM JStgStat
enter StgToJSConfig
s JStgExpr
c
enter :: StgToJSConfig -> JStgExpr -> JSM JStgStat
enter :: StgToJSConfig -> JStgExpr -> JSM JStgStat
enter StgToJSConfig
s JStgExpr
ex = (JStgExpr -> JSM JStgStat) -> JSM JStgStat
forall t.
(JVarMagic t, ToJExpr t) =>
(t -> JSM JStgStat) -> JSM JStgStat
jVar \JStgExpr
c ->
JStgStat -> JSM JStgStat
forall a. a -> StateT JEnv Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStgStat -> JSM JStgStat) -> JStgStat -> JSM JStgStat
forall a b. (a -> b) -> a -> b
$ [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat ([JStgStat] -> JStgStat) -> [JStgStat] -> JStgStat
forall a b. (a -> b) -> a -> b
$
[ JStgExpr -> JStgStat -> JStgStat
jwhenS (FastString -> [JStgExpr] -> JStgExpr
app FastString
typeof [JStgExpr
ex] JStgExpr -> JStgExpr -> JStgExpr
.!==. JStgExpr
jTyObject) JStgStat
returnStack
, JStgExpr
c JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr -> JStgExpr
closureInfo JStgExpr
ex
, JStgExpr -> JStgStat -> JStgStat
jwhenS (JStgExpr
c JStgExpr -> JStgExpr -> JStgExpr
.===. JStgExpr
hdUnboxEntry) ((JStgExpr
r1 JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr -> JStgExpr
closureField1 JStgExpr
ex) JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> JStgStat
returnStack)
, JStgExpr -> [(JStgExpr, JStgStat)] -> JStgStat -> JStgStat
SwitchStat (JStgExpr -> JStgExpr
infoClosureType JStgExpr
c)
[ (ClosureType -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr ClosureType
Con, JStgStat
forall a. Monoid a => a
mempty)
, (ClosureType -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr ClosureType
Fun, JStgStat
forall a. Monoid a => a
mempty)
, (ClosureType -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr ClosureType
Pap, JStgStat
returnStack)
, (ClosureType -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr ClosureType
Blackhole, StgToJSConfig -> [JStgExpr] -> JStgStat
push' StgToJSConfig
s [JStgExpr
hdAp00, JStgExpr
ex, JStgExpr
hdReturn]
JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> JStgExpr -> JStgStat
returnS (FastString -> [JStgExpr] -> JStgExpr
app FastString
hdBlockOnBlackHoleStr [JStgExpr
ex]))
] (JStgExpr -> JStgStat
returnS JStgExpr
c)
]
updates :: StgToJSConfig -> JSM JStgStat
updates :: StgToJSConfig -> JSM JStgStat
updates StgToJSConfig
s = do
upd_frm <- JSM JStgStat
update_frame
upd_frm_lne <- update_frame_lne
return $ BlockStat [upd_frm, upd_frm_lne]
where
unbox_closure :: JStgExpr -> Closure
unbox_closure JStgExpr
f1 = Closure { clInfo :: JStgExpr
clInfo = JStgExpr
hdUnboxEntry
, clField1 :: JStgExpr
clField1 = JStgExpr
f1
, clField2 :: JStgExpr
clField2 = JStgExpr
null_
, clMeta :: JStgExpr
clMeta = JStgExpr
0
, clCC :: Maybe JStgExpr
clCC = Maybe JStgExpr
forall a. Maybe a
Nothing
}
upd_loop' :: JStgExpr -> JStgExpr -> JStgExpr -> JSM JStgStat
upd_loop' JStgExpr
ss' JStgExpr
si' JStgExpr
sir' = JStgExpr
-> (JStgExpr -> JStgExpr)
-> (JStgExpr -> JSM JStgStat)
-> JSM JStgStat
loop JStgExpr
zero_ (JStgExpr -> JStgExpr -> JStgExpr
.<. JStgExpr
ss' JStgExpr -> FastString -> JStgExpr
.^ FastString
"length")
((JStgExpr -> JSM JStgStat) -> JSM JStgStat)
-> (JStgExpr -> JSM JStgStat) -> JSM JStgStat
forall a b. (a -> b) -> a -> b
$ \JStgExpr
i -> JStgStat -> JSM JStgStat
forall a. a -> StateT JEnv Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStgStat -> JSM JStgStat) -> JStgStat -> JSM JStgStat
forall a b. (a -> b) -> a -> b
$ [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat
[ JStgExpr
si' JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
ss' JStgExpr -> JStgExpr -> JStgExpr
.! JStgExpr
i
, JStgExpr
sir' JStgExpr -> JStgExpr -> JStgStat
|= (JStgExpr -> JStgExpr
closureField2 JStgExpr
si') JStgExpr -> [JStgExpr] -> JStgExpr
`ApplExpr` [JStgExpr
r1]
, JStgExpr -> JStgStat -> JStgStat -> JStgStat
ifS (FastString -> [JStgExpr] -> JStgExpr
app FastString
"typeof" [JStgExpr
sir'] JStgExpr -> JStgExpr -> JStgExpr
.===. JStgExpr
jTyObject)
(CopyCC -> JStgExpr -> JStgExpr -> JStgStat
copyClosure CopyCC
DontCopyCC JStgExpr
si' JStgExpr
sir')
(JStgExpr -> Closure -> JStgStat
assignClosure JStgExpr
si' (Closure -> JStgStat) -> Closure -> JStgStat
forall a b. (a -> b) -> a -> b
$ JStgExpr -> Closure
unbox_closure JStgExpr
sir')
, JStgExpr -> JStgStat
postIncrS JStgExpr
i
]
update_frame :: JSM JStgStat
update_frame = ClosureInfo -> JSM JStgStat -> JSM JStgStat
closure
(ClosureInfo
{ ciVar :: Ident
ciVar = Ident
hdUpdFrameStr
, ciRegs :: CIRegs
ciRegs = Int -> [JSRep] -> CIRegs
CIRegs Int
0 [JSRep
PtrV]
, ciName :: FastString
ciName = Ident -> FastString
identFS Ident
hdUpdFrameStr
, ciLayout :: CILayout
ciLayout = Int -> [JSRep] -> CILayout
CILayoutFixed Int
1 [JSRep
PtrV]
, ciType :: CIType
ciType = CIType
CIStackFrame
, ciStatic :: CIStatic
ciStatic = CIStatic
forall a. Monoid a => a
mempty
})
(JSM JStgStat -> JSM JStgStat) -> JSM JStgStat -> JSM JStgStat
forall a b. (a -> b) -> a -> b
$ ((JStgExpr, JStgExpr, JStgExpr, JStgExpr, JStgExpr)
-> JSM JStgStat)
-> JSM JStgStat
forall args.
JSArgument args =>
(args -> JSM JStgStat) -> JSM JStgStat
jVars \(JStgExpr
updatee, JStgExpr
waiters, JStgExpr
ss, JStgExpr
si, JStgExpr
sir) ->
do upd_loop <- JStgExpr -> JStgExpr -> JStgExpr -> JSM JStgStat
upd_loop' JStgExpr
ss JStgExpr
si JStgExpr
sir
wake_thread_loop <- loop zero_ (.<. waiters .^ "length")
\JStgExpr
i -> JStgStat -> JSM JStgStat
forall a. a -> StateT JEnv Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStgStat -> JSM JStgStat) -> JStgStat -> JSM JStgStat
forall a b. (a -> b) -> a -> b
$
FastString -> [JStgExpr] -> JStgStat
appS FastString
hdWakeupThread [JStgExpr
waiters JStgExpr -> JStgExpr -> JStgExpr
.! JStgExpr
i]
JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> JStgExpr -> JStgStat
postIncrS JStgExpr
i
let updateCC JStgExpr
updatee = JStgExpr -> JStgExpr
closureCC JStgExpr
updatee JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
jCurrentCCS
return $ mconcat $
[ updatee |= stack .! (sp - 1)
, traceRts s (jString "h$upd_frame updatee alloc: " + updatee .^ "alloc")
,
waiters |= closureField2 updatee
, jwhenS (waiters .!==. null_) wake_thread_loop
,
jwhenS ((app typeof [closureMeta updatee] .===. jTyObject) .&&. (closureMeta updatee .^ "sel"))
((ss |= closureMeta updatee .^ "sel")
<> upd_loop)
,
ifS (app typeof [r1] .===. jTyObject)
(mconcat [ traceRts s (jString "$upd_frame: boxed: " + ((closureInfo r1) .^ "n"))
, copyClosure DontCopyCC updatee r1
])
(assignClosure updatee (unbox_closure r1))
, profStat s (updateCC updatee)
, adjSpN' 2
, traceRts s (jString "h$upd_frame: updating: "
+ updatee
+ jString " -> "
+ r1)
, returnStack
]
update_frame_lne :: JSM JStgStat
update_frame_lne = ClosureInfo -> JSM JStgStat -> JSM JStgStat
closure
(ClosureInfo
{ ciVar :: Ident
ciVar = FastString -> Ident
name (FastString -> Ident) -> FastString -> Ident
forall a b. (a -> b) -> a -> b
$ [Char] -> FastString
fsLit [Char]
"h$upd_frame_lne"
, ciRegs :: CIRegs
ciRegs = Int -> [JSRep] -> CIRegs
CIRegs Int
0 [JSRep
PtrV]
, ciName :: FastString
ciName = FastString
"h$upd_frame_lne"
, ciLayout :: CILayout
ciLayout = Int -> [JSRep] -> CILayout
CILayoutFixed Int
1 [JSRep
PtrV]
, ciType :: CIType
ciType = CIType
CIStackFrame
, ciStatic :: CIStatic
ciStatic = CIStatic
forall a. Monoid a => a
mempty
})
(JSM JStgStat -> JSM JStgStat) -> JSM JStgStat -> JSM JStgStat
forall a b. (a -> b) -> a -> b
$ (JStgExpr -> JSM JStgStat) -> JSM JStgStat
forall t.
(JVarMagic t, ToJExpr t) =>
(t -> JSM JStgStat) -> JSM JStgStat
jVar \JStgExpr
updateePos ->
JStgStat -> JSM JStgStat
forall a. a -> StateT JEnv Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStgStat -> JSM JStgStat) -> JStgStat -> JSM JStgStat
forall a b. (a -> b) -> a -> b
$ [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat ([JStgStat] -> JStgStat) -> [JStgStat] -> JStgStat
forall a b. (a -> b) -> a -> b
$
[ JStgExpr
updateePos JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
stack JStgExpr -> JStgExpr -> JStgExpr
.! (JStgExpr
sp JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
- JStgExpr
1)
, JStgExpr
stack JStgExpr -> JStgExpr -> JStgExpr
.! JStgExpr
updateePos JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
r1
, Int -> JStgStat
adjSpN' Int
2
, StgToJSConfig -> JStgExpr -> JStgStat
traceRts StgToJSConfig
s (FastString -> JStgExpr
jString FastString
"h$upd_frame_lne: updating: "
JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
+ JStgExpr
updateePos
JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
+ FastString -> JStgExpr
jString FastString
" -> "
JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
+ JStgExpr
r1)
, JStgStat
returnStack
]
selectors :: StgToJSConfig -> JSM JStgStat
selectors :: StgToJSConfig -> JSM JStgStat
selectors StgToJSConfig
s =
do
sel_one <- FastString -> (JStgExpr -> JStgExpr) -> JSM JStgStat
mkSel FastString
"1" JStgExpr -> JStgExpr
closureField1
sel_twoA <- mkSel "2a" closureField2
sel_twoB <- mkSel "2b" (closureField1 . closureField2)
rest <- mconcat <$> mapM mkSelN [3..16]
return $
sel_one <> sel_twoA <> sel_twoB <> rest
where
mkSelN :: Int -> JSM JStgStat
mkSelN :: Int -> JSM JStgStat
mkSelN Int
x = FastString -> (JStgExpr -> JStgExpr) -> JSM JStgStat
mkSel ([Char] -> FastString
mkFastString ([Char] -> FastString) -> [Char] -> FastString
forall a b. (a -> b) -> a -> b
$ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
x)
(\JStgExpr
e -> JStgExpr -> Ident -> JStgExpr
SelExpr (JStgExpr -> JStgExpr
closureField2 (JStgExpr -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr JStgExpr
e))
(FastString -> Ident
name (FastString -> Ident) -> FastString -> Ident
forall a b. (a -> b) -> a -> b
$ [Char] -> FastString
mkFastString ([Char]
"d" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (Int
xInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1))))
mkSel :: FastString -> (JStgExpr -> JStgExpr) -> JSM JStgStat
mkSel :: FastString -> (JStgExpr -> JStgExpr) -> JSM JStgStat
mkSel FastString
name_ JStgExpr -> JStgExpr
sel = [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat ([JStgStat] -> JStgStat)
-> StateT JEnv Identity [JStgStat] -> JSM JStgStat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [JSM JStgStat] -> StateT JEnv Identity [JStgStat]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence
[Ident -> (Solo JStgExpr -> JSM JStgStat) -> JSM JStgStat
forall args.
JSArgument args =>
Ident -> (args -> JSM JStgStat) -> JSM JStgStat
jFunction (FastString -> Ident
name FastString
createName) ((Solo JStgExpr -> JSM JStgStat) -> JSM JStgStat)
-> (Solo JStgExpr -> JSM JStgStat) -> JSM JStgStat
forall a b. (a -> b) -> a -> b
$
\(MkSolo JStgExpr
r) -> JStgStat -> JSM JStgStat
forall a. a -> StateT JEnv Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStgStat -> JSM JStgStat) -> JStgStat -> JSM JStgStat
forall a b. (a -> b) -> a -> b
$ [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat
[ StgToJSConfig -> JStgExpr -> JStgStat
traceRts StgToJSConfig
s (FastString -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr (FastString
"selector create: " FastString -> FastString -> FastString
forall a. Semigroup a => a -> a -> a
<> FastString
name_ FastString -> FastString -> FastString
forall a. Semigroup a => a -> a -> a
<> FastString
" for ") JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
+ (JStgExpr
r JStgExpr -> FastString -> JStgExpr
.^ FastString
"alloc"))
, JStgExpr -> JStgStat -> JStgStat -> JStgStat
ifS (JStgExpr -> JStgExpr
isThunk JStgExpr
r JStgExpr -> JStgExpr -> JStgExpr
.||. JStgExpr -> JStgExpr
isBlackhole JStgExpr
r)
(JStgExpr -> JStgStat
returnS (FastString -> [JStgExpr] -> JStgExpr
app FastString
"h$mkSelThunk" [JStgExpr
r, JVal -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr (FastString -> JVal
v FastString
entryName), JVal -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr (FastString -> JVal
v FastString
resName)]))
(JStgExpr -> JStgStat
returnS (JStgExpr -> JStgExpr
sel JStgExpr
r))
]
, Ident -> (Solo JStgExpr -> JSM JStgStat) -> JSM JStgStat
forall args.
JSArgument args =>
Ident -> (args -> JSM JStgStat) -> JSM JStgStat
jFunction (FastString -> Ident
name FastString
resName) ((Solo JStgExpr -> JSM JStgStat) -> JSM JStgStat)
-> (Solo JStgExpr -> JSM JStgStat) -> JSM JStgStat
forall a b. (a -> b) -> a -> b
$
\(MkSolo JStgExpr
r) -> JStgStat -> JSM JStgStat
forall a. a -> StateT JEnv Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStgStat -> JSM JStgStat) -> JStgStat -> JSM JStgStat
forall a b. (a -> b) -> a -> b
$ [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat
[ StgToJSConfig -> JStgExpr -> JStgStat
traceRts StgToJSConfig
s (FastString -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr (FastString
"selector result: " FastString -> FastString -> FastString
forall a. Semigroup a => a -> a -> a
<> FastString
name_ FastString -> FastString -> FastString
forall a. Semigroup a => a -> a -> a
<> FastString
" for ") JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
+ (JStgExpr
r JStgExpr -> FastString -> JStgExpr
.^ FastString
"alloc"))
, JStgExpr -> JStgStat
returnS (JStgExpr -> JStgExpr
sel JStgExpr
r)
]
, ClosureInfo -> JSM JStgStat -> JSM JStgStat
closure
(ClosureInfo
{ ciVar :: Ident
ciVar = FastString -> Ident
name FastString
entryName
, ciRegs :: CIRegs
ciRegs = Int -> [JSRep] -> CIRegs
CIRegs Int
0 [JSRep
PtrV]
, ciName :: FastString
ciName = FastString
"select " FastString -> FastString -> FastString
forall a. Semigroup a => a -> a -> a
<> FastString
name_
, ciLayout :: CILayout
ciLayout = Int -> [JSRep] -> CILayout
CILayoutFixed Int
1 [JSRep
PtrV]
, ciType :: CIType
ciType = CIType
CIThunk
, ciStatic :: CIStatic
ciStatic = CIStatic
forall a. Monoid a => a
mempty
})
((JStgExpr -> JSM JStgStat) -> JSM JStgStat
forall t.
(JVarMagic t, ToJExpr t) =>
(t -> JSM JStgStat) -> JSM JStgStat
jVar ((JStgExpr -> JSM JStgStat) -> JSM JStgStat)
-> (JStgExpr -> JSM JStgStat) -> JSM JStgStat
forall a b. (a -> b) -> a -> b
$ \JStgExpr
tgt ->
JStgStat -> JSM JStgStat
forall a. a -> StateT JEnv Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStgStat -> JSM JStgStat) -> JStgStat -> JSM JStgStat
forall a b. (a -> b) -> a -> b
$ [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat ([JStgStat] -> JStgStat) -> [JStgStat] -> JStgStat
forall a b. (a -> b) -> a -> b
$
[ JStgExpr
tgt JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr -> JStgExpr
closureField1 JStgExpr
r1
, StgToJSConfig -> JStgExpr -> JStgStat
traceRts StgToJSConfig
s (FastString -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr (FastString
"selector entry: " FastString -> FastString -> FastString
forall a. Semigroup a => a -> a -> a
<> FastString
name_ FastString -> FastString -> FastString
forall a. Semigroup a => a -> a -> a
<> FastString
" for ") JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
+ (JStgExpr
tgt JStgExpr -> FastString -> JStgExpr
.^ FastString
"alloc"))
, JStgExpr -> JStgStat -> JStgStat -> JStgStat
ifS (JStgExpr -> JStgExpr
isThunk JStgExpr
tgt JStgExpr -> JStgExpr -> JStgExpr
.||. JStgExpr -> JStgExpr
isBlackhole JStgExpr
tgt)
(JStgExpr -> JStgStat
preIncrS JStgExpr
sp
JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> (JStgExpr
stack JStgExpr -> JStgExpr -> JStgExpr
.! JStgExpr
sp JStgExpr -> JStgExpr -> JStgStat
|= FastString -> JStgExpr
global FastString
frameName)
JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> JStgExpr -> JStgStat
returnS (FastString -> [JStgExpr] -> JStgExpr
app FastString
"h$e" [JStgExpr
tgt]))
(JStgExpr -> JStgStat
returnS (FastString -> [JStgExpr] -> JStgExpr
app FastString
"h$e" [JStgExpr -> JStgExpr
sel JStgExpr
tgt]))
])
, ClosureInfo -> JSM JStgStat -> JSM JStgStat
closure
(ClosureInfo
{ ciVar :: Ident
ciVar = FastString -> Ident
name FastString
frameName
, ciRegs :: CIRegs
ciRegs = Int -> [JSRep] -> CIRegs
CIRegs Int
0 [JSRep
PtrV]
, ciName :: FastString
ciName = FastString
"select " FastString -> FastString -> FastString
forall a. Semigroup a => a -> a -> a
<> FastString
name_ FastString -> FastString -> FastString
forall a. Semigroup a => a -> a -> a
<> FastString
" frame"
, ciLayout :: CILayout
ciLayout = Int -> [JSRep] -> CILayout
CILayoutFixed Int
0 []
, ciType :: CIType
ciType = CIType
CIStackFrame
, ciStatic :: CIStatic
ciStatic = CIStatic
forall a. Monoid a => a
mempty
})
(JSM JStgStat -> JSM JStgStat) -> JSM JStgStat -> JSM JStgStat
forall a b. (a -> b) -> a -> b
$ JStgStat -> JSM JStgStat
forall a. a -> StateT JEnv Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStgStat -> JSM JStgStat) -> JStgStat -> JSM JStgStat
forall a b. (a -> b) -> a -> b
$
[JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat [ StgToJSConfig -> JStgExpr -> JStgStat
traceRts StgToJSConfig
s (FastString -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr (FastString
"selector frame: " FastString -> FastString -> FastString
forall a. Semigroup a => a -> a -> a
<> FastString
name_))
, JStgExpr -> JStgStat
postDecrS JStgExpr
sp
, JStgExpr -> JStgStat
returnS (FastString -> [JStgExpr] -> JStgExpr
app FastString
"h$e" [JStgExpr -> JStgExpr
sel JStgExpr
r1])
]
]
where
v :: FastString -> JVal
v FastString
x = Ident -> JVal
JVar (FastString -> Ident
name FastString
x)
n :: FastString -> FastString
n FastString
ext = FastString
"h$c_sel_" FastString -> FastString -> FastString
forall a. Semigroup a => a -> a -> a
<> FastString
name_ FastString -> FastString -> FastString
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
-> JStgExpr
-> JStgExpr
-> [JStgExpr]
-> JStgStat
mkPap :: StgToJSConfig
-> Ident -> JStgExpr -> JStgExpr -> [JStgExpr] -> JStgStat
mkPap StgToJSConfig
s Ident
tgt JStgExpr
fun JStgExpr
n [JStgExpr]
values =
StgToJSConfig -> JStgExpr -> JStgStat
traceRts StgToJSConfig
s ([Char] -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr ([Char] -> JStgExpr) -> [Char] -> JStgExpr
forall a b. (a -> b) -> a -> b
$ [Char]
"making pap with: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show ([JStgExpr] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [JStgExpr]
values) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" items")
JStgStat -> JStgStat -> JStgStat
forall a. Monoid a => a -> a -> a
`mappend`
StgToJSConfig
-> Bool
-> Ident
-> JStgExpr
-> [JStgExpr]
-> Maybe JStgExpr
-> JStgStat
allocDynamic StgToJSConfig
s Bool
True Ident
tgt (Ident -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr Ident
entry) (JStgExpr
funJStgExpr -> [JStgExpr] -> [JStgExpr]
forall a. a -> [a] -> [a]
:JStgExpr
papArJStgExpr -> [JStgExpr] -> [JStgExpr]
forall a. a -> [a] -> [a]
:(JStgExpr -> JStgExpr) -> [JStgExpr] -> [JStgExpr]
forall a b. (a -> b) -> [a] -> [b]
map JStgExpr -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr [JStgExpr]
values')
(if StgToJSConfig -> Bool
csProf StgToJSConfig
s then JStgExpr -> Maybe JStgExpr
forall a. a -> Maybe a
Just JStgExpr
jCurrentCCS else Maybe JStgExpr
forall a. Maybe a
Nothing)
where
papAr :: JStgExpr
papAr = JStgExpr -> Maybe JStgExpr -> JStgExpr
funOrPapArity JStgExpr
fun Maybe JStgExpr
forall a. Maybe a
Nothing JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
- Int -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr ([JStgExpr] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [JStgExpr]
values Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
256) JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
- JStgExpr
n
values' :: [JStgExpr]
values' | [JStgExpr] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
GHC.Prelude.null [JStgExpr]
values = [JStgExpr
null_]
| Bool
otherwise = [JStgExpr]
values
entry :: Ident
entry | [JStgExpr] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [JStgExpr]
values Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
numSpecPap = FastString -> Ident
name FastString
"h$pap_gen"
| Bool
otherwise = Array Int Ident
specPapIdents Array Int Ident -> Int -> Ident
forall i e. Ix i => Array i e -> i -> e
! [JStgExpr] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [JStgExpr]
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 = (Int, Int) -> [Ident] -> Array Int Ident
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0,Int
numSpecPap) ([Ident] -> Array Int Ident) -> [Ident] -> Array Int Ident
forall a b. (a -> b) -> a -> b
$ (Int -> Ident) -> [Int] -> [Ident]
forall a b. (a -> b) -> [a] -> [b]
map (FastString -> Ident
name (FastString -> Ident) -> (Int -> FastString) -> Int -> Ident
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> FastString
mkFastString ([Char] -> FastString) -> (Int -> [Char]) -> Int -> FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
"h$pap_"[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> (Int -> [Char]) -> Int -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Char]
forall a. Show a => a -> [Char]
show) [Int]
specPap
pap :: StgToJSConfig
-> Int
-> JSM JStgStat
pap :: StgToJSConfig -> Int -> JSM JStgStat
pap StgToJSConfig
s Int
r = ClosureInfo -> JSM JStgStat -> JSM JStgStat
closure (ClosureInfo
{ ciVar :: Ident
ciVar = Ident
funcIdent
, ciRegs :: CIRegs
ciRegs = CIRegs
CIRegsUnknown
, ciName :: FastString
ciName = FastString
funcName
, ciLayout :: CILayout
ciLayout = Int -> CILayout
CILayoutUnknown (Int
rInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
2)
, ciType :: CIType
ciType = CIType
CIPap
, ciStatic :: CIStatic
ciStatic = CIStatic
forall a. Monoid a => a
mempty
}) JSM JStgStat
body
where
funcIdent :: Ident
funcIdent = FastString -> Ident
name FastString
funcName
funcName :: FastString
funcName = [Char] -> FastString
mkFastString ([Char]
"h$pap_" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
r)
body :: JSM JStgStat
body = ((JStgExpr, JStgExpr, JStgExpr, JStgExpr) -> JSM JStgStat)
-> JSM JStgStat
forall args.
JSArgument args =>
(args -> JSM JStgStat) -> JSM JStgStat
jVars (((JStgExpr, JStgExpr, JStgExpr, JStgExpr) -> JSM JStgStat)
-> JSM JStgStat)
-> ((JStgExpr, JStgExpr, JStgExpr, JStgExpr) -> JSM JStgStat)
-> JSM JStgStat
forall a b. (a -> b) -> a -> b
$ \(JStgExpr
c, JStgExpr
d, JStgExpr
f, JStgExpr
extra) ->
JStgStat -> JSM JStgStat
forall a. a -> StateT JEnv Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStgStat -> JSM JStgStat) -> JStgStat -> JSM JStgStat
forall a b. (a -> b) -> a -> b
$ [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat ([JStgStat] -> JStgStat) -> [JStgStat] -> JStgStat
forall a b. (a -> b) -> a -> b
$
[ JStgExpr
c JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr -> JStgExpr
closureField1 JStgExpr
r1
, JStgExpr
d JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr -> JStgExpr
closureField2 JStgExpr
r1
, JStgExpr
f JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr -> JStgExpr
closureInfo JStgExpr
c
, StgToJSConfig -> JStgExpr -> FastString -> JStgStat
forall a. ToJExpr a => StgToJSConfig -> JStgExpr -> a -> JStgStat
assertRts StgToJSConfig
s (JStgExpr -> JStgExpr
isFun' JStgExpr
f JStgExpr -> JStgExpr -> JStgExpr
.||. JStgExpr -> JStgExpr
isPap' JStgExpr
f) (FastString
funcName FastString -> FastString -> FastString
forall a. Semigroup a => a -> a -> a
<> FastString
": expected function or pap")
, StgToJSConfig -> JStgStat -> JStgStat
profStat StgToJSConfig
s (CostCentreStack -> JStgStat
enterCostCentreFun CostCentreStack
currentCCS)
, JStgExpr
extra JStgExpr -> JStgExpr -> JStgStat
|= (JStgExpr -> Maybe JStgExpr -> JStgExpr
funOrPapArity JStgExpr
c (JStgExpr -> Maybe JStgExpr
forall a. a -> Maybe a
Just JStgExpr
f) JStgExpr -> JStgExpr -> JStgExpr
.>>. JStgExpr
8) JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
- Int -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr Int
r
, StgToJSConfig -> JStgExpr -> JStgStat
traceRts StgToJSConfig
s (FastString -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr (FastString
funcName FastString -> FastString -> FastString
forall a. Semigroup a => a -> a -> a
<> FastString
": pap extra args moving: ") JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
+ JStgExpr
extra)
, JStgExpr -> JStgStat
moveBy JStgExpr
extra
, JStgExpr -> JStgStat
loadOwnArgs JStgExpr
d
, JStgExpr
r1 JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
c
, JStgExpr -> JStgStat
returnS JStgExpr
f
]
moveBy :: JStgExpr -> JStgStat
moveBy JStgExpr
extra = JStgExpr -> [(JStgExpr, JStgStat)] -> JStgStat -> JStgStat
SwitchStat JStgExpr
extra
([(JStgExpr, JStgStat)] -> [(JStgExpr, JStgStat)]
forall a. [a] -> [a]
reverse ([(JStgExpr, JStgStat)] -> [(JStgExpr, JStgStat)])
-> [(JStgExpr, JStgStat)] -> [(JStgExpr, JStgStat)]
forall a b. (a -> b) -> a -> b
$ (Int -> (JStgExpr, JStgStat)) -> [Int] -> [(JStgExpr, JStgStat)]
forall a b. (a -> b) -> [a] -> [b]
map Int -> (JStgExpr, JStgStat)
moveCase [Int
1..Int
maxRegInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
rInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]) JStgStat
forall a. Monoid a => a
mempty
moveCase :: Int -> (JStgExpr, JStgStat)
moveCase Int
m = (Int -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr Int
m, Int -> JStgExpr
jsReg (Int
mInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
rInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) JStgExpr -> JStgExpr -> JStgStat
|= Int -> JStgExpr
jsReg (Int
mInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1))
loadOwnArgs :: JStgExpr -> JStgStat
loadOwnArgs JStgExpr
d = [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat ([JStgStat] -> JStgStat) -> [JStgStat] -> JStgStat
forall a b. (a -> b) -> a -> b
$ (Int -> JStgStat) -> [Int] -> [JStgStat]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
r ->
Int -> JStgExpr
jsReg (Int
rInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr -> Int -> JStgExpr
forall {a}. (Show a, Num a) => JStgExpr -> a -> JStgExpr
dField JStgExpr
d (Int
rInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
2)) [Int
1..Int
r]
dField :: JStgExpr -> a -> JStgExpr
dField JStgExpr
d a
n = JStgExpr -> Ident -> JStgExpr
SelExpr JStgExpr
d (FastString -> Ident
name (FastString -> Ident) -> ([Char] -> FastString) -> [Char] -> Ident
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> FastString
mkFastString ([Char] -> Ident) -> [Char] -> Ident
forall a b. (a -> b) -> a -> b
$ (Char
'd'Char -> ShowS
forall a. a -> [a] -> [a]
:a -> [Char]
forall a. Show a => a -> [Char]
show (a
na -> a -> a
forall a. Num a => a -> a -> a
-a
1)))
papGen :: StgToJSConfig -> JSM JStgStat
papGen :: StgToJSConfig -> JSM JStgStat
papGen StgToJSConfig
cfg =
ClosureInfo -> JSM JStgStat -> JSM JStgStat
closure (ClosureInfo
{ ciVar :: Ident
ciVar = Ident
funcIdent
, ciRegs :: CIRegs
ciRegs = CIRegs
CIRegsUnknown
, ciName :: FastString
ciName = FastString
funcName
, ciLayout :: CILayout
ciLayout = CILayout
CILayoutVariable
, ciType :: CIType
ciType = CIType
CIPap
, ciStatic :: CIStatic
ciStatic = CIStatic
forall a. Monoid a => a
mempty
})
(((JStgExpr, JStgExpr, JStgExpr, JStgExpr, JStgExpr, JStgExpr)
-> JSM JStgStat)
-> JSM JStgStat
forall args.
JSArgument args =>
(args -> JSM JStgStat) -> JSM JStgStat
jVars (((JStgExpr, JStgExpr, JStgExpr, JStgExpr, JStgExpr, JStgExpr)
-> JSM JStgStat)
-> JSM JStgStat)
-> ((JStgExpr, JStgExpr, JStgExpr, JStgExpr, JStgExpr, JStgExpr)
-> JSM JStgStat)
-> JSM JStgStat
forall a b. (a -> b) -> a -> b
$ \(JStgExpr
c, JStgExpr
f, JStgExpr
d, JStgExpr
pr, JStgExpr
or, JStgExpr
r) ->
JStgStat -> JSM JStgStat
forall a. a -> StateT JEnv Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStgStat -> JSM JStgStat) -> JStgStat -> JSM JStgStat
forall a b. (a -> b) -> a -> b
$ [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat
[ JStgExpr
c JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr -> JStgExpr
closureField1 JStgExpr
r1
, JStgExpr
d JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr -> JStgExpr
closureField2 JStgExpr
r1
, JStgExpr
f JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr -> JStgExpr
closureInfo JStgExpr
c
, JStgExpr
pr JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr -> Maybe JStgExpr -> JStgExpr
funOrPapArity JStgExpr
c (JStgExpr -> Maybe JStgExpr
forall a. a -> Maybe a
Just JStgExpr
f) JStgExpr -> JStgExpr -> JStgExpr
.>>. JStgExpr
8
, JStgExpr
or JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr -> JStgExpr
papArity JStgExpr
r1 JStgExpr -> JStgExpr -> JStgExpr
.>>. JStgExpr
8
, JStgExpr
r JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
pr JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
- JStgExpr
or
, StgToJSConfig -> JStgExpr -> JStgExpr -> JStgStat
forall a. ToJExpr a => StgToJSConfig -> JStgExpr -> a -> JStgStat
assertRts StgToJSConfig
cfg
(JStgExpr -> JStgExpr
isFun' JStgExpr
f JStgExpr -> JStgExpr -> JStgExpr
.||. JStgExpr -> JStgExpr
isPap' JStgExpr
f)
(FastString -> JStgExpr
jString FastString
"h$pap_gen: expected function or pap")
, StgToJSConfig -> JStgStat -> JStgStat
profStat StgToJSConfig
cfg (CostCentreStack -> JStgStat
enterCostCentreFun CostCentreStack
currentCCS)
, StgToJSConfig -> JStgExpr -> JStgStat
traceRts StgToJSConfig
cfg (FastString -> JStgExpr
jString FastString
"h$pap_gen: generic pap extra args moving: " JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
+ JStgExpr
or)
, FastString -> [JStgExpr] -> JStgStat
appS FastString
hdMoveRegs2 [JStgExpr
or, JStgExpr
r]
, JStgExpr -> JStgExpr -> JStgStat
loadOwnArgs JStgExpr
d JStgExpr
r
, JStgExpr
r1 JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
c
, JStgExpr -> JStgStat
returnS JStgExpr
f
])
where
funcIdent :: Ident
funcIdent = FastString -> Ident
name FastString
funcName
funcName :: FastString
funcName = FastString
hdPapGenStr
loadOwnArgs :: JStgExpr -> JStgExpr -> JStgStat
loadOwnArgs JStgExpr
d JStgExpr
r =
let prop :: Int -> JStgExpr
prop Int
n = JStgExpr
d JStgExpr -> FastString -> JStgExpr
.^ (FastString
"d" FastString -> FastString -> FastString
forall a. Semigroup a => a -> a -> a
<> [Char] -> FastString
mkFastString (Int -> [Char]
forall a. Show a => a -> [Char]
show (Int -> [Char]) -> Int -> [Char]
forall a b. (a -> b) -> a -> b
$ Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1))
loadOwnArg :: Int -> (JStgExpr, JStgStat)
loadOwnArg Int
n = (Int -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr Int
n, Int -> JStgExpr
jsReg (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) JStgExpr -> JStgExpr -> JStgStat
|= Int -> JStgExpr
prop Int
n)
in JStgExpr -> [(JStgExpr, JStgStat)] -> JStgStat -> JStgStat
SwitchStat JStgExpr
r ((Int -> (JStgExpr, JStgStat)) -> [Int] -> [(JStgExpr, JStgStat)]
forall a b. (a -> b) -> [a] -> [b]
map Int -> (JStgExpr, JStgStat)
loadOwnArg [Int
127,Int
126..Int
1]) JStgStat
forall a. Monoid a => a
mempty
moveRegs2 :: JSM JStgStat
moveRegs2 :: JSM JStgStat
moveRegs2 = Ident -> ((JStgExpr, JStgExpr) -> JSM JStgStat) -> JSM JStgStat
forall args.
JSArgument args =>
Ident -> (args -> JSM JStgStat) -> JSM JStgStat
jFunction (FastString -> Ident
name FastString
hdMoveRegs2) (JStgExpr, JStgExpr) -> JSM JStgStat
moveSwitch
where
moveSwitch :: (JStgExpr, JStgExpr) -> JSM JStgStat
moveSwitch (JStgExpr
n,JStgExpr
m) = JStgExpr -> JStgExpr -> JSM JStgStat
defaultCase JStgExpr
n JStgExpr
m JSM JStgStat -> (JStgStat -> JSM JStgStat) -> JSM JStgStat
forall a b.
StateT JEnv Identity a
-> (a -> StateT JEnv Identity b) -> StateT JEnv Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= JStgStat -> JSM JStgStat
forall a. a -> StateT JEnv Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStgStat -> JSM JStgStat)
-> (JStgStat -> JStgStat) -> JStgStat -> JSM JStgStat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JStgExpr -> [(JStgExpr, JStgStat)] -> JStgStat -> JStgStat
SwitchStat ((JStgExpr
n JStgExpr -> JStgExpr -> JStgExpr
.<<. JStgExpr
8) JStgExpr -> JStgExpr -> JStgExpr
.|. JStgExpr
m) [(JStgExpr, JStgStat)]
switchCases
switchCases :: [(JStgExpr, JStgStat)]
switchCases = [Int -> Int -> (JStgExpr, JStgStat)
switchCase Int
n Int
m | Int
n <- [Int
1..Int
5], Int
m <- [Int
1..Int
4]]
switchCase :: Int -> Int -> (JStgExpr, JStgStat)
switchCase :: Int -> Int -> (JStgExpr, JStgStat)
switchCase Int
n Int
m = (Int -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr (Int -> JStgExpr) -> Int -> JStgExpr
forall a b. (a -> b) -> a -> b
$
(Int
n Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`Bits.shiftL` Int
8) Int -> Int -> Int
forall a. Bits a => a -> a -> a
Bits..|. Int
m
, [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat ((Int -> JStgStat) -> [Int] -> [JStgStat]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Int -> JStgStat
`moveRegFast` Int
m) [Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1,Int
n..Int
2])
JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> Maybe JsLabel -> JStgStat
BreakStat Maybe JsLabel
forall a. Maybe a
Nothing )
moveRegFast :: Int -> Int -> JStgStat
moveRegFast Int
n Int
m = Int -> JStgExpr
jsReg (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
m) JStgExpr -> JStgExpr -> JStgStat
|= Int -> JStgExpr
jsReg Int
n
defaultCase :: JStgExpr -> JStgExpr -> JSM JStgStat
defaultCase JStgExpr
n JStgExpr
m =
JStgExpr
-> (JStgExpr -> JStgExpr)
-> (JStgExpr -> JSM JStgStat)
-> JSM JStgStat
loop JStgExpr
n (JStgExpr -> JStgExpr -> JStgExpr
.>.JStgExpr
0) (\JStgExpr
i -> JStgStat -> JSM JStgStat
forall a. a -> StateT JEnv Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStgStat -> JSM JStgStat) -> JStgStat -> JSM JStgStat
forall a b. (a -> b) -> a -> b
$
FastString -> [JStgExpr] -> JStgStat
appS FastString
hdSetRegStr [JStgExpr
iJStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
+JStgExpr
1JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
+JStgExpr
m, FastString -> [JStgExpr] -> JStgExpr
app FastString
hdGetRegStr [JStgExpr
iJStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
+JStgExpr
1]]
JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> JStgExpr -> JStgStat
postDecrS JStgExpr
i)
initClosure :: StgToJSConfig -> JStgExpr -> JStgExpr -> JStgExpr -> JStgExpr
initClosure :: StgToJSConfig -> JStgExpr -> JStgExpr -> JStgExpr -> JStgExpr
initClosure StgToJSConfig
cfg JStgExpr
info JStgExpr
values JStgExpr
ccs = FastString -> [JStgExpr] -> JStgExpr
app FastString
hdInitClosure
[ Closure -> JStgExpr
newClosure (Closure -> JStgExpr) -> Closure -> JStgExpr
forall a b. (a -> b) -> a -> b
$ Closure
{ clInfo :: JStgExpr
clInfo = JStgExpr
info
, clField1 :: JStgExpr
clField1 = JStgExpr
null_
, clField2 :: JStgExpr
clField2 = JStgExpr
null_
, clMeta :: JStgExpr
clMeta = JStgExpr
0
, clCC :: Maybe JStgExpr
clCC = if StgToJSConfig -> Bool
csProf StgToJSConfig
cfg then JStgExpr -> Maybe JStgExpr
forall a. a -> Maybe a
Just JStgExpr
ccs else Maybe JStgExpr
forall a. Maybe a
Nothing
}
, JStgExpr
values
]
getIdFields :: Id -> G [TypedExpr]
getIdFields :: Id -> G [TypedExpr]
getIdFields Id
i = Id -> [JStgExpr] -> [TypedExpr]
assocIdExprs Id
i ([JStgExpr] -> [TypedExpr])
-> StateT GenState IO [JStgExpr] -> G [TypedExpr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> StateT GenState IO [JStgExpr]
varsForId Id
i
storeIdFields :: Id -> [TypedExpr] -> G JStgStat
storeIdFields :: Id -> [TypedExpr] -> G JStgStat
storeIdFields Id
i [TypedExpr]
dst = do
fields <- Id -> G [TypedExpr]
getIdFields Id
i
pure (assignCoerce1 dst fields)