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