{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE BlockArguments #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  GHC.StgToJS.Apply
-- Copyright   :  (c) The University of Glasgow 2001
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  Jeffrey Young  <jeffrey.young@iohk.io>
--                Luite Stegeman <luite.stegeman@iohk.io>
--                Sylvain Henry  <sylvain.henry@iohk.io>
--                Josh Meredith  <josh.meredith@iohk.io>
-- Stability   :  experimental
--
--
-- Module that deals with expression application in JavaScript. In some cases we
-- rely on pre-generated functions that are bundled with the RTS (see rtsApply).
-----------------------------------------------------------------------------

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

-- | Pre-generated functions for fast Apply.
-- These are bundled with the RTS.
rtsApply :: StgToJSConfig -> JStat
rtsApply :: StgToJSConfig -> JStat
rtsApply StgToJSConfig
cfg = [JStat] -> JStat
BlockStat forall a b. (a -> b) -> a -> b
$
  forall a b. (a -> b) -> [a] -> [b]
map (StgToJSConfig -> ApplySpec -> JStat
specApply StgToJSConfig
cfg) [ApplySpec]
applySpec
  forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map (StgToJSConfig -> Int -> JStat
pap StgToJSConfig
cfg) [Int]
specPap
  forall a. [a] -> [a] -> [a]
++ [ JStat
mkApplyArr
     , StgToJSConfig -> JStat
genericStackApply StgToJSConfig
cfg
     , StgToJSConfig -> JStat
genericFastApply  StgToJSConfig
cfg
     , StgToJSConfig -> JStat
zeroApply StgToJSConfig
cfg
     , StgToJSConfig -> JStat
updates   StgToJSConfig
cfg
     , StgToJSConfig -> JStat
papGen    StgToJSConfig
cfg
     , JStat
moveRegs2
     , StgToJSConfig -> JStat
selectors StgToJSConfig
cfg
     ]


-- | Generate an application of some args to an Id.
--
-- The case where args is null is common as it's used to generate the evaluation
-- code for an Id.
genApp
  :: HasDebugCallStack
  => ExprCtx
  -> Id
  -> [StgArg]
  -> G (JStat, ExprResult)
genApp :: HasDebugCallStack =>
ExprCtx -> Id -> [StgArg] -> G (JStat, ExprResult)
genApp ExprCtx
ctx Id
i [StgArg]
args

    -- Case: unpackCStringAppend# "some string"# str
    --
    -- Generates h$appendToHsStringA(str, "some string"), which has a faster
    -- decoding loop.
    | [StgLitArg (LitString ByteString
bs), StgArg
x] <- [StgArg]
args
    , [JExpr
top] <- forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TypedExpr -> [JExpr]
typex_expr (ExprCtx -> [TypedExpr]
ctxTarget ExprCtx
ctx)
    , forall a. Uniquable a => a -> Unique
getUnique Id
i forall a. Eq a => a -> a -> Bool
== Unique
unpackCStringAppendIdKey
    , [Char]
d <- ByteString -> [Char]
utf8DecodeByteString ByteString
bs
    = do
        Bool
prof <- StgToJSConfig -> Bool
csProf forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> G StgToJSConfig
getSettings
        let profArg :: [JExpr]
profArg = if Bool
prof then [JExpr
jCafCCS] else []
        [JExpr]
a <- HasDebugCallStack => StgArg -> G [JExpr]
genArg StgArg
x
        forall (m :: * -> *) a. Monad m => a -> m a
return ( JExpr
top JExpr -> JExpr -> JStat
|= FastString -> [JExpr] -> JExpr
app FastString
"h$appendToHsStringA" ([forall a. ToJExpr a => a -> JExpr
toJExpr [Char]
d, forall a. ToJExpr a => a -> JExpr
toJExpr [JExpr]
a] forall a. [a] -> [a] -> [a]
++ [JExpr]
profArg)
               , Maybe [JExpr] -> ExprResult
ExprInline forall a. Maybe a
Nothing
               )

    -- let-no-escape
    | Just Int
n <- ExprCtx -> Id -> Maybe Int
ctxLneBindingStackSize ExprCtx
ctx Id
i
    = do
      [JExpr]
as'      <- forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Traversable f) =>
(a -> m [b]) -> f a -> m [b]
concatMapM HasDebugCallStack => StgArg -> G [JExpr]
genArg [StgArg]
args
      JExpr
ei       <- Id -> G JExpr
varForEntryId Id
i
      let ra :: JStat
ra = forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$
                 forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\StgReg
r JExpr
a -> forall a. ToJExpr a => a -> JExpr
toJExpr StgReg
r JExpr -> JExpr -> JStat
|= JExpr
a) [StgReg
R1 ..] [JExpr]
as'
      JStat
p <- HasDebugCallStack => Int -> ExprCtx -> G JStat
pushLneFrame Int
n ExprCtx
ctx
      JStat
a <- Int -> G JStat
adjSp Int
1 -- for the header (which will only be written when the thread is suspended)
      forall (m :: * -> *) a. Monad m => a -> m a
return (JStat
ra forall a. Semigroup a => a -> a -> a
<> JStat
p forall a. Semigroup a => a -> a -> a
<> JStat
a forall a. Semigroup a => a -> a -> a
<> JExpr -> JStat
returnS JExpr
ei, ExprResult
ExprCont)

    -- proxy#
    | [] <- [StgArg]
args
    , forall a. Uniquable a => a -> Unique
getUnique Id
i forall a. Eq a => a -> a -> Bool
== Unique
proxyHashKey
    , [JExpr
top] <- forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TypedExpr -> [JExpr]
typex_expr (ExprCtx -> [TypedExpr]
ctxTarget ExprCtx
ctx)
    = forall (m :: * -> *) a. Monad m => a -> m a
return (JExpr
top JExpr -> JExpr -> JStat
|= JExpr
null_, Maybe [JExpr] -> ExprResult
ExprInline forall a. Maybe a
Nothing)

    -- unboxed tuple or strict type: return fields individually
    | [] <- [StgArg]
args
    , Type -> Bool
isUnboxedTupleType (Id -> Type
idType Id
i) Bool -> Bool -> Bool
|| HasDebugCallStack => Type -> Bool
isStrictType (Id -> Type
idType Id
i)
    = do
      JStat
a <- Id -> [TypedExpr] -> G JStat
storeIdFields Id
i (ExprCtx -> [TypedExpr]
ctxTarget ExprCtx
ctx)
      forall (m :: * -> *) a. Monad m => a -> m a
return (JStat
a, Maybe [JExpr] -> ExprResult
ExprInline forall a. Maybe a
Nothing)

    -- Handle alternative heap object representation: in some cases, a heap
    -- object is not represented as a JS object but directly as a number or a
    -- string. I.e. only the payload is stored because the box isn't useful.
    -- It happens for "Int Int#" for example: no need to box the Int# in JS.
    --
    -- We must check that:
    --  - the object is subject to the optimization (cf isUnboxable predicate)
    --  - we know that it is already evaluated (cf ctxIsEvaluated), otherwise we
    --  need to evaluate it properly first.
    --
    -- In which case we generate a dynamic check (using isObject) that either:
    --  - returns the payload of the heap object, if it uses the generic heap
    --  object representation
    --  - returns the object directly, otherwise
    | [] <- [StgArg]
args
    , [VarType
vt] <- HasDebugCallStack => Id -> [VarType]
idVt Id
i
    , VarType -> Bool
isUnboxable VarType
vt
    , ExprCtx -> Id -> Bool
ctxIsEvaluated ExprCtx
ctx Id
i
    = do
      let c :: JExpr
c = forall a. [a] -> a
head (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TypedExpr -> [JExpr]
typex_expr forall a b. (a -> b) -> a -> b
$ ExprCtx -> [TypedExpr]
ctxTarget ExprCtx
ctx)
      [JExpr]
is <- Id -> G [JExpr]
varsForId Id
i
      case [JExpr]
is of
        [JExpr
i'] ->
          forall (m :: * -> *) a. Monad m => a -> m a
return ( JExpr
c JExpr -> JExpr -> JStat
|= JExpr -> JExpr -> JExpr -> JExpr
if_ (JExpr -> JExpr
isObject JExpr
i') (JExpr -> JExpr
closureField1 JExpr
i') JExpr
i'
                 , Maybe [JExpr] -> ExprResult
ExprInline forall a. Maybe a
Nothing
                 )
        [JExpr]
_ -> forall a. HasCallStack => [Char] -> a
panic [Char]
"genApp: invalid size"

    -- case of Id without args and known to be already evaluated: return fields
    -- individually
    | [] <- [StgArg]
args
    , ExprCtx -> Id -> Bool
ctxIsEvaluated ExprCtx
ctx Id
i Bool -> Bool -> Bool
|| HasDebugCallStack => Type -> Bool
isStrictType (Id -> Type
idType Id
i)
    = do
      JStat
a <- Id -> [TypedExpr] -> G JStat
storeIdFields Id
i (ExprCtx -> [TypedExpr]
ctxTarget ExprCtx
ctx)
      -- optional runtime assert for detecting unexpected thunks (unevaluated)
      StgToJSConfig
settings <- G StgToJSConfig
getSettings
      let ww :: JStat
ww = case forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TypedExpr -> [JExpr]
typex_expr (ExprCtx -> [TypedExpr]
ctxTarget ExprCtx
ctx) of
                 [JExpr
t] | StgToJSConfig -> Bool
csAssertRts StgToJSConfig
settings ->
                         JExpr -> JStat -> JStat -> JStat
ifS (JExpr -> JExpr
isObject JExpr
t JExpr -> JExpr -> JExpr
.&&. JExpr -> JExpr
isThunk JExpr
t)
                             (FastString -> [JExpr] -> JStat
appS FastString
"throw" [FastString -> JExpr
String FastString
"unexpected thunk"]) -- yuck
                             forall a. Monoid a => a
mempty
                 [JExpr]
_   -> forall a. Monoid a => a
mempty
      forall (m :: * -> *) a. Monad m => a -> m a
return (JStat
a forall a. Monoid a => a -> a -> a
`mappend` JStat
ww, Maybe [JExpr] -> ExprResult
ExprInline forall a. Maybe a
Nothing)


    -- Case: "newtype" datacon wrapper
    --
    -- If the wrapped argument is known to be already evaluated, then we don't
    -- need to enter it.
    | DataConWrapId DataCon
dc <- Id -> IdDetails
idDetails Id
i
    , TyCon -> Bool
isNewTyCon (DataCon -> TyCon
dataConTyCon DataCon
dc)
    = do
      [JExpr]
as <- forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Traversable f) =>
(a -> m [b]) -> f a -> m [b]
concatMapM HasDebugCallStack => StgArg -> G [JExpr]
genArg [StgArg]
args
      case [JExpr]
as of
        [JExpr
ai] -> do
          let t :: JExpr
t = forall a. [a] -> a
head (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TypedExpr -> [JExpr]
typex_expr (ExprCtx -> [TypedExpr]
ctxTarget ExprCtx
ctx))
              a' :: Id
a' = case [StgArg]
args of
                [StgVarArg Id
a'] -> Id
a'
                [StgArg]
_              -> forall a. HasCallStack => [Char] -> a
panic [Char]
"genApp: unexpected arg"
          if Id -> Bool
isStrictId Id
a' Bool -> Bool -> Bool
|| ExprCtx -> Id -> Bool
ctxIsEvaluated ExprCtx
ctx Id
a'
            then forall (m :: * -> *) a. Monad m => a -> m a
return (JExpr
t JExpr -> JExpr -> JStat
|= JExpr
ai, Maybe [JExpr] -> ExprResult
ExprInline forall a. Maybe a
Nothing)
            else forall (m :: * -> *) a. Monad m => a -> m a
return (JExpr -> JStat
returnS (FastString -> [JExpr] -> JExpr
app FastString
"h$e" [JExpr
ai]), ExprResult
ExprCont)
        [JExpr]
_ -> forall a. HasCallStack => [Char] -> a
panic [Char]
"genApp: invalid size"

    -- no args and Id can't be a function: just enter it
    | [] <- [StgArg]
args
    , Id -> Int
idFunRepArity Id
i forall a. Eq a => a -> a -> Bool
== Int
0
    , Bool -> Bool
not (HasDebugCallStack => Type -> Bool
might_be_a_function (Id -> Type
idType Id
i))
    = do
      JExpr
enter_id <- HasDebugCallStack => Id -> G [JExpr]
genIdArg Id
i forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                    \case
                       [JExpr
x] -> forall (m :: * -> *) a. Monad m => a -> m a
return JExpr
x
                       [JExpr]
xs  -> forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"genApp: unexpected multi-var argument"
                                (forall doc. IsDoc doc => [doc] -> doc
vcat [forall a. Outputable a => a -> SDoc
ppr (forall (t :: * -> *) a. Foldable t => t a -> Int
length [JExpr]
xs), forall a. Outputable a => a -> SDoc
ppr Id
i])
      forall (m :: * -> *) a. Monad m => a -> m a
return (JExpr -> JStat
returnS (FastString -> [JExpr] -> JExpr
app FastString
"h$e" [JExpr
enter_id]), ExprResult
ExprCont)

    -- fully saturated global function:
    --  - deals with arguments
    --  - jumps into the function
    | Int
n <- forall (t :: * -> *) a. Foldable t => t a -> Int
length [StgArg]
args
    , Int
n forall a. Eq a => a -> a -> Bool
/= Int
0
    , Id -> Int
idFunRepArity Id
i forall a. Eq a => a -> a -> Bool
== Int
n
    , Bool -> Bool
not (Id -> Bool
isLocalId Id
i)
    , Id -> Bool
isStrictId Id
i
    = do
      [JExpr]
as' <- forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Traversable f) =>
(a -> m [b]) -> f a -> m [b]
concatMapM HasDebugCallStack => StgArg -> G [JExpr]
genArg [StgArg]
args
      JStat
is  <- [JExpr] -> [JExpr] -> JStat
assignAll [JExpr]
jsRegsFromR1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> G [JExpr]
varsForId Id
i
      JStat
jmp <- Id -> [JExpr] -> JStat -> G JStat
jumpToII Id
i [JExpr]
as' JStat
is
      forall (m :: * -> *) a. Monad m => a -> m a
return (JStat
jmp, ExprResult
ExprCont)

    -- oversaturated function:
    --  - push continuation with extra args
    --  - deals with arguments
    --  - jumps into the function
    | Id -> Int
idFunRepArity Id
i forall a. Ord a => a -> a -> Bool
< forall (t :: * -> *) a. Foldable t => t a -> Int
length [StgArg]
args
    , Id -> Bool
isStrictId Id
i
    , Id -> Int
idFunRepArity Id
i forall a. Ord a => a -> a -> Bool
> Int
0
    = do
      let ([StgArg]
reg,[StgArg]
over) = forall a. Int -> [a] -> ([a], [a])
splitAt (Id -> Int
idFunRepArity Id
i) [StgArg]
args
      [JExpr]
reg' <- forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Traversable f) =>
(a -> m [b]) -> f a -> m [b]
concatMapM HasDebugCallStack => StgArg -> G [JExpr]
genArg [StgArg]
reg
      JStat
pc   <- HasDebugCallStack => [StgArg] -> G JStat
pushCont [StgArg]
over
      JStat
is   <- [JExpr] -> [JExpr] -> JStat
assignAll [JExpr]
jsRegsFromR1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> G [JExpr]
varsForId Id
i
      JStat
jmp  <- Id -> [JExpr] -> JStat -> G JStat
jumpToII Id
i [JExpr]
reg' JStat
is
      forall (m :: * -> *) a. Monad m => a -> m a
return (JStat
pc forall a. Semigroup a => a -> a -> a
<> JStat
jmp, ExprResult
ExprCont)

    -- generic apply:
    --  - try to find a pre-generated apply function that matches
    --  - use it if any
    --  - otherwise use generic apply function h$ap_gen_fast
    | Bool
otherwise
    = do
      JStat
is  <- [JExpr] -> [JExpr] -> JStat
assignAll [JExpr]
jsRegsFromR1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> G [JExpr]
varsForId Id
i
      JStat
jmp <- HasDebugCallStack => [StgArg] -> JStat -> G JStat
jumpToFast [StgArg]
args JStat
is
      forall (m :: * -> *) a. Monad m => a -> m a
return (JStat
jmp, ExprResult
ExprCont)

-- avoid one indirection for global ids
-- fixme in many cases we can also jump directly to the entry for local?
jumpToII :: Id -> [JExpr] -> JStat -> G JStat
jumpToII :: Id -> [JExpr] -> JStat -> G JStat
jumpToII Id
i [JExpr]
vars JStat
load_app_in_r1
  | Id -> Bool
isLocalId Id
i = do
     JExpr
ii <- Id -> G JExpr
varForId Id
i
     forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat
      [ [JExpr] -> [JExpr] -> JStat
assignAllReverseOrder [JExpr]
jsRegsFromR2 [JExpr]
vars
      , JStat
load_app_in_r1
      , JExpr -> JStat
returnS (JExpr -> JExpr
closureEntry JExpr
ii)
      ]
  | Bool
otherwise   = do
     JExpr
ei <- Id -> G JExpr
varForEntryId Id
i
     forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat
      [ [JExpr] -> [JExpr] -> JStat
assignAllReverseOrder [JExpr]
jsRegsFromR2 [JExpr]
vars
      , JStat
load_app_in_r1
      , JExpr -> JStat
returnS JExpr
ei
      ]

-- | Try to use a specialized pre-generated application function.
-- If there is none, use h$ap_gen_fast instead
jumpToFast :: HasDebugCallStack => [StgArg] -> JStat -> G JStat
jumpToFast :: HasDebugCallStack => [StgArg] -> JStat -> G JStat
jumpToFast [StgArg]
args JStat
load_app_in_r1 = do
  -- get JS expressions for every argument
  -- Arguments may have more than one expression (e.g. Word64#)
  [JExpr]
vars <- forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Traversable f) =>
(a -> m [b]) -> f a -> m [b]
concatMapM HasDebugCallStack => StgArg -> G [JExpr]
genArg [StgArg]
args
  -- try to find a specialized apply function
  let spec :: ApplySpec
spec = ApplyConv -> [StgArg] -> [JExpr] -> ApplySpec
mkApplySpec ApplyConv
RegsConv [StgArg]
args [JExpr]
vars
  Either JExpr JExpr
ap_fun <- ApplySpec -> G (Either JExpr JExpr)
selectApply ApplySpec
spec
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat
    [ [JExpr] -> [JExpr] -> JStat
assignAllReverseOrder [JExpr]
jsRegsFromR2 [JExpr]
vars
    , JStat
load_app_in_r1
    , case Either JExpr JExpr
ap_fun of
        -- specialized apply: no tag
        Right JExpr
fun -> JExpr -> JStat
returnS (JExpr -> [JExpr] -> JExpr
ApplExpr JExpr
fun [])
        -- generic apply: pass a tag indicating number of args/slots
        Left  JExpr
fun -> JExpr -> JStat
returnS (JExpr -> [JExpr] -> JExpr
ApplExpr JExpr
fun [ApplySpec -> JExpr
specTagExpr ApplySpec
spec])
    ]

-- | Calling convention for an apply function
data ApplyConv
  = RegsConv  -- ^ Fast calling convention: use registers
  | StackConv -- ^ Slow calling convention: use the stack
  deriving (Int -> ApplyConv -> ShowS
[ApplyConv] -> ShowS
ApplyConv -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [ApplyConv] -> ShowS
$cshowList :: [ApplyConv] -> ShowS
show :: ApplyConv -> [Char]
$cshow :: ApplyConv -> [Char]
showsPrec :: Int -> ApplyConv -> ShowS
$cshowsPrec :: Int -> ApplyConv -> ShowS
Show,ApplyConv -> ApplyConv -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ApplyConv -> ApplyConv -> Bool
$c/= :: ApplyConv -> ApplyConv -> Bool
== :: ApplyConv -> ApplyConv -> Bool
$c== :: ApplyConv -> ApplyConv -> Bool
Eq,Eq ApplyConv
ApplyConv -> ApplyConv -> Bool
ApplyConv -> ApplyConv -> Ordering
ApplyConv -> ApplyConv -> ApplyConv
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ApplyConv -> ApplyConv -> ApplyConv
$cmin :: ApplyConv -> ApplyConv -> ApplyConv
max :: ApplyConv -> ApplyConv -> ApplyConv
$cmax :: ApplyConv -> ApplyConv -> ApplyConv
>= :: ApplyConv -> ApplyConv -> Bool
$c>= :: ApplyConv -> ApplyConv -> Bool
> :: ApplyConv -> ApplyConv -> Bool
$c> :: ApplyConv -> ApplyConv -> Bool
<= :: ApplyConv -> ApplyConv -> Bool
$c<= :: ApplyConv -> ApplyConv -> Bool
< :: ApplyConv -> ApplyConv -> Bool
$c< :: ApplyConv -> ApplyConv -> Bool
compare :: ApplyConv -> ApplyConv -> Ordering
$ccompare :: ApplyConv -> ApplyConv -> Ordering
Ord)

-- | Name of the generic apply function
genericApplyName :: ApplyConv -> FastString
genericApplyName :: ApplyConv -> FastString
genericApplyName = \case
  ApplyConv
RegsConv  -> FastString
"h$ap_gen_fast"
  ApplyConv
StackConv -> FastString
"h$ap_gen"

-- | Expr of the generic apply function
genericApplyExpr :: ApplyConv -> JExpr
genericApplyExpr :: ApplyConv -> JExpr
genericApplyExpr ApplyConv
conv = FastString -> JExpr
var (ApplyConv -> FastString
genericApplyName ApplyConv
conv)


-- | Return the name of the specialized apply function for the given number of
-- args, number of arg variables, and calling convention.
specApplyName :: ApplySpec -> FastString
specApplyName :: ApplySpec -> FastString
specApplyName = \case
  -- specialize a few for compiler performance (avoid building FastStrings over
  -- and over for common cases)
  ApplySpec ApplyConv
RegsConv  Int
0 Int
0    -> FastString
"h$ap_0_0_fast"
  ApplySpec ApplyConv
StackConv Int
0 Int
0    -> FastString
"h$ap_0_0"
  ApplySpec ApplyConv
RegsConv  Int
1 Int
0    -> FastString
"h$ap_1_0_fast"
  ApplySpec ApplyConv
StackConv Int
1 Int
0    -> FastString
"h$ap_1_0"
  ApplySpec ApplyConv
RegsConv  Int
1 Int
1    -> FastString
"h$ap_1_1_fast"
  ApplySpec ApplyConv
StackConv Int
1 Int
1    -> FastString
"h$ap_1_1"
  ApplySpec ApplyConv
RegsConv  Int
1 Int
2    -> FastString
"h$ap_1_2_fast"
  ApplySpec ApplyConv
StackConv Int
1 Int
2    -> FastString
"h$ap_1_2"
  ApplySpec ApplyConv
RegsConv  Int
2 Int
1    -> FastString
"h$ap_2_1_fast"
  ApplySpec ApplyConv
StackConv Int
2 Int
1    -> FastString
"h$ap_2_1"
  ApplySpec ApplyConv
RegsConv  Int
2 Int
2    -> FastString
"h$ap_2_2_fast"
  ApplySpec ApplyConv
StackConv Int
2 Int
2    -> FastString
"h$ap_2_2"
  ApplySpec ApplyConv
RegsConv  Int
2 Int
3    -> FastString
"h$ap_2_3_fast"
  ApplySpec ApplyConv
StackConv Int
2 Int
3    -> FastString
"h$ap_2_3"
  ApplySpec ApplyConv
conv Int
nargs Int
nvars -> [Char] -> FastString
mkFastString forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat
                                  [ [Char]
"h$ap_", forall a. Show a => a -> [Char]
show Int
nargs
                                  , [Char]
"_"    , forall a. Show a => a -> [Char]
show Int
nvars
                                  , case ApplyConv
conv of
                                      ApplyConv
RegsConv  -> [Char]
"_fast"
                                      ApplyConv
StackConv -> [Char]
""
                                  ]

-- | Return the expression of the specialized apply function for the given
-- number of args, number of arg variables, and calling convention.
--
-- Warning: the returned function may not be generated! Use specApplyExprMaybe
-- if you want to ensure that it exists.
specApplyExpr :: ApplySpec -> JExpr
specApplyExpr :: ApplySpec -> JExpr
specApplyExpr ApplySpec
spec = FastString -> JExpr
var (ApplySpec -> FastString
specApplyName ApplySpec
spec)

-- | Return the expression of the specialized apply function for the given
-- number of args, number of arg variables, and calling convention.
-- Return Nothing if it isn't generated.
specApplyExprMaybe :: ApplySpec -> Maybe JExpr
specApplyExprMaybe :: ApplySpec -> Maybe JExpr
specApplyExprMaybe ApplySpec
spec =
  if ApplySpec
spec forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ApplySpec]
applySpec
    then forall a. a -> Maybe a
Just (ApplySpec -> JExpr
specApplyExpr ApplySpec
spec)
    else forall a. Maybe a
Nothing

-- | Make an ApplySpec from a calling convention, a list of Haskell args, and a
-- list of corresponding JS variables
mkApplySpec :: ApplyConv -> [StgArg] -> [JExpr] -> ApplySpec
mkApplySpec :: ApplyConv -> [StgArg] -> [JExpr] -> ApplySpec
mkApplySpec ApplyConv
conv [StgArg]
args [JExpr]
vars = ApplySpec
  { specConv :: ApplyConv
specConv = ApplyConv
conv
  , specArgs :: Int
specArgs = forall (t :: * -> *) a. Foldable t => t a -> Int
length [StgArg]
args
  , specVars :: Int
specVars = forall (t :: * -> *) a. Foldable t => t a -> Int
length [JExpr]
vars
  }

-- | Find a specialized application function if there is one
selectApply
  :: ApplySpec
  -> G (Either JExpr JExpr) -- ^ the function to call (Left for generic, Right for specialized)
selectApply :: ApplySpec -> G (Either JExpr JExpr)
selectApply ApplySpec
spec =
  case ApplySpec -> Maybe JExpr
specApplyExprMaybe ApplySpec
spec of
    Just JExpr
e  -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right JExpr
e)
    Maybe JExpr
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left (ApplyConv -> JExpr
genericApplyExpr (ApplySpec -> ApplyConv
specConv ApplySpec
spec)))


-- | Apply specification
data ApplySpec = ApplySpec
  { ApplySpec -> ApplyConv
specConv :: !ApplyConv -- ^ Calling convention
  , ApplySpec -> Int
specArgs :: !Int       -- ^ number of Haskell arguments
  , ApplySpec -> Int
specVars :: !Int       -- ^ number of JavaScript variables for the arguments
  }
  deriving (Int -> ApplySpec -> ShowS
[ApplySpec] -> ShowS
ApplySpec -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [ApplySpec] -> ShowS
$cshowList :: [ApplySpec] -> ShowS
show :: ApplySpec -> [Char]
$cshow :: ApplySpec -> [Char]
showsPrec :: Int -> ApplySpec -> ShowS
$cshowsPrec :: Int -> ApplySpec -> ShowS
Show,ApplySpec -> ApplySpec -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ApplySpec -> ApplySpec -> Bool
$c/= :: ApplySpec -> ApplySpec -> Bool
== :: ApplySpec -> ApplySpec -> Bool
$c== :: ApplySpec -> ApplySpec -> Bool
Eq,Eq ApplySpec
ApplySpec -> ApplySpec -> Bool
ApplySpec -> ApplySpec -> Ordering
ApplySpec -> ApplySpec -> ApplySpec
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ApplySpec -> ApplySpec -> ApplySpec
$cmin :: ApplySpec -> ApplySpec -> ApplySpec
max :: ApplySpec -> ApplySpec -> ApplySpec
$cmax :: ApplySpec -> ApplySpec -> ApplySpec
>= :: ApplySpec -> ApplySpec -> Bool
$c>= :: ApplySpec -> ApplySpec -> Bool
> :: ApplySpec -> ApplySpec -> Bool
$c> :: ApplySpec -> ApplySpec -> Bool
<= :: ApplySpec -> ApplySpec -> Bool
$c<= :: ApplySpec -> ApplySpec -> Bool
< :: ApplySpec -> ApplySpec -> Bool
$c< :: ApplySpec -> ApplySpec -> Bool
compare :: ApplySpec -> ApplySpec -> Ordering
$ccompare :: ApplySpec -> ApplySpec -> Ordering
Ord)

-- | List of specialized apply function templates
applySpec :: [ApplySpec]
applySpec :: [ApplySpec]
applySpec = [ ApplyConv -> Int -> Int -> ApplySpec
ApplySpec ApplyConv
conv Int
nargs Int
nvars
            | ApplyConv
conv  <- [ApplyConv
RegsConv, ApplyConv
StackConv]
            , Int
nargs <- [Int
0..Int
4]
            , Int
nvars <- [forall a. Ord a => a -> a -> a
max Int
0 (Int
nargsforall a. Num a => a -> a -> a
-Int
1)..(Int
nargsforall a. Num a => a -> a -> a
*Int
2)]
            ]

-- | Generate a tag for the given ApplySpec
--
-- Warning: tag doesn't take into account the calling convention
specTag :: ApplySpec -> Int
specTag :: ApplySpec -> Int
specTag ApplySpec
spec = forall a. Bits a => a -> Int -> a
Bits.shiftL (ApplySpec -> Int
specVars ApplySpec
spec) Int
8 forall a. Bits a => a -> a -> a
Bits..|. (ApplySpec -> Int
specArgs ApplySpec
spec)

-- | Generate a tag expression for the given ApplySpec
specTagExpr :: ApplySpec -> JExpr
specTagExpr :: ApplySpec -> JExpr
specTagExpr = forall a. ToJExpr a => a -> JExpr
toJExpr forall b c a. (b -> c) -> (a -> b) -> a -> c
. ApplySpec -> Int
specTag

-- | Build arrays to quickly lookup apply functions
--
--  h$apply[r << 8 | n] = function application for r regs, n args
--  h$paps[r]           = partial application for r registers (number of args is in the object)
mkApplyArr :: JStat
mkApplyArr :: JStat
mkApplyArr = forall a. Monoid a => [a] -> a
mconcat
  [ FastString -> Ident
TxtI FastString
"h$apply" Ident -> JExpr -> JStat
||= forall a. ToJExpr a => a -> JExpr
toJExpr ([JExpr] -> JVal
JList [])
  , FastString -> Ident
TxtI FastString
"h$paps"  Ident -> JExpr -> JStat
||= forall a. ToJExpr a => a -> JExpr
toJExpr ([JExpr] -> JVal
JList [])
  , JExpr -> [JExpr] -> JStat
ApplStat (FastString -> JExpr
var FastString
"h$initStatic" JExpr -> FastString -> JExpr
.^ FastString
"push")
    [ JVal -> JExpr
ValExpr forall a b. (a -> b) -> a -> b
$ [Ident] -> JStat -> JVal
JFunc [] forall a b. (a -> b) -> a -> b
$ forall a. ToSat a => a -> JStat
jVar \JExpr
i -> forall a. Monoid a => [a] -> a
mconcat
        [ JExpr
i JExpr -> JExpr -> JStat
|= JExpr
zero_
        , Bool -> JExpr -> JStat -> JStat
WhileStat Bool
False (JExpr
i JExpr -> JExpr -> JExpr
.<. Integer -> JExpr
Int Integer
65536) forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat
            [ FastString -> JExpr
var FastString
"h$apply" JExpr -> JExpr -> JExpr
.! JExpr
i JExpr -> JExpr -> JStat
|= FastString -> JExpr
var FastString
"h$ap_gen"
            , JExpr -> JStat
preIncrS JExpr
i
            ]
        , JExpr
i JExpr -> JExpr -> JStat
|= JExpr
zero_
        , Bool -> JExpr -> JStat -> JStat
WhileStat Bool
False (JExpr
i JExpr -> JExpr -> JExpr
.<. Integer -> JExpr
Int Integer
128) forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat
            [ FastString -> JExpr
var FastString
"h$paps" JExpr -> JExpr -> JExpr
.! JExpr
i JExpr -> JExpr -> JStat
|= FastString -> JExpr
var FastString
"h$pap_gen"
            , JExpr -> JStat
preIncrS JExpr
i
            ]
        , forall a. Monoid a => [a] -> a
mconcat (forall a b. (a -> b) -> [a] -> [b]
map ApplySpec -> JStat
assignSpec [ApplySpec]
applySpec)
        , forall a. Monoid a => [a] -> a
mconcat (forall a b. (a -> b) -> [a] -> [b]
map Int -> JStat
assignPap [Int]
specPap)
        ]
    ]
  ]
  where
    assignSpec :: ApplySpec -> JStat
    assignSpec :: ApplySpec -> JStat
assignSpec ApplySpec
spec = case ApplySpec -> ApplyConv
specConv ApplySpec
spec of
      -- both fast/slow (regs/stack) specialized apply functions have the same
      -- tags. We store the stack ones in the array because they are used as
      -- continuation stack frames.
      ApplyConv
StackConv -> FastString -> JExpr
var FastString
"h$apply" JExpr -> JExpr -> JExpr
.! ApplySpec -> JExpr
specTagExpr ApplySpec
spec JExpr -> JExpr -> JStat
|= ApplySpec -> JExpr
specApplyExpr ApplySpec
spec
      ApplyConv
RegsConv  -> forall a. Monoid a => a
mempty

    assignPap :: Int -> JStat
    assignPap :: Int -> JStat
assignPap Int
p = FastString -> JExpr
var FastString
"h$paps" JExpr -> JExpr -> JExpr
.! forall a. ToJExpr a => a -> JExpr
toJExpr Int
p JExpr -> JExpr -> JStat
|=
                      (FastString -> JExpr
var ([Char] -> FastString
mkFastString forall a b. (a -> b) -> a -> b
$ ([Char]
"h$pap_" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int
p)))

-- | Push a continuation on the stack
--
-- First push the given args, then push an apply function (specialized if
-- possible, otherwise the generic h$ap_gen function).
pushCont :: HasDebugCallStack
         => [StgArg]
         -> G JStat
pushCont :: HasDebugCallStack => [StgArg] -> G JStat
pushCont [StgArg]
args = do
  [JExpr]
vars <- forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Traversable f) =>
(a -> m [b]) -> f a -> m [b]
concatMapM HasDebugCallStack => StgArg -> G [JExpr]
genArg [StgArg]
args
  let spec :: ApplySpec
spec = ApplyConv -> [StgArg] -> [JExpr] -> ApplySpec
mkApplySpec ApplyConv
StackConv [StgArg]
args [JExpr]
vars
  ApplySpec -> G (Either JExpr JExpr)
selectApply ApplySpec
spec forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Right JExpr
app -> [JExpr] -> G JStat
push forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ JExpr
app forall a. a -> [a] -> [a]
: [JExpr]
vars
    Left  JExpr
app -> [JExpr] -> G JStat
push forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ JExpr
app forall a. a -> [a] -> [a]
: ApplySpec -> JExpr
specTagExpr ApplySpec
spec forall a. a -> [a] -> [a]
: [JExpr]
vars

-- | Generic stack apply function (h$ap_gen) that can do everything, but less
-- efficiently than other more specialized functions.
--
-- Stack layout:
--  -3: ...
--  -2: args
--  -1: tag (number of arg slots << 8 | number of args)
--
-- Regs:
--  R1 = applied closure
--
genericStackApply :: StgToJSConfig -> JStat
genericStackApply :: StgToJSConfig -> JStat
genericStackApply StgToJSConfig
cfg = ClosureInfo -> JStat -> JStat
closure ClosureInfo
info JStat
body
  where
    -- h$ap_gen body
    body :: JStat
body = forall a. ToSat a => a -> JStat
jVar \JExpr
cf ->
      [ StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
cfg (FastString -> JExpr
jString FastString
"h$ap_gen")
      , JExpr
cf JExpr -> JExpr -> JStat
|= JExpr -> JExpr
closureEntry JExpr
r1
        -- switch on closure type
      , JExpr -> [(JExpr, JStat)] -> JStat -> JStat
SwitchStat (JExpr -> JExpr
entryClosureType JExpr
cf)
        [ (forall a. ToJExpr a => a -> JExpr
toJExpr ClosureType
Thunk    , StgToJSConfig -> JExpr -> JStat
thunk_case StgToJSConfig
cfg JExpr
cf)
        , (forall a. ToJExpr a => a -> JExpr
toJExpr ClosureType
Fun      , JExpr -> JExpr -> JStat
fun_case JExpr
cf (JExpr -> JExpr
funArity' JExpr
cf))
        , (forall a. ToJExpr a => a -> JExpr
toJExpr ClosureType
Pap      , JExpr -> JExpr -> JStat
fun_case JExpr
cf (JExpr -> JExpr
papArity JExpr
r1))
        , (forall a. ToJExpr a => a -> JExpr
toJExpr ClosureType
Blackhole, StgToJSConfig -> JStat
blackhole_case StgToJSConfig
cfg)
        ]
        (JExpr -> JStat
default_case JExpr
cf)
      ]

    -- info table for h$ap_gen
    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] -- closure to apply to
      , ciName :: FastString
ciName    = FastString
"h$ap_gen"
      , ciLayout :: CILayout
ciLayout  = CILayout
CILayoutVariable
      , ciType :: CIType
ciType    = CIType
CIStackFrame
      , ciStatic :: CIStatic
ciStatic  = forall a. Monoid a => a
mempty
      }

    default_case :: JExpr -> JStat
default_case JExpr
cf = FastString -> [JExpr] -> JStat
appS FastString
"throw" [FastString -> JExpr
jString FastString
"h$ap_gen: unexpected closure type "
                                    forall a. Num a => a -> a -> a
+ (JExpr -> JExpr
entryClosureType JExpr
cf)]

    thunk_case :: StgToJSConfig -> JExpr -> JStat
thunk_case StgToJSConfig
cfg JExpr
cf = forall a. Monoid a => [a] -> a
mconcat
      [ StgToJSConfig -> JStat -> JStat
profStat StgToJSConfig
cfg JStat
pushRestoreCCS
      , JExpr -> JStat
returnS JExpr
cf
      ]

    blackhole_case :: StgToJSConfig -> JStat
blackhole_case StgToJSConfig
cfg = forall a. Monoid a => [a] -> a
mconcat
      [ StgToJSConfig -> [JExpr] -> JStat
push' StgToJSConfig
cfg [JExpr
r1, FastString -> JExpr
var FastString
"h$return"]
      , JExpr -> JStat
returnS (FastString -> [JExpr] -> JExpr
app FastString
"h$blockOnBlackhole" [JExpr
r1])
      ]

    fun_case :: JExpr -> JExpr -> JStat
fun_case JExpr
c JExpr
arity = forall a. ToSat a => a -> JStat
jVar \JExpr
tag JExpr
needed_args JExpr
needed_regs JExpr
given_args JExpr
given_regs JExpr
newTag JExpr
newAp JExpr
p JExpr
dat ->
      [ JExpr
tag         JExpr -> JExpr -> JStat
|= JExpr
stack JExpr -> JExpr -> JExpr
.! (JExpr
sp forall a. Num a => a -> a -> a
- JExpr
1) -- tag on the stack
      , JExpr
given_args  JExpr -> JExpr -> JStat
|= JExpr -> JExpr
mask8 JExpr
tag         -- indicates the number of passed args
      , JExpr
given_regs  JExpr -> JExpr -> JStat
|= JExpr
tag JExpr -> JExpr -> JExpr
.>>. JExpr
8        -- and the number of passed values for registers
      , JExpr
needed_args JExpr -> JExpr -> JStat
|= JExpr -> JExpr
mask8 JExpr
arity
      , JExpr
needed_regs JExpr -> JExpr -> JStat
|= JExpr
arity JExpr -> JExpr -> JExpr
.>>. JExpr
8
      , StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
cfg (FastString -> JExpr
jString FastString
"h$ap_gen: args: " forall a. Num a => a -> a -> a
+ JExpr
given_args
                    forall a. Num a => a -> a -> a
+ FastString -> JExpr
jString FastString
" regs: " forall a. Num a => a -> a -> a
+ JExpr
given_regs)
      , JExpr -> [JStat] -> [JStat] -> JStat
ifBlockS (JExpr
given_args JExpr -> JExpr -> JExpr
.===. JExpr
needed_args)
        --------------------------------
        -- exactly saturated application
        --------------------------------
        [ StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
cfg (FastString -> JExpr
jString FastString
"h$ap_gen: exact")
        -- Set registers to register values on the stack
        , JExpr -> (JExpr -> JExpr) -> (JExpr -> JStat) -> JStat
loop JExpr
0 (JExpr -> JExpr -> JExpr
.<. JExpr
given_regs) \JExpr
i -> forall a. Monoid a => [a] -> a
mconcat
            [ FastString -> [JExpr] -> JStat
appS FastString
"h$setReg" [JExpr
iforall a. Num a => a -> a -> a
+JExpr
2, JExpr
stack JExpr -> JExpr -> JExpr
.! (JExpr
spforall a. Num a => a -> a -> a
-JExpr
2forall a. Num a => a -> a -> a
-JExpr
i)]
            , JExpr -> JStat
postIncrS JExpr
i
            ]
        -- drop register values from the stack
        , JExpr
sp JExpr -> JExpr -> JStat
|= JExpr
sp forall a. Num a => a -> a -> a
- JExpr
given_regs forall a. Num a => a -> a -> a
- JExpr
2
        -- enter closure in R1
        , JExpr -> JStat
returnS JExpr
c
        ]
        [ JExpr -> [JStat] -> [JStat] -> JStat
ifBlockS (JExpr
given_args JExpr -> JExpr -> JExpr
.>. JExpr
needed_args)
            ----------------------------
            -- oversaturated application
            ----------------------------
            [ StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
cfg (FastString -> JExpr
jString FastString
"h$ap_gen: oversat: arity: " forall a. Num a => a -> a -> a
+ JExpr
needed_args
                          forall a. Num a => a -> a -> a
+ FastString -> JExpr
jString FastString
" regs: " forall a. Num a => a -> a -> a
+ JExpr
needed_regs)
            -- load needed register values
            , JExpr -> (JExpr -> JExpr) -> (JExpr -> JStat) -> JStat
loop JExpr
0 (JExpr -> JExpr -> JExpr
.<. JExpr
needed_regs) \JExpr
i -> forall a. Monoid a => [a] -> a
mconcat
                [ StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
cfg (FastString -> JExpr
jString FastString
"h$ap_gen: loading register: " forall a. Num a => a -> a -> a
+ JExpr
i)
                , FastString -> [JExpr] -> JStat
appS FastString
"h$setReg" [JExpr
iforall a. Num a => a -> a -> a
+JExpr
2, JExpr
stack JExpr -> JExpr -> JExpr
.! (JExpr
spforall a. Num a => a -> a -> a
-JExpr
2forall a. Num a => a -> a -> a
-JExpr
i)]
                , JExpr -> JStat
postIncrS JExpr
i
                ]
            -- compute new tag with consumed register values and args removed
            , JExpr
newTag JExpr -> JExpr -> JStat
|= ((JExpr
given_regsforall a. Num a => a -> a -> a
-JExpr
needed_regs)JExpr -> JExpr -> JExpr
.<<.JExpr
8) JExpr -> JExpr -> JExpr
.|. (JExpr
given_args forall a. Num a => a -> a -> a
- JExpr
needed_args)
            -- find application function for the remaining regs/args
            , JExpr
newAp JExpr -> JExpr -> JStat
|= FastString -> JExpr
var FastString
"h$apply" JExpr -> JExpr -> JExpr
.! JExpr
newTag
            , StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
cfg (FastString -> JExpr
jString FastString
"h$ap_gen: next: " forall a. Num a => a -> a -> a
+ (JExpr
newAp JExpr -> FastString -> JExpr
.^ FastString
"n"))

            -- Drop used registers from the stack.
            -- Test if the application function needs a tag and push it.
            , JExpr -> JStat -> JStat -> JStat
ifS (JExpr
newAp JExpr -> JExpr -> JExpr
.===. FastString -> JExpr
var FastString
"h$ap_gen")
                   ((JExpr
sp JExpr -> JExpr -> JStat
|= JExpr
sp forall a. Num a => a -> a -> a
- JExpr
needed_regs) forall a. Semigroup a => a -> a -> a
<> (JExpr
stack JExpr -> JExpr -> JExpr
.! (JExpr
sp forall a. Num a => a -> a -> a
- JExpr
1) JExpr -> JExpr -> JStat
|= JExpr
newTag))
                   (JExpr
sp JExpr -> JExpr -> JStat
|= JExpr
sp forall a. Num a => a -> a -> a
- JExpr
needed_regs forall a. Num a => a -> a -> a
- JExpr
1)

            -- Push generic application function as continuation
            , JExpr
stack JExpr -> JExpr -> JExpr
.! JExpr
sp JExpr -> JExpr -> JStat
|= JExpr
newAp

            -- Push "current thread CCS restore" function as continuation
            , StgToJSConfig -> JStat -> JStat
profStat StgToJSConfig
cfg JStat
pushRestoreCCS

            -- enter closure in R1
            , JExpr -> JStat
returnS JExpr
c
            ]

            -----------------------------
            -- undersaturated application
            -----------------------------
            [ StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
cfg (FastString -> JExpr
jString FastString
"h$ap_gen: undersat")
            -- find PAP entry function corresponding to given_regs count
            , JExpr
p      JExpr -> JExpr -> JStat
|= FastString -> JExpr
var FastString
"h$paps" JExpr -> JExpr -> JExpr
.! JExpr
given_regs

            -- build PAP payload: R1 + tag + given register values
            , JExpr
newTag JExpr -> JExpr -> JStat
|= ((JExpr
needed_regsforall a. Num a => a -> a -> a
-JExpr
given_regs) JExpr -> JExpr -> JExpr
.<<. JExpr
8) JExpr -> JExpr -> JExpr
.|. (JExpr
needed_argsforall a. Num a => a -> a -> a
-JExpr
given_args)
            , JExpr
dat    JExpr -> JExpr -> JStat
|= forall a. ToJExpr a => a -> JExpr
toJExpr [JExpr
r1, JExpr
newTag]
            , JExpr -> (JExpr -> JExpr) -> (JExpr -> JStat) -> JStat
loop JExpr
0 (JExpr -> JExpr -> JExpr
.<. JExpr
given_regs) \JExpr
i -> forall a. Monoid a => [a] -> a
mconcat
                [ (JExpr
dat JExpr -> FastString -> JExpr
.^ FastString
"push") JExpr -> [JExpr] -> JStat
`ApplStat` [JExpr
stack JExpr -> JExpr -> JExpr
.! (JExpr
sp forall a. Num a => a -> a -> a
- JExpr
i forall a. Num a => a -> a -> a
- JExpr
2)]
                , JExpr -> JStat
postIncrS JExpr
i
                ]

            -- remove register values from the stack.
            , JExpr
sp  JExpr -> JExpr -> JStat
|= JExpr
sp forall a. Num a => a -> a -> a
- JExpr
given_regs forall a. Num a => a -> a -> a
- JExpr
2

            -- alloc PAP closure, store reference to it in R1.
            , JExpr
r1  JExpr -> JExpr -> JStat
|= StgToJSConfig -> JExpr -> JExpr -> JExpr -> JExpr
initClosure StgToJSConfig
cfg JExpr
p JExpr
dat JExpr
jCurrentCCS

            -- return to the continuation on the stack
            , JStat
returnStack
            ]
        ]
      ]

-- | Generic fast apply function (h$ap_gen_fast) that can do everything, but less
-- efficiently than other more specialized functions.
--
-- Signature tag in argument. Tag: (regs << 8 | arity)
--
-- Regs:
--  R1 = closure to apply to
--
genericFastApply :: StgToJSConfig -> JStat
genericFastApply :: StgToJSConfig -> JStat
genericFastApply StgToJSConfig
s =
   FastString -> Ident
TxtI FastString
"h$ap_gen_fast" Ident -> JExpr -> JStat
||= forall a. ToSat a => a -> JExpr
jLam \JExpr
tag -> forall a. ToSat a => a -> JStat
jVar \JExpr
c ->
      [StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (FastString -> JExpr
jString FastString
"h$ap_gen_fast: " forall a. Num a => a -> a -> a
+ JExpr
tag)
      , JExpr
c JExpr -> JExpr -> JStat
|= JExpr -> JExpr
closureEntry JExpr
r1
      , JExpr -> [(JExpr, JStat)] -> JStat -> JStat
SwitchStat (JExpr -> JExpr
entryClosureType JExpr
c)
        [ (forall a. ToJExpr a => a -> JExpr
toJExpr ClosureType
Thunk, StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (FastString -> JExpr
jString FastString
"h$ap_gen_fast: thunk")
           forall a. Semigroup a => a -> a -> a
<> JExpr -> JExpr -> JStat
pushStackApply JExpr
c JExpr
tag
           forall a. Semigroup a => a -> a -> a
<> JExpr -> JStat
returnS JExpr
c)
        , (forall a. ToJExpr a => a -> JExpr
toJExpr ClosureType
Fun, forall a. ToSat a => a -> JStat
jVar \JExpr
farity ->
                               [ JExpr
farity JExpr -> JExpr -> JStat
|= JExpr -> JExpr
funArity' JExpr
c
                               , StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (FastString -> JExpr
jString FastString
"h$ap_gen_fast: fun " forall a. Num a => a -> a -> a
+ JExpr
farity)
                               , JExpr -> JExpr -> JExpr -> JStat
funCase JExpr
c JExpr
tag JExpr
farity
                               ])
        , (forall a. ToJExpr a => a -> JExpr
toJExpr ClosureType
Pap, forall a. ToSat a => a -> JStat
jVar \JExpr
parity ->
                               [ JExpr
parity JExpr -> JExpr -> JStat
|= JExpr -> JExpr
papArity JExpr
r1
                               , StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (FastString -> JExpr
jString FastString
"h$ap_gen_fast: pap " forall a. Num a => a -> a -> a
+ JExpr
parity)
                               , JExpr -> JExpr -> JExpr -> JStat
funCase JExpr
c JExpr
tag JExpr
parity
                               ])
        , (forall a. ToJExpr a => a -> JExpr
toJExpr ClosureType
Con, StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (FastString -> JExpr
jString FastString
"h$ap_gen_fast: con")
            forall a. Semigroup a => a -> a -> a
<> JExpr -> JStat -> JStat
jwhenS (JExpr
tag JExpr -> JExpr -> JExpr
.!=. JExpr
0)
                (FastString -> [JExpr] -> JStat
appS FastString
"throw" [FastString -> JExpr
jString FastString
"h$ap_gen_fast: invalid apply"])
                        forall a. Semigroup a => a -> a -> a
<> JExpr -> JStat
returnS JExpr
c)
        , (forall a. ToJExpr a => a -> JExpr
toJExpr ClosureType
Blackhole, StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (FastString -> JExpr
jString FastString
"h$ap_gen_fast: blackhole")
            forall a. Semigroup a => a -> a -> a
<> JExpr -> JExpr -> JStat
pushStackApply JExpr
c JExpr
tag
            forall a. Semigroup a => a -> a -> a
<> StgToJSConfig -> [JExpr] -> JStat
push' StgToJSConfig
s [JExpr
r1, FastString -> JExpr
var FastString
"h$return"]
            forall a. Semigroup a => a -> a -> a
<> JExpr -> JStat
returnS (FastString -> [JExpr] -> JExpr
app FastString
"h$blockOnBlackhole" [JExpr
r1]))
        ] forall a b. (a -> b) -> a -> b
$ FastString -> [JExpr] -> JStat
appS FastString
"throw" [FastString -> JExpr
jString FastString
"h$ap_gen_fast: unexpected closure type: " forall a. Num a => a -> a -> a
+ JExpr -> JExpr
entryClosureType JExpr
c]
      ]

  where
     -- thunk: push everything to stack frame, enter thunk first
    pushStackApply :: JExpr -> JExpr -> JStat
    pushStackApply :: JExpr -> JExpr -> JStat
pushStackApply JExpr
_c JExpr
tag =
      forall a. ToSat a => a -> JStat
jVar \JExpr
ap ->
        [ JExpr -> JStat
pushAllRegs JExpr
tag
        , JExpr
ap JExpr -> JExpr -> JStat
|= FastString -> JExpr
var FastString
"h$apply" JExpr -> JExpr -> JExpr
.! JExpr
tag
        , JExpr -> JStat -> JStat -> JStat
ifS (JExpr
ap JExpr -> JExpr -> JExpr
.===. FastString -> JExpr
var FastString
"h$ap_gen")
                ((JExpr
sp JExpr -> JExpr -> JStat
|= JExpr
sp forall a. Num a => a -> a -> a
+ JExpr
2) forall a. Semigroup a => a -> a -> a
<> (JExpr
stack JExpr -> JExpr -> JExpr
.! (JExpr
spforall a. Num a => a -> a -> a
-JExpr
1) JExpr -> JExpr -> JStat
|= JExpr
tag))
                (JExpr
sp JExpr -> JExpr -> JStat
|= JExpr
sp forall a. Num a => a -> a -> a
+ JExpr
1)
        , JExpr
stack JExpr -> JExpr -> JExpr
.! JExpr
sp JExpr -> JExpr -> JStat
|= JExpr
ap
        , StgToJSConfig -> JStat -> JStat
profStat StgToJSConfig
s JStat
pushRestoreCCS
        ]

    funCase :: JExpr -> JExpr -> JExpr -> JStat
    funCase :: JExpr -> JExpr -> JExpr -> JStat
funCase JExpr
c JExpr
tag JExpr
arity =
      forall a. ToSat a => a -> JStat
jVar \JExpr
ar JExpr
myAr JExpr
myRegs JExpr
regsStart JExpr
newTag JExpr
newAp JExpr
dat JExpr
p ->
        [ JExpr
ar     JExpr -> JExpr -> JStat
|= JExpr -> JExpr
mask8 JExpr
arity
        , JExpr
myAr   JExpr -> JExpr -> JStat
|= JExpr -> JExpr
mask8 JExpr
tag
        , JExpr
myRegs JExpr -> JExpr -> JStat
|= JExpr
tag JExpr -> JExpr -> JExpr
.>>. JExpr
8
        , StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (FastString -> JExpr
jString FastString
"h$ap_gen_fast: args: " forall a. Num a => a -> a -> a
+ JExpr
myAr
                      forall a. Num a => a -> a -> a
+ FastString -> JExpr
jString FastString
" regs: "             forall a. Num a => a -> a -> a
+ JExpr
myRegs)
        , JExpr -> JStat -> JStat -> JStat
ifS (JExpr
myAr JExpr -> JExpr -> JExpr
.===. JExpr
ar)
        -- call the function directly
          (StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (FastString -> JExpr
jString FastString
"h$ap_gen_fast: exact") forall a. Semigroup a => a -> a -> a
<> JExpr -> JStat
returnS JExpr
c)
          (JExpr -> [JStat] -> [JStat] -> JStat
ifBlockS (JExpr
myAr JExpr -> JExpr -> JExpr
.>. JExpr
ar)
          -- push stack frame with remaining args, then call fun
           [ StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (FastString -> JExpr
jString FastString
"h$ap_gen_fast: oversat " forall a. Num a => a -> a -> a
+ JExpr
sp)
           , JExpr
regsStart JExpr -> JExpr -> JStat
|= (JExpr
arity JExpr -> JExpr -> JExpr
.>>. JExpr
8) forall a. Num a => a -> a -> a
+ JExpr
1
           , JExpr
sp JExpr -> JExpr -> JStat
|= JExpr
sp forall a. Num a => a -> a -> a
+ JExpr
myRegs forall a. Num a => a -> a -> a
- JExpr
regsStart forall a. Num a => a -> a -> a
+ JExpr
1
           , StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (FastString -> JExpr
jString FastString
"h$ap_gen_fast: oversat " forall a. Num a => a -> a -> a
+ JExpr
sp)
           , JExpr -> JExpr -> JStat
pushArgs JExpr
regsStart JExpr
myRegs
           , JExpr
newTag JExpr -> JExpr -> JStat
|= ((JExpr
myRegsforall a. Num a => a -> a -> a
-( JExpr
arityJExpr -> JExpr -> JExpr
.>>.JExpr
8))JExpr -> JExpr -> JExpr
.<<.JExpr
8)JExpr -> JExpr -> JExpr
.|.JExpr
myArforall a. Num a => a -> a -> a
-JExpr
ar
           , JExpr
newAp JExpr -> JExpr -> JStat
|= FastString -> JExpr
var FastString
"h$apply" JExpr -> JExpr -> JExpr
.! JExpr
newTag
           , JExpr -> JStat -> JStat -> JStat
ifS (JExpr
newAp JExpr -> JExpr -> JExpr
.===. FastString -> JExpr
var FastString
"h$ap_gen")
                 ((JExpr
sp JExpr -> JExpr -> JStat
|= JExpr
sp forall a. Num a => a -> a -> a
+ JExpr
2) forall a. Semigroup a => a -> a -> a
<> (JExpr
stack JExpr -> JExpr -> JExpr
.! (JExpr
sp forall a. Num a => a -> a -> a
- JExpr
1) JExpr -> JExpr -> JStat
|= JExpr
newTag))
                 (JExpr
sp JExpr -> JExpr -> JStat
|= JExpr
sp forall a. Num a => a -> a -> a
+ JExpr
1)
           , JExpr
stack JExpr -> JExpr -> JExpr
.! JExpr
sp JExpr -> JExpr -> JStat
|= JExpr
newAp
           , StgToJSConfig -> JStat -> JStat
profStat StgToJSConfig
s JStat
pushRestoreCCS
           , JExpr -> JStat
returnS JExpr
c
           ]
          -- else
           [StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (FastString -> JExpr
jString FastString
"h$ap_gen_fast: undersat: " forall a. Num a => a -> a -> a
+ JExpr
myRegs forall a. Num a => a -> a -> a
+ FastString -> JExpr
jString FastString
" " forall a. Num a => a -> a -> a
+ JExpr
tag)
           , JExpr -> JStat -> JStat
jwhenS (JExpr
tag JExpr -> JExpr -> JExpr
.!=. JExpr
0) forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat
               [ JExpr
p JExpr -> JExpr -> JStat
|= FastString -> JExpr
var FastString
"h$paps" JExpr -> JExpr -> JExpr
.! JExpr
myRegs
               , JExpr
dat JExpr -> JExpr -> JStat
|= forall a. ToJExpr a => a -> JExpr
toJExpr [JExpr
r1, ((JExpr
arity JExpr -> JExpr -> JExpr
.>>. JExpr
8)forall a. Num a => a -> a -> a
-JExpr
myRegs)forall a. Num a => a -> a -> a
*JExpr
256forall a. Num a => a -> a -> a
+JExpr
arforall a. Num a => a -> a -> a
-JExpr
myAr]
               , JExpr -> (JExpr -> JExpr) -> (JExpr -> JStat) -> JStat
loop JExpr
0 (JExpr -> JExpr -> JExpr
.<. JExpr
myRegs)
                 (\JExpr
i -> (JExpr
dat JExpr -> FastString -> JExpr
.^ FastString
"push")
                   JExpr -> [JExpr] -> JStat
`ApplStat` [FastString -> [JExpr] -> JExpr
app FastString
"h$getReg" [JExpr
iforall a. Num a => a -> a -> a
+JExpr
2]] forall a. Semigroup a => a -> a -> a
<> JExpr -> JStat
postIncrS JExpr
i)
               , JExpr
r1 JExpr -> JExpr -> JStat
|= StgToJSConfig -> JExpr -> JExpr -> JExpr -> JExpr
initClosure StgToJSConfig
s JExpr
p JExpr
dat JExpr
jCurrentCCS
               ]
           , JStat
returnStack
           ])
        ]


    pushAllRegs :: JExpr -> JStat
    pushAllRegs :: JExpr -> JStat
pushAllRegs JExpr
tag =
      forall a. ToSat a => a -> JStat
jVar \JExpr
regs ->
        [ JExpr
regs JExpr -> JExpr -> JStat
|= JExpr
tag JExpr -> JExpr -> JExpr
.>>. JExpr
8
        , JExpr
sp JExpr -> JExpr -> JStat
|= JExpr
sp forall a. Num a => a -> a -> a
+ JExpr
regs
        , JExpr -> [(JExpr, JStat)] -> JStat -> JStat
SwitchStat JExpr
regs (forall a b. (a -> b) -> [a] -> [b]
map Int -> (JExpr, JStat)
pushReg [Int
65,Int
64..Int
2]) forall a. Monoid a => a
mempty
        ]
      where
        pushReg :: Int -> (JExpr, JStat)
        pushReg :: Int -> (JExpr, JStat)
pushReg Int
r = (forall a. ToJExpr a => a -> JExpr
toJExpr (Int
rforall a. Num a => a -> a -> a
-Int
1),  JExpr
stack JExpr -> JExpr -> JExpr
.! (JExpr
sp forall a. Num a => a -> a -> a
- forall a. ToJExpr a => a -> JExpr
toJExpr (Int
r forall a. Num a => a -> a -> a
- Int
2)) JExpr -> JExpr -> JStat
|= Int -> JExpr
jsReg Int
r)

    pushArgs :: JExpr -> JExpr -> JStat
    pushArgs :: JExpr -> JExpr -> JStat
pushArgs JExpr
start JExpr
end =
      JExpr -> (JExpr -> JExpr) -> (JExpr -> JStat) -> JStat
loop JExpr
end (JExpr -> JExpr -> JExpr
.>=.JExpr
start) (\JExpr
i -> StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (FastString -> JExpr
jString FastString
"pushing register: " forall a. Num a => a -> a -> a
+ JExpr
i)
                             forall a. Semigroup a => a -> a -> a
<> (JExpr
stack JExpr -> JExpr -> JExpr
.! (JExpr
sp forall a. Num a => a -> a -> a
+ JExpr
start forall a. Num a => a -> a -> a
- JExpr
i) JExpr -> JExpr -> JStat
|= FastString -> [JExpr] -> JExpr
app FastString
"h$getReg" [JExpr
iforall a. Num a => a -> a -> a
+JExpr
1])
                             forall a. Semigroup a => a -> a -> a
<> JExpr -> JStat
postDecrS JExpr
i
                           )

-- | Make specialized apply function for the given ApplySpec
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

-- | Make specialized apply function with Stack calling convention
stackApply
  :: StgToJSConfig
  -> FastString
  -> Int
  -> Int
  -> JStat
stackApply :: StgToJSConfig -> FastString -> Int -> Int -> JStat
stackApply StgToJSConfig
s FastString
fun_name Int
nargs Int
nvars =
  -- special case for h$ap_0_0
  if Int
nargs forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
&& Int
nvars forall a. Eq a => a -> a -> Bool
== Int
0
    then ClosureInfo -> JStat -> JStat
closure ClosureInfo
info0 JStat
body0
    else ClosureInfo -> JStat -> JStat
closure ClosureInfo
info JStat
body
  where
    info :: ClosureInfo
info  = Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo (FastString -> Ident
TxtI FastString
fun_name) (Int -> [VarType] -> CIRegs
CIRegs Int
0 [VarType
PtrV]) FastString
fun_name (Int -> CILayout
CILayoutUnknown Int
nvars) CIType
CIStackFrame forall a. Monoid a => a
mempty
    info0 :: ClosureInfo
info0 = Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo (FastString -> Ident
TxtI FastString
fun_name) (Int -> [VarType] -> CIRegs
CIRegs Int
0 [VarType
PtrV]) FastString
fun_name (Int -> [VarType] -> CILayout
CILayoutFixed Int
0 [])    CIType
CIStackFrame forall a. Monoid a => a
mempty

    body0 :: JStat
body0 = Int -> JStat
adjSpN' Int
1 forall a. Semigroup a => a -> a -> a
<> StgToJSConfig -> JExpr -> JStat
enter StgToJSConfig
s JExpr
r1

    body :: JStat
body = forall a. ToSat a => a -> JStat
jVar \JExpr
c ->
             [ JExpr
c JExpr -> JExpr -> JStat
|= JExpr -> JExpr
closureEntry JExpr
r1
             , StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (forall a. ToJExpr a => a -> JExpr
toJExpr FastString
fun_name
                           forall a. Num a => a -> a -> a
+ FastString -> JExpr
jString FastString
" "
                           forall a. Num a => a -> a -> a
+ (JExpr
c JExpr -> FastString -> JExpr
.^ FastString
"n")
                           forall a. Num a => a -> a -> a
+ FastString -> JExpr
jString FastString
" sp: " forall a. Num a => a -> a -> a
+ JExpr
sp
                           forall a. Num a => a -> a -> a
+ FastString -> JExpr
jString FastString
" a: "  forall a. Num a => a -> a -> a
+ (JExpr
c JExpr -> FastString -> JExpr
.^ FastString
"a"))
             , JExpr -> [(JExpr, JStat)] -> JStat -> JStat
SwitchStat (JExpr -> JExpr
entryClosureType JExpr
c)
               [ (forall a. ToJExpr a => a -> JExpr
toJExpr ClosureType
Thunk, StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (forall a. ToJExpr a => a -> JExpr
toJExpr forall a b. (a -> b) -> a -> b
$ FastString
fun_name forall a. Semigroup a => a -> a -> a
<> FastString
": thunk") forall a. Semigroup a => a -> a -> a
<> StgToJSConfig -> JStat -> JStat
profStat StgToJSConfig
s JStat
pushRestoreCCS forall a. Semigroup a => a -> a -> a
<> JExpr -> JStat
returnS JExpr
c)
               , (forall a. ToJExpr a => a -> JExpr
toJExpr ClosureType
Fun, StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (forall a. ToJExpr a => a -> JExpr
toJExpr forall a b. (a -> b) -> a -> b
$ FastString
fun_name forall a. Semigroup a => a -> a -> a
<> FastString
": fun") forall a. Semigroup a => a -> a -> a
<> JExpr -> JStat
funCase JExpr
c)
               , (forall a. ToJExpr a => a -> JExpr
toJExpr ClosureType
Pap, StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (forall a. ToJExpr a => a -> JExpr
toJExpr forall a b. (a -> b) -> a -> b
$ FastString
fun_name forall a. Semigroup a => a -> a -> a
<> FastString
": pap") forall a. Semigroup a => a -> a -> a
<> JExpr -> JStat
papCase JExpr
c)
               , (forall a. ToJExpr a => a -> JExpr
toJExpr ClosureType
Blackhole, StgToJSConfig -> [JExpr] -> JStat
push' StgToJSConfig
s [JExpr
r1, FastString -> JExpr
var FastString
"h$return"] forall a. Semigroup a => a -> a -> a
<> JExpr -> JStat
returnS (FastString -> [JExpr] -> JExpr
app FastString
"h$blockOnBlackhole" [JExpr
r1]))
               ] (FastString -> [JExpr] -> JStat
appS FastString
"throw" [forall a. ToJExpr a => a -> JExpr
toJExpr (FastString
"panic: " forall a. Semigroup a => a -> a -> a
<> FastString
fun_name forall a. Semigroup a => a -> a -> a
<> FastString
", unexpected closure type: ") forall a. Num a => a -> a -> a
+ (JExpr -> JExpr
entryClosureType JExpr
c)])
             ]

    funExact :: JExpr -> JStat
funExact JExpr
c = Int -> [JExpr] -> JStat
popSkip Int
1 (forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
take Int
nvars [JExpr]
jsRegsFromR2) forall a. Semigroup a => a -> a -> a
<> JExpr -> JStat
returnS JExpr
c
    stackArgs :: [JExpr]
stackArgs = forall a b. (a -> b) -> [a] -> [b]
map (\Int
x -> JExpr
stack JExpr -> JExpr -> JExpr
.! (JExpr
sp forall a. Num a => a -> a -> a
- forall a. ToJExpr a => a -> JExpr
toJExpr Int
x)) [Int
1..Int
nvars]

    papCase :: JExpr -> JStat
    papCase :: JExpr -> JStat
papCase JExpr
c = forall a. ToSat a => a -> JStat
jVar \JExpr
expr JExpr
arity0 JExpr
arity ->
      case JExpr
expr of
        ValExpr (JVar Ident
pap) -> [ JExpr
arity0 JExpr -> JExpr -> JStat
|= JExpr -> JExpr
papArity JExpr
r1
                              , JExpr
arity JExpr -> JExpr -> JStat
|= JExpr -> JExpr
mask8 JExpr
arity0
                              , StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (forall a. ToJExpr a => a -> JExpr
toJExpr (FastString
fun_name forall a. Semigroup a => a -> a -> a
<> FastString
": found pap, arity: ") forall a. Num a => a -> a -> a
+ JExpr
arity)
                              , JExpr -> JStat -> JStat -> JStat
ifS (forall a. ToJExpr a => a -> JExpr
toJExpr Int
nargs JExpr -> JExpr -> JExpr
.===. JExpr
arity)
                              --then
                                (StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (forall a. ToJExpr a => a -> JExpr
toJExpr (FastString
fun_name forall a. Semigroup a => a -> a -> a
<> FastString
": exact")) forall a. Semigroup a => a -> a -> a
<> JExpr -> JStat
funExact JExpr
c)
                              -- else
                                (JExpr -> JStat -> JStat -> JStat
ifS (forall a. ToJExpr a => a -> JExpr
toJExpr Int
nargs JExpr -> JExpr -> JExpr
.>. JExpr
arity)
                                  (StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (forall a. ToJExpr a => a -> JExpr
toJExpr (FastString
fun_name forall a. Semigroup a => a -> a -> a
<> FastString
": oversat")) forall a. Semigroup a => a -> a -> a
<> JExpr -> JExpr -> JExpr -> JStat
oversatCase JExpr
c JExpr
arity0 JExpr
arity)
                                  (StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (forall a. ToJExpr a => a -> JExpr
toJExpr (FastString
fun_name forall a. Semigroup a => a -> a -> a
<> FastString
": undersat"))
                                   forall a. Semigroup a => a -> a -> a
<> StgToJSConfig -> Ident -> JExpr -> JExpr -> [JExpr] -> JStat
mkPap StgToJSConfig
s Ident
pap JExpr
r1 (forall a. ToJExpr a => a -> JExpr
toJExpr Int
nargs) [JExpr]
stackArgs
                                   forall a. Semigroup a => a -> a -> a
<> (JExpr
sp JExpr -> JExpr -> JStat
|= JExpr
sp forall a. Num a => a -> a -> a
- forall a. ToJExpr a => a -> JExpr
toJExpr (Int
nvars forall a. Num a => a -> a -> a
+ Int
1))
                                   forall a. Semigroup a => a -> a -> a
<> (JExpr
r1 JExpr -> JExpr -> JStat
|= forall a. ToJExpr a => a -> JExpr
toJExpr Ident
pap)
                                   forall a. Semigroup a => a -> a -> a
<> JStat
returnStack))
                              ]
        JExpr
_                   -> forall a. Monoid a => a
mempty


    funCase :: JExpr -> JStat
    funCase :: JExpr -> JStat
funCase JExpr
c = forall a. ToSat a => a -> JStat
jVar \JExpr
expr JExpr
ar0 JExpr
ar ->
      case JExpr
expr of
        ValExpr (JVar Ident
pap) -> [ JExpr
ar0 JExpr -> JExpr -> JStat
|= JExpr -> JExpr
funArity' JExpr
c
                              , JExpr
ar JExpr -> JExpr -> JStat
|= JExpr -> JExpr
mask8 JExpr
ar0
                              , JExpr -> JStat -> JStat -> JStat
ifS (forall a. ToJExpr a => a -> JExpr
toJExpr Int
nargs JExpr -> JExpr -> JExpr
.===. JExpr
ar)
                                (StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (forall a. ToJExpr a => a -> JExpr
toJExpr (FastString
fun_name forall a. Semigroup a => a -> a -> a
<> FastString
": exact")) forall a. Semigroup a => a -> a -> a
<> JExpr -> JStat
funExact JExpr
c)
                                (JExpr -> JStat -> JStat -> JStat
ifS (forall a. ToJExpr a => a -> JExpr
toJExpr Int
nargs JExpr -> JExpr -> JExpr
.>. JExpr
ar)
                                 (StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (forall a. ToJExpr a => a -> JExpr
toJExpr (FastString
fun_name forall a. Semigroup a => a -> a -> a
<> FastString
": oversat"))
                                  forall a. Semigroup a => a -> a -> a
<> JExpr -> JExpr -> JExpr -> JStat
oversatCase JExpr
c JExpr
ar0 JExpr
ar)
                                 (StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (forall a. ToJExpr a => a -> JExpr
toJExpr (FastString
fun_name forall a. Semigroup a => a -> a -> a
<> FastString
": undersat"))
                                  forall a. Semigroup a => a -> a -> a
<> StgToJSConfig -> Ident -> JExpr -> JExpr -> [JExpr] -> JStat
mkPap StgToJSConfig
s Ident
pap (forall a. ToJExpr a => a -> JExpr
toJExpr StgReg
R1) (forall a. ToJExpr a => a -> JExpr
toJExpr Int
nargs) [JExpr]
stackArgs
                                  forall a. Semigroup a => a -> a -> a
<> (JExpr
sp JExpr -> JExpr -> JStat
|= JExpr
sp forall a. Num a => a -> a -> a
- forall a. ToJExpr a => a -> JExpr
toJExpr (Int
nvarsforall a. Num a => a -> a -> a
+Int
1))
                                  forall a. Semigroup a => a -> a -> a
<> (JExpr
r1 JExpr -> JExpr -> JStat
|= forall a. ToJExpr a => a -> JExpr
toJExpr Ident
pap)
                                  forall a. Semigroup a => a -> a -> a
<> JStat
returnStack))
                              ]
        JExpr
_                  -> forall a. Monoid a => a
mempty


    -- oversat: call the function but keep enough on the stack for the next
    oversatCase :: JExpr -- function
                -> JExpr -- the arity tag
                -> JExpr -- real arity (arity & 0xff)
                -> JStat
    oversatCase :: JExpr -> JExpr -> JExpr -> JStat
oversatCase JExpr
c JExpr
arity JExpr
arity0 =
      forall a. ToSat a => a -> JStat
jVar \JExpr
rs JExpr
newAp ->
        [ JExpr
rs JExpr -> JExpr -> JStat
|= (JExpr
arity JExpr -> JExpr -> JExpr
.>>. JExpr
8)
        , JExpr -> JStat
loadRegs JExpr
rs
        , JExpr
sp JExpr -> JExpr -> JStat
|= JExpr
sp forall a. Num a => a -> a -> a
- JExpr
rs
        , JExpr
newAp JExpr -> JExpr -> JStat
|= (FastString -> JExpr
var FastString
"h$apply" JExpr -> JExpr -> JExpr
.! ((forall a. ToJExpr a => a -> JExpr
toJExpr Int
nargsforall a. Num a => a -> a -> a
-JExpr
arity0)JExpr -> JExpr -> JExpr
.|.((forall a. ToJExpr a => a -> JExpr
toJExpr Int
nvarsforall a. Num a => a -> a -> a
-JExpr
rs)JExpr -> JExpr -> JExpr
.<<.JExpr
8)))
        , JExpr
stack JExpr -> JExpr -> JExpr
.! JExpr
sp JExpr -> JExpr -> JStat
|= JExpr
newAp
        , StgToJSConfig -> JStat -> JStat
profStat StgToJSConfig
s JStat
pushRestoreCCS
        , StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (forall a. ToJExpr a => a -> JExpr
toJExpr (FastString
fun_name forall a. Semigroup a => a -> a -> a
<> FastString
": new stack frame: ") forall a. Num a => a -> a -> a
+ (JExpr
newAp JExpr -> FastString -> JExpr
.^ FastString
"n"))
        , JExpr -> JStat
returnS JExpr
c
        ]
      where
        loadRegs :: JExpr -> JStat
loadRegs JExpr
rs = JExpr -> [(JExpr, JStat)] -> JStat -> JStat
SwitchStat JExpr
rs [(JExpr, JStat)]
switchAlts forall a. Monoid a => a
mempty
          where
            switchAlts :: [(JExpr, JStat)]
switchAlts = forall a b. (a -> b) -> [a] -> [b]
map (\Int
x -> (forall a. ToJExpr a => a -> JExpr
toJExpr Int
x, Int -> JExpr
jsReg (Int
xforall a. Num a => a -> a -> a
+Int
1) JExpr -> JExpr -> JStat
|= JExpr
stack JExpr -> JExpr -> JExpr
.! (JExpr
sp forall a. Num a => a -> a -> a
- forall a. ToJExpr a => a -> JExpr
toJExpr Int
x))) [Int
nvars,Int
nvarsforall a. Num a => a -> a -> a
-Int
1..Int
1]

-- | Make specialized apply function with Regs calling convention
--
-- h$ap_n_r_fast is entered if a function of unknown arity is called, n
-- arguments are already in r registers
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
      -- special case for h$ap_0_0_fast
      body0 :: JExpr
body0 = if Int
nargs forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
&& Int
nvars forall a. Eq a => a -> a -> Bool
== Int
0
        then forall a. ToSat a => a -> JExpr
jLam (StgToJSConfig -> JExpr -> JStat
enter StgToJSConfig
s JExpr
r1)
        else forall a. ToJExpr a => a -> JExpr
toJExpr ([Ident] -> JStat -> JVal
JFunc forall a. [a]
myFunArgs JStat
body)

      func :: Ident
func    = FastString -> Ident
TxtI FastString
fun_name

      myFunArgs :: [a]
myFunArgs = []

      regArgs :: [JExpr]
regArgs = forall a. Int -> [a] -> [a]
take Int
nvars [JExpr]
jsRegsFromR2

      mkAp :: Int -> Int -> [JExpr]
      mkAp :: Int -> Int -> [JExpr]
mkAp Int
n' Int
r' = [ ApplySpec -> JExpr
specApplyExpr (ApplyConv -> Int -> Int -> ApplySpec
ApplySpec ApplyConv
StackConv Int
n' Int
r') ]

      body :: JStat
body =
        forall a. ToSat a => a -> JStat
jVar \JExpr
c JExpr
farity JExpr
arity ->
          [ JExpr
c JExpr -> JExpr -> JStat
|= JExpr -> JExpr
closureEntry JExpr
r1
          , StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (forall a. ToJExpr a => a -> JExpr
toJExpr (FastString
fun_name forall a. Semigroup a => a -> a -> a
<> FastString
": sp ") forall a. Num a => a -> a -> a
+ JExpr
sp)
          , JExpr -> [(JExpr, JStat)] -> JStat -> JStat
SwitchStat (JExpr -> JExpr
entryClosureType JExpr
c)
             [(forall a. ToJExpr a => a -> JExpr
toJExpr ClosureType
Fun, StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (forall a. ToJExpr a => a -> JExpr
toJExpr (FastString
fun_name forall a. Semigroup a => a -> a -> a
<> FastString
": ")
                                        forall a. Num a => a -> a -> a
+ JExpr -> JExpr
clName JExpr
c
                                        forall a. Num a => a -> a -> a
+ FastString -> JExpr
jString FastString
" (arity: " forall a. Num a => a -> a -> a
+ (JExpr
c JExpr -> FastString -> JExpr
.^ FastString
"a") forall a. Num a => a -> a -> a
+ FastString -> JExpr
jString FastString
")")
                            forall a. Semigroup a => a -> a -> a
<> (JExpr
farity JExpr -> JExpr -> JStat
|= JExpr -> JExpr
funArity' JExpr
c)
                            forall a. Semigroup a => a -> a -> a
<> JExpr -> JExpr -> JStat
funCase JExpr
c JExpr
farity)
             ,(forall a. ToJExpr a => a -> JExpr
toJExpr ClosureType
Pap, StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (forall a. ToJExpr a => a -> JExpr
toJExpr (FastString
fun_name forall a. Semigroup a => a -> a -> a
<> FastString
": pap")) forall a. Semigroup a => a -> a -> a
<> (JExpr
arity JExpr -> JExpr -> JStat
|= JExpr -> JExpr
papArity JExpr
r1) forall a. Semigroup a => a -> a -> a
<> JExpr -> JExpr -> JStat
funCase JExpr
c JExpr
arity)
             ,(forall a. ToJExpr a => a -> JExpr
toJExpr ClosureType
Thunk, StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (forall a. ToJExpr a => a -> JExpr
toJExpr (FastString
fun_name forall a. Semigroup a => a -> a -> a
<> FastString
": thunk")) forall a. Semigroup a => a -> a -> a
<> StgToJSConfig -> [JExpr] -> JStat
push' StgToJSConfig
s (forall a. [a] -> [a]
reverse [JExpr]
regArgs forall a. [a] -> [a] -> [a]
++ Int -> Int -> [JExpr]
mkAp Int
nargs Int
nvars) forall a. Semigroup a => a -> a -> a
<> StgToJSConfig -> JStat -> JStat
profStat StgToJSConfig
s JStat
pushRestoreCCS forall a. Semigroup a => a -> a -> a
<> JExpr -> JStat
returnS JExpr
c)
             ,(forall a. ToJExpr a => a -> JExpr
toJExpr ClosureType
Blackhole, StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (forall a. ToJExpr a => a -> JExpr
toJExpr (FastString
fun_name forall a. Semigroup a => a -> a -> a
<> FastString
": blackhole")) forall a. Semigroup a => a -> a -> a
<> StgToJSConfig -> [JExpr] -> JStat
push' StgToJSConfig
s (forall a. [a] -> [a]
reverse [JExpr]
regArgs forall a. [a] -> [a] -> [a]
++ Int -> Int -> [JExpr]
mkAp Int
nargs Int
nvars) forall a. Semigroup a => a -> a -> a
<> StgToJSConfig -> [JExpr] -> JStat
push' StgToJSConfig
s [JExpr
r1, FastString -> JExpr
var FastString
"h$return"] forall a. Semigroup a => a -> a -> a
<> JExpr -> JStat
returnS (FastString -> [JExpr] -> JExpr
app FastString
"h$blockOnBlackhole" [JExpr
r1]))]
             (FastString -> [JExpr] -> JStat
appS FastString
"throw" [forall a. ToJExpr a => a -> JExpr
toJExpr (FastString
fun_name forall a. Semigroup a => a -> a -> a
<> FastString
": unexpected closure type: ") forall a. Num a => a -> a -> a
+ JExpr -> JExpr
entryClosureType JExpr
c])
          ]

      funCase :: JExpr -> JExpr -> JStat
      funCase :: JExpr -> JExpr -> JStat
funCase JExpr
c JExpr
arity = forall a. ToSat a => a -> JStat
jVar \JExpr
arg JExpr
ar -> case JExpr
arg of
          ValExpr (JVar Ident
pap) -> [ JExpr
ar JExpr -> JExpr -> JStat
|= JExpr -> JExpr
mask8 JExpr
arity
                                ,  JExpr -> JStat -> JStat -> JStat
ifS (forall a. ToJExpr a => a -> JExpr
toJExpr Int
nargs JExpr -> JExpr -> JExpr
.===. JExpr
ar)
                                  -- then
                                  (StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (forall a. ToJExpr a => a -> JExpr
toJExpr (FastString
fun_name forall a. Semigroup a => a -> a -> a
<> FastString
": exact")) forall a. Semigroup a => a -> a -> a
<> JExpr -> JStat
returnS JExpr
c)
                                  -- else
                                  (JExpr -> JStat -> JStat -> JStat
ifS (forall a. ToJExpr a => a -> JExpr
toJExpr Int
nargs JExpr -> JExpr -> JExpr
.>. JExpr
ar)
                                    --then
                                    (StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (forall a. ToJExpr a => a -> JExpr
toJExpr (FastString
fun_name forall a. Semigroup a => a -> a -> a
<> FastString
": oversat")) forall a. Semigroup a => a -> a -> a
<> JExpr -> JExpr -> JStat
oversatCase JExpr
c JExpr
arity)
                                    -- else
                                    (StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (forall a. ToJExpr a => a -> JExpr
toJExpr (FastString
fun_name forall a. Semigroup a => a -> a -> a
<> FastString
": undersat"))
                                     forall a. Semigroup a => a -> a -> a
<> StgToJSConfig -> Ident -> JExpr -> JExpr -> [JExpr] -> JStat
mkPap StgToJSConfig
s Ident
pap JExpr
r1 (forall a. ToJExpr a => a -> JExpr
toJExpr Int
nargs) [JExpr]
regArgs
                                     forall a. Semigroup a => a -> a -> a
<> (JExpr
r1 JExpr -> JExpr -> JStat
|= forall a. ToJExpr a => a -> JExpr
toJExpr Ident
pap)
                                     forall a. Semigroup a => a -> a -> a
<> JStat
returnStack))
                                ]
          JExpr
_             -> forall a. Monoid a => a
mempty

      oversatCase :: JExpr -> JExpr -> JStat
      oversatCase :: JExpr -> JExpr -> JStat
oversatCase JExpr
c JExpr
arity =
         forall a. ToSat a => a -> JStat
jVar \JExpr
rs JExpr
rsRemain ->
           [ JExpr
rs JExpr -> JExpr -> JStat
|= JExpr
arity JExpr -> JExpr -> JExpr
.>>. JExpr
8
           , JExpr
rsRemain JExpr -> JExpr -> JStat
|= forall a. ToJExpr a => a -> JExpr
toJExpr Int
nvars forall a. Num a => a -> a -> a
- JExpr
rs
           , StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (forall a. ToJExpr a => a -> JExpr
toJExpr
                         (FastString
fun_name forall a. Semigroup a => a -> a -> a
<> FastString
" regs oversat ")
                          forall a. Num a => a -> a -> a
+ JExpr
rs
                          forall a. Num a => a -> a -> a
+ FastString -> JExpr
jString FastString
" remain: "
                          forall a. Num a => a -> a -> a
+ JExpr
rsRemain)
           , JExpr -> JStat
saveRegs JExpr
rs
           , JExpr
sp JExpr -> JExpr -> JStat
|= JExpr
sp forall a. Num a => a -> a -> a
+ JExpr
rsRemain forall a. Num a => a -> a -> a
+ JExpr
1
           , JExpr
stack JExpr -> JExpr -> JExpr
.! JExpr
sp JExpr -> JExpr -> JStat
|= FastString -> JExpr
var FastString
"h$apply" JExpr -> JExpr -> JExpr
.! ((JExpr
rsRemainJExpr -> JExpr -> JExpr
.<<.JExpr
8)JExpr -> JExpr -> JExpr
.|. (forall a. ToJExpr a => a -> JExpr
toJExpr Int
nargs forall a. Num a => a -> a -> a
- JExpr -> JExpr
mask8 JExpr
arity))
           , StgToJSConfig -> JStat -> JStat
profStat StgToJSConfig
s JStat
pushRestoreCCS
           , JExpr -> JStat
returnS JExpr
c
           ]
          where
            saveRegs :: JExpr -> JStat
saveRegs JExpr
n = JExpr -> [(JExpr, JStat)] -> JStat -> JStat
SwitchStat JExpr
n [(JExpr, JStat)]
switchAlts forall a. Monoid a => a
mempty
              where
                switchAlts :: [(JExpr, JStat)]
switchAlts = forall a b. (a -> b) -> [a] -> [b]
map (\Int
x -> (forall a. ToJExpr a => a -> JExpr
toJExpr Int
x, JExpr
stack JExpr -> JExpr -> JExpr
.! (JExpr
sp forall a. Num a => a -> a -> a
+ forall a. ToJExpr a => a -> JExpr
toJExpr (Int
nvarsforall a. Num a => a -> a -> a
-Int
x)) JExpr -> JExpr -> JStat
|= Int -> JExpr
jsReg (Int
xforall a. Num a => a -> a -> a
+Int
2))) [Int
0..Int
nvarsforall a. Num a => a -> a -> a
-Int
1]

zeroApply :: StgToJSConfig -> JStat
zeroApply :: StgToJSConfig -> JStat
zeroApply StgToJSConfig
s = forall a. Monoid a => [a] -> a
mconcat
  [ FastString -> Ident
TxtI FastString
"h$e" Ident -> JExpr -> JStat
||= forall a. ToSat a => a -> JExpr
jLam (\JExpr
c -> (JExpr
r1 JExpr -> JExpr -> JStat
|= JExpr
c) forall a. Semigroup a => a -> a -> a
<> StgToJSConfig -> JExpr -> JStat
enter StgToJSConfig
s JExpr
c)
  ]

-- carefully enter a closure that might be a thunk or a function

-- ex may be a local var, but must've been copied to R1 before calling this
enter :: StgToJSConfig -> JExpr -> JStat
enter :: StgToJSConfig -> JExpr -> JStat
enter StgToJSConfig
s JExpr
ex = forall a. ToSat a => a -> JStat
jVar \JExpr
c ->
  [ JExpr -> JStat -> JStat
jwhenS (FastString -> [JExpr] -> JExpr
app FastString
"typeof" [JExpr
ex] JExpr -> JExpr -> JExpr
.!==. JExpr
jTyObject) JStat
returnStack
  , JExpr
c JExpr -> JExpr -> JStat
|= JExpr -> JExpr
closureEntry JExpr
ex
  , JExpr -> JStat -> JStat
jwhenS (JExpr
c JExpr -> JExpr -> JExpr
.===. FastString -> JExpr
var FastString
"h$unbox_e") ((JExpr
r1 JExpr -> JExpr -> JStat
|= JExpr -> JExpr
closureField1 JExpr
ex) forall a. Semigroup a => a -> a -> a
<> JStat
returnStack)
  , JExpr -> [(JExpr, JStat)] -> JStat -> JStat
SwitchStat (JExpr -> JExpr
entryClosureType JExpr
c)
    [ (forall a. ToJExpr a => a -> JExpr
toJExpr ClosureType
Con, forall a. Monoid a => a
mempty)
    , (forall a. ToJExpr a => a -> JExpr
toJExpr ClosureType
Fun, forall a. Monoid a => a
mempty)
    , (forall a. ToJExpr a => a -> JExpr
toJExpr ClosureType
Pap, JStat
returnStack)
    , (forall a. ToJExpr a => a -> JExpr
toJExpr ClosureType
Blackhole, StgToJSConfig -> [JExpr] -> JStat
push' StgToJSConfig
s [FastString -> JExpr
var FastString
"h$ap_0_0", JExpr
ex, FastString -> JExpr
var FastString
"h$return"]
        forall a. Semigroup a => a -> a -> a
<> JExpr -> JStat
returnS (FastString -> [JExpr] -> JExpr
app FastString
"h$blockOnBlackhole" [JExpr
ex]))
    ] (JExpr -> JStat
returnS JExpr
c)
  ]

updates :: StgToJSConfig -> JStat
updates :: StgToJSConfig -> JStat
updates StgToJSConfig
s = [JStat] -> JStat
BlockStat
  [ ClosureInfo -> JStat -> JStat
closure
      (Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo (FastString -> Ident
TxtI FastString
"h$upd_frame") (Int -> [VarType] -> CIRegs
CIRegs Int
0 [VarType
PtrV]) FastString
"h$upd_frame" (Int -> [VarType] -> CILayout
CILayoutFixed Int
1 [VarType
PtrV]) CIType
CIStackFrame forall a. Monoid a => a
mempty)
      forall a b. (a -> b) -> a -> b
$ forall a. ToSat a => a -> JStat
jVar \JExpr
updatee JExpr
waiters JExpr
ss JExpr
si JExpr
sir ->
            let unbox_closure :: Closure
unbox_closure = Closure
                  { clEntry :: JExpr
clEntry  = FastString -> JExpr
var FastString
"h$unbox_e"
                  , clField1 :: JExpr
clField1 = JExpr
sir
                  , clField2 :: JExpr
clField2 = JExpr
null_
                  , clMeta :: JExpr
clMeta   = JExpr
0
                  , clCC :: Maybe JExpr
clCC     = forall a. Maybe a
Nothing
                  }
                updateCC :: JExpr -> JStat
updateCC JExpr
updatee = JExpr -> JExpr
closureCC JExpr
updatee JExpr -> JExpr -> JStat
|= JExpr
jCurrentCCS
            in [ JExpr
updatee JExpr -> JExpr -> JStat
|= JExpr
stack JExpr -> JExpr -> JExpr
.! (JExpr
sp forall a. Num a => a -> a -> a
- JExpr
1)
               , StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (FastString -> JExpr
jString FastString
"h$upd_frame updatee alloc: " forall a. Num a => a -> a -> a
+ JExpr
updatee JExpr -> FastString -> JExpr
.^ FastString
"alloc")
               , -- wake up threads blocked on blackhole
                 JExpr
waiters JExpr -> JExpr -> JStat
|= JExpr -> JExpr
closureField2 JExpr
updatee
               , JExpr -> JStat -> JStat
jwhenS (JExpr
waiters JExpr -> JExpr -> JExpr
.!==. JExpr
null_)
                           (JExpr -> (JExpr -> JExpr) -> (JExpr -> JStat) -> JStat
loop JExpr
0 (JExpr -> JExpr -> JExpr
.<. JExpr
waiters JExpr -> FastString -> JExpr
.^ FastString
"length")
                              (\JExpr
i -> FastString -> [JExpr] -> JStat
appS FastString
"h$wakeupThread" [JExpr
waiters JExpr -> JExpr -> JExpr
.! JExpr
i] forall a. Semigroup a => a -> a -> a
<> JExpr -> JStat
postIncrS JExpr
i))
               , -- update selectors
                 JExpr -> JStat -> JStat
jwhenS ((FastString -> [JExpr] -> JExpr
app FastString
"typeof" [JExpr -> JExpr
closureMeta JExpr
updatee] JExpr -> JExpr -> JExpr
.===. JExpr
jTyObject) JExpr -> JExpr -> JExpr
.&&. (JExpr -> JExpr
closureMeta JExpr
updatee JExpr -> FastString -> JExpr
.^ FastString
"sel"))
                 ((JExpr
ss JExpr -> JExpr -> JStat
|= JExpr -> JExpr
closureMeta JExpr
updatee JExpr -> FastString -> JExpr
.^ FastString
"sel")
                   forall a. Semigroup a => a -> a -> a
<> JExpr -> (JExpr -> JExpr) -> (JExpr -> JStat) -> JStat
loop JExpr
0 (JExpr -> JExpr -> JExpr
.<. JExpr
ss JExpr -> FastString -> JExpr
.^ FastString
"length") \JExpr
i -> forall a. Monoid a => [a] -> a
mconcat
                        [ JExpr
si JExpr -> JExpr -> JStat
|= JExpr
ss JExpr -> JExpr -> JExpr
.! JExpr
i
                        , JExpr
sir JExpr -> JExpr -> JStat
|= (JExpr -> JExpr
closureField2 JExpr
si) JExpr -> [JExpr] -> JExpr
`ApplExpr` [JExpr
r1]
                        , JExpr -> JStat -> JStat -> JStat
ifS (FastString -> [JExpr] -> JExpr
app FastString
"typeof" [JExpr
sir] JExpr -> JExpr -> JExpr
.===. JExpr
jTyObject)
                            (CopyCC -> JExpr -> JExpr -> JStat
copyClosure CopyCC
DontCopyCC JExpr
si JExpr
sir)
                            (JExpr -> Closure -> JStat
assignClosure JExpr
si Closure
unbox_closure)
                        , JExpr -> JStat
postIncrS JExpr
i
                        ])
               , -- overwrite the object
                 JExpr -> JStat -> JStat -> JStat
ifS (FastString -> [JExpr] -> JExpr
app FastString
"typeof" [JExpr
r1] JExpr -> JExpr -> JExpr
.===. JExpr
jTyObject)
                     (forall a. Monoid a => [a] -> a
mconcat [ StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (FastString -> JExpr
jString FastString
"$upd_frame: boxed: " forall a. Num a => a -> a -> a
+ ((JExpr -> JExpr
closureEntry JExpr
r1) JExpr -> FastString -> JExpr
.^ FastString
"n"))
                              , CopyCC -> JExpr -> JExpr -> JStat
copyClosure CopyCC
DontCopyCC JExpr
updatee JExpr
r1
                              ])
                     -- the heap object is represented by another type of value
                     -- (e.g. a JS number or string) so the unboxing closure
                     -- will simply return it.
                     (JExpr -> Closure -> JStat
assignClosure JExpr
updatee (Closure
unbox_closure { clField1 :: JExpr
clField1 = JExpr
r1 }))
               , StgToJSConfig -> JStat -> JStat
profStat StgToJSConfig
s (JExpr -> JStat
updateCC JExpr
updatee)
               , Int -> JStat
adjSpN' Int
2
               , StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (FastString -> JExpr
jString FastString
"h$upd_frame: updating: "
                             forall a. Num a => a -> a -> a
+ JExpr
updatee
                             forall a. Num a => a -> a -> a
+ FastString -> JExpr
jString FastString
" -> "
                             forall a. Num a => a -> a -> a
+ JExpr
r1)
               , JStat
returnStack
               ]

   , ClosureInfo -> JStat -> JStat
closure
      (Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo (FastString -> Ident
TxtI FastString
"h$upd_frame_lne") (Int -> [VarType] -> CIRegs
CIRegs Int
0 [VarType
PtrV]) FastString
"h$upd_frame_lne" (Int -> [VarType] -> CILayout
CILayoutFixed Int
1 [VarType
PtrV]) CIType
CIStackFrame forall a. Monoid a => a
mempty)
      forall a b. (a -> b) -> a -> b
$ forall a. ToSat a => a -> JStat
jVar \JExpr
updateePos ->
          [ JExpr
updateePos JExpr -> JExpr -> JStat
|= JExpr
stack JExpr -> JExpr -> JExpr
.! (JExpr
sp forall a. Num a => a -> a -> a
- JExpr
1)
          , (JExpr
stack JExpr -> JExpr -> JExpr
.! JExpr
updateePos JExpr -> JExpr -> JStat
|= JExpr
r1)
          , Int -> JStat
adjSpN' Int
2
          , StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (FastString -> JExpr
jString FastString
"h$upd_frame_lne: updating: "
                         forall a. Num a => a -> a -> a
+ JExpr
updateePos
                         forall a. Num a => a -> a -> a
+ FastString -> JExpr
jString FastString
" -> "
                         forall a. Num a => a -> a -> a
+ JExpr
r1)
          , JStat
returnStack
          ]
  ]

selectors :: StgToJSConfig -> JStat
selectors :: StgToJSConfig -> JStat
selectors StgToJSConfig
s =
  FastString -> (JExpr -> JExpr) -> JStat
mkSel FastString
"1"      JExpr -> JExpr
closureField1
  forall a. Semigroup a => a -> a -> a
<> FastString -> (JExpr -> JExpr) -> JStat
mkSel FastString
"2a"  JExpr -> JExpr
closureField2
  forall a. Semigroup a => a -> a -> a
<> FastString -> (JExpr -> JExpr) -> JStat
mkSel FastString
"2b"  (JExpr -> JExpr
closureField1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. JExpr -> JExpr
closureField2)
  forall a. Semigroup a => a -> a -> a
<> forall a. Monoid a => [a] -> a
mconcat (forall a b. (a -> b) -> [a] -> [b]
map Int -> JStat
mkSelN [Int
3..Int
16])
   where
    mkSelN :: Int -> JStat
    mkSelN :: Int -> JStat
mkSelN Int
x = FastString -> (JExpr -> JExpr) -> JStat
mkSel ([Char] -> FastString
mkFastString forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show Int
x)
                     (\JExpr
e -> JExpr -> Ident -> JExpr
SelExpr (JExpr -> JExpr
closureField2 (forall a. ToJExpr a => a -> JExpr
toJExpr JExpr
e))
                            (FastString -> Ident
TxtI forall a b. (a -> b) -> a -> b
$ [Char] -> FastString
mkFastString ([Char]
"d" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (Int
xforall a. Num a => a -> a -> a
-Int
1))))


    mkSel :: FastString -> (JExpr -> JExpr) -> JStat
    mkSel :: FastString -> (JExpr -> JExpr) -> JStat
mkSel FastString
name JExpr -> JExpr
sel = forall a. Monoid a => [a] -> a
mconcat
      [FastString -> Ident
TxtI FastString
createName Ident -> JExpr -> JStat
||= forall a. ToSat a => a -> JExpr
jLam \JExpr
r -> forall a. Monoid a => [a] -> a
mconcat
          [ StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (forall a. ToJExpr a => a -> JExpr
toJExpr (FastString
"selector create: " forall a. Semigroup a => a -> a -> a
<> FastString
name forall a. Semigroup a => a -> a -> a
<> FastString
" for ") forall a. Num a => a -> a -> a
+ (JExpr
r JExpr -> FastString -> JExpr
.^ FastString
"alloc"))
          , JExpr -> JStat -> JStat -> JStat
ifS (JExpr -> JExpr
isThunk JExpr
r JExpr -> JExpr -> JExpr
.||. JExpr -> JExpr
isBlackhole JExpr
r)
              (JExpr -> JStat
returnS (FastString -> [JExpr] -> JExpr
app FastString
"h$mkSelThunk" [JExpr
r, forall a. ToJExpr a => a -> JExpr
toJExpr (FastString -> JVal
v FastString
entryName), forall a. ToJExpr a => a -> JExpr
toJExpr (FastString -> JVal
v FastString
resName)]))
              (JExpr -> JStat
returnS (JExpr -> JExpr
sel JExpr
r))
          ]
      , FastString -> Ident
TxtI FastString
resName Ident -> JExpr -> JStat
||= forall a. ToSat a => a -> JExpr
jLam \JExpr
r -> forall a. Monoid a => [a] -> a
mconcat
          [ StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (forall a. ToJExpr a => a -> JExpr
toJExpr (FastString
"selector result: " forall a. Semigroup a => a -> a -> a
<> FastString
name forall a. Semigroup a => a -> a -> a
<> FastString
" for ") forall a. Num a => a -> a -> a
+ (JExpr
r JExpr -> FastString -> JExpr
.^ FastString
"alloc"))
          , JExpr -> JStat
returnS (JExpr -> JExpr
sel JExpr
r)
          ]
      , ClosureInfo -> JStat -> JStat
closure
        (Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo (FastString -> Ident
TxtI FastString
entryName) (Int -> [VarType] -> CIRegs
CIRegs Int
0 [VarType
PtrV]) (FastString
"select " forall a. Semigroup a => a -> a -> a
<> FastString
name) (Int -> [VarType] -> CILayout
CILayoutFixed Int
1 [VarType
PtrV]) CIType
CIThunk forall a. Monoid a => a
mempty)
        (forall a. ToSat a => a -> JStat
jVar \JExpr
tgt ->
          [ JExpr
tgt JExpr -> JExpr -> JStat
|= JExpr -> JExpr
closureField1 JExpr
r1
          , StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (forall a. ToJExpr a => a -> JExpr
toJExpr (FastString
"selector entry: " forall a. Semigroup a => a -> a -> a
<> FastString
name forall a. Semigroup a => a -> a -> a
<> FastString
" for ") forall a. Num a => a -> a -> a
+ (JExpr
tgt JExpr -> FastString -> JExpr
.^ FastString
"alloc"))
          , JExpr -> JStat -> JStat -> JStat
ifS (JExpr -> JExpr
isThunk JExpr
tgt JExpr -> JExpr -> JExpr
.||. JExpr -> JExpr
isBlackhole JExpr
tgt)
              (JExpr -> JStat
preIncrS JExpr
sp
               forall a. Semigroup a => a -> a -> a
<> (JExpr
stack JExpr -> JExpr -> JExpr
.! JExpr
sp JExpr -> JExpr -> JStat
|= FastString -> JExpr
var FastString
frameName)
               forall a. Semigroup a => a -> a -> a
<> JExpr -> JStat
returnS (FastString -> [JExpr] -> JExpr
app FastString
"h$e" [JExpr
tgt]))
              (JExpr -> JStat
returnS (FastString -> [JExpr] -> JExpr
app FastString
"h$e" [JExpr -> JExpr
sel JExpr
tgt]))
          ])
      , ClosureInfo -> JStat -> JStat
closure
        (Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo (FastString -> Ident
TxtI FastString
frameName) (Int -> [VarType] -> CIRegs
CIRegs Int
0 [VarType
PtrV]) (FastString
"select " forall a. Semigroup a => a -> a -> a
<> FastString
name forall a. Semigroup a => a -> a -> a
<> FastString
" frame") (Int -> [VarType] -> CILayout
CILayoutFixed Int
0 []) CIType
CIStackFrame forall a. Monoid a => a
mempty)
        forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat [ StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (forall a. ToJExpr a => a -> JExpr
toJExpr (FastString
"selector frame: " forall a. Semigroup a => a -> a -> a
<> FastString
name))
                  , JExpr -> JStat
postDecrS JExpr
sp
                  , JExpr -> JStat
returnS (FastString -> [JExpr] -> JExpr
app FastString
"h$e" [JExpr -> JExpr
sel JExpr
r1])
                  ]
      ]

      where
         v :: FastString -> JVal
v FastString
x   = Ident -> JVal
JVar (FastString -> Ident
TxtI FastString
x)
         n :: FastString -> FastString
n FastString
ext =  FastString
"h$c_sel_" forall a. Semigroup a => a -> a -> a
<> FastString
name forall a. Semigroup a => a -> a -> a
<> FastString
ext
         createName :: FastString
createName = FastString -> FastString
n FastString
""
         resName :: FastString
resName    = FastString -> FastString
n FastString
"_res"
         entryName :: FastString
entryName  = FastString -> FastString
n FastString
"_e"
         frameName :: FastString
frameName  = FastString -> FastString
n FastString
"_frame_e"


-- arity is the remaining arity after our supplied arguments are applied
mkPap :: StgToJSConfig
      -> Ident   -- ^ id of the pap object
      -> JExpr   -- ^ the function that's called (can be a second pap)
      -> JExpr   -- ^ number of arguments in pap
      -> [JExpr] -- ^ values for the supplied arguments
      -> JStat
mkPap :: StgToJSConfig -> Ident -> JExpr -> JExpr -> [JExpr] -> JStat
mkPap StgToJSConfig
s Ident
tgt JExpr
fun JExpr
n [JExpr]
values =
      StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (forall a. ToJExpr a => a -> JExpr
toJExpr forall a b. (a -> b) -> a -> b
$ [Char]
"making pap with: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [JExpr]
values) forall a. [a] -> [a] -> [a]
++ [Char]
" items")
      forall a. Monoid a => a -> a -> a
`mappend`
      StgToJSConfig
-> Bool -> Ident -> JExpr -> [JExpr] -> Maybe JExpr -> JStat
allocDynamic StgToJSConfig
s Bool
True Ident
tgt (forall a. ToJExpr a => a -> JExpr
toJExpr Ident
entry) (JExpr
funforall a. a -> [a] -> [a]
:JExpr
papArforall a. a -> [a] -> [a]
:forall a b. (a -> b) -> [a] -> [b]
map forall a. ToJExpr a => a -> JExpr
toJExpr [JExpr]
values')
        (if StgToJSConfig -> Bool
csProf StgToJSConfig
s then forall a. a -> Maybe a
Just JExpr
jCurrentCCS else forall a. Maybe a
Nothing)
  where
    papAr :: JExpr
papAr = JExpr -> Maybe JExpr -> JExpr
funOrPapArity JExpr
fun forall a. Maybe a
Nothing forall a. Num a => a -> a -> a
- forall a. ToJExpr a => a -> JExpr
toJExpr (forall (t :: * -> *) a. Foldable t => t a -> Int
length [JExpr]
values forall a. Num a => a -> a -> a
* Int
256) forall a. Num a => a -> a -> a
- JExpr
n

    values' :: [JExpr]
values' | forall (t :: * -> *) a. Foldable t => t a -> Bool
GHC.Prelude.null [JExpr]
values = [JExpr
null_]
            | Bool
otherwise   = [JExpr]
values
    entry :: Ident
entry | forall (t :: * -> *) a. Foldable t => t a -> Int
length [JExpr]
values forall a. Ord a => a -> a -> Bool
> Int
numSpecPap = FastString -> Ident
TxtI FastString
"h$pap_gen"
          | Bool
otherwise                  = Array Int Ident
specPapIdents forall i e. Ix i => Array i e -> i -> e
! forall (t :: * -> *) a. Foldable t => t a -> Int
length [JExpr]
values

-- | Number of specialized PAPs (pre-generated for a given number of args)
numSpecPap :: Int
numSpecPap :: Int
numSpecPap = Int
6

-- specialized (faster) pap generated for [0..numSpecPap]
-- others use h$pap_gen
specPap :: [Int]
specPap :: [Int]
specPap = [Int
0..Int
numSpecPap]

-- | Cache of specialized PAP idents
specPapIdents :: Array Int Ident
specPapIdents :: Array Int Ident
specPapIdents = forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0,Int
numSpecPap) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (FastString -> Ident
TxtI forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> FastString
mkFastString forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
"h$pap_"forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show) [Int]
specPap

pap :: StgToJSConfig
    -> Int
    -> JStat
pap :: StgToJSConfig -> Int -> JStat
pap StgToJSConfig
s Int
r = ClosureInfo -> JStat -> JStat
closure (Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo Ident
funcIdent CIRegs
CIRegsUnknown FastString
funcName (Int -> CILayout
CILayoutUnknown (Int
rforall a. Num a => a -> a -> a
+Int
2)) CIType
CIPap forall a. Monoid a => a
mempty) JStat
body
  where
    funcIdent :: Ident
funcIdent = FastString -> Ident
TxtI FastString
funcName
    funcName :: FastString
funcName = [Char] -> FastString
mkFastString ([Char]
"h$pap_" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int
r)

    body :: JStat
body = forall a. ToSat a => a -> JStat
jVar \JExpr
c JExpr
d JExpr
f JExpr
extra ->
             [ JExpr
c JExpr -> JExpr -> JStat
|= JExpr -> JExpr
closureField1 JExpr
r1
             , JExpr
d JExpr -> JExpr -> JStat
|= JExpr -> JExpr
closureField2 JExpr
r1
             , JExpr
f JExpr -> JExpr -> JStat
|= JExpr -> JExpr
closureEntry  JExpr
c
             , forall a. ToJExpr a => StgToJSConfig -> JExpr -> a -> JStat
assertRts StgToJSConfig
s (JExpr -> JExpr
isFun' JExpr
f JExpr -> JExpr -> JExpr
.||. JExpr -> JExpr
isPap' JExpr
f) (FastString
funcName forall a. Semigroup a => a -> a -> a
<> FastString
": expected function or pap")
             , StgToJSConfig -> JStat -> JStat
profStat StgToJSConfig
s (CostCentreStack -> JStat
enterCostCentreFun CostCentreStack
currentCCS)
             , JExpr
extra JExpr -> JExpr -> JStat
|= (JExpr -> Maybe JExpr -> JExpr
funOrPapArity JExpr
c (forall a. a -> Maybe a
Just JExpr
f) JExpr -> JExpr -> JExpr
.>>. JExpr
8) forall a. Num a => a -> a -> a
- forall a. ToJExpr a => a -> JExpr
toJExpr Int
r
             , StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (forall a. ToJExpr a => a -> JExpr
toJExpr (FastString
funcName forall a. Semigroup a => a -> a -> a
<> FastString
": pap extra args moving: ") forall a. Num a => a -> a -> a
+ JExpr
extra)
             , JExpr -> JStat
moveBy JExpr
extra
             , JExpr -> JStat
loadOwnArgs JExpr
d
             , JExpr
r1 JExpr -> JExpr -> JStat
|= JExpr
c
             , JExpr -> JStat
returnS JExpr
f
             ]
    moveBy :: JExpr -> JStat
moveBy JExpr
extra = JExpr -> [(JExpr, JStat)] -> JStat -> JStat
SwitchStat JExpr
extra
                   (forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Int -> (JExpr, JStat)
moveCase [Int
1..Int
maxRegforall a. Num a => a -> a -> a
-Int
rforall a. Num a => a -> a -> a
-Int
1]) forall a. Monoid a => a
mempty
    moveCase :: Int -> (JExpr, JStat)
moveCase Int
m = (forall a. ToJExpr a => a -> JExpr
toJExpr Int
m, Int -> JExpr
jsReg (Int
mforall a. Num a => a -> a -> a
+Int
rforall a. Num a => a -> a -> a
+Int
1) JExpr -> JExpr -> JStat
|= Int -> JExpr
jsReg (Int
mforall a. Num a => a -> a -> a
+Int
1))
    loadOwnArgs :: JExpr -> JStat
loadOwnArgs JExpr
d = forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\Int
r ->
        Int -> JExpr
jsReg (Int
rforall a. Num a => a -> a -> a
+Int
1) JExpr -> JExpr -> JStat
|= forall {a}. (Show a, Num a) => JExpr -> a -> JExpr
dField JExpr
d (Int
rforall a. Num a => a -> a -> a
+Int
2)) [Int
1..Int
r]
    dField :: JExpr -> a -> JExpr
dField JExpr
d a
n = JExpr -> Ident -> JExpr
SelExpr JExpr
d (FastString -> Ident
TxtI forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> FastString
mkFastString forall a b. (a -> b) -> a -> b
$ (Char
'd'forall a. a -> [a] -> [a]
:forall a. Show a => a -> [Char]
show (a
nforall a. Num a => a -> a -> a
-a
1)))

-- Construct a generic PAP
papGen :: StgToJSConfig -> JStat
papGen :: StgToJSConfig -> JStat
papGen StgToJSConfig
cfg =
   ClosureInfo -> JStat -> JStat
closure (Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo Ident
funcIdent CIRegs
CIRegsUnknown FastString
funcName CILayout
CILayoutVariable CIType
CIPap forall a. Monoid a => a
mempty)
           (forall a. ToSat a => a -> JStat
jVar \JExpr
c JExpr
f JExpr
d JExpr
pr JExpr
or JExpr
r ->
              [ JExpr
c JExpr -> JExpr -> JStat
|= JExpr -> JExpr
closureField1 JExpr
r1
              , JExpr
d JExpr -> JExpr -> JStat
|= JExpr -> JExpr
closureField2 JExpr
r1
              , JExpr
f JExpr -> JExpr -> JStat
|= JExpr -> JExpr
closureEntry  JExpr
c
              , JExpr
pr JExpr -> JExpr -> JStat
|= JExpr -> Maybe JExpr -> JExpr
funOrPapArity JExpr
c (forall a. a -> Maybe a
Just JExpr
f) JExpr -> JExpr -> JExpr
.>>. JExpr
8
              , JExpr
or JExpr -> JExpr -> JStat
|= JExpr -> JExpr
papArity JExpr
r1 JExpr -> JExpr -> JExpr
.>>. JExpr
8
              , JExpr
r JExpr -> JExpr -> JStat
|= JExpr
pr forall a. Num a => a -> a -> a
- JExpr
or
              , forall a. ToJExpr a => StgToJSConfig -> JExpr -> a -> JStat
assertRts StgToJSConfig
cfg
                (JExpr -> JExpr
isFun' JExpr
f JExpr -> JExpr -> JExpr
.||. JExpr -> JExpr
isPap' JExpr
f)
                (FastString -> JExpr
jString FastString
"h$pap_gen: expected function or pap")
              , StgToJSConfig -> JStat -> JStat
profStat StgToJSConfig
cfg (CostCentreStack -> JStat
enterCostCentreFun CostCentreStack
currentCCS)
              , StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
cfg (FastString -> JExpr
jString FastString
"h$pap_gen: generic pap extra args moving: " forall a. Num a => a -> a -> a
+ JExpr
or)
              , FastString -> [JExpr] -> JStat
appS FastString
"h$moveRegs2" [JExpr
or, JExpr
r]
              , JExpr -> JExpr -> JStat
loadOwnArgs JExpr
d JExpr
r
              , JExpr
r1 JExpr -> JExpr -> JStat
|= JExpr
c
              , JExpr -> JStat
returnS JExpr
f
              ])


  where
    funcIdent :: Ident
funcIdent = FastString -> Ident
TxtI FastString
funcName
    funcName :: FastString
funcName = FastString
"h$pap_gen"
    loadOwnArgs :: JExpr -> JExpr -> JStat
loadOwnArgs JExpr
d JExpr
r =
      let prop :: Int -> JExpr
prop Int
n = JExpr
d JExpr -> FastString -> JExpr
.^ (FastString
"d" forall a. Semigroup a => a -> a -> a
<> [Char] -> FastString
mkFastString (forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$ Int
nforall a. Num a => a -> a -> a
+Int
1))
          loadOwnArg :: Int -> (JExpr, JStat)
loadOwnArg Int
n = (forall a. ToJExpr a => a -> JExpr
toJExpr Int
n, Int -> JExpr
jsReg (Int
nforall a. Num a => a -> a -> a
+Int
1) JExpr -> JExpr -> JStat
|= Int -> JExpr
prop Int
n)
      in  JExpr -> [(JExpr, JStat)] -> JStat -> JStat
SwitchStat JExpr
r (forall a b. (a -> b) -> [a] -> [b]
map Int -> (JExpr, JStat)
loadOwnArg [Int
127,Int
126..Int
1]) forall a. Monoid a => a
mempty

-- general utilities
-- move the first n registers, starting at R2, m places up (do not use with negative m)
moveRegs2 :: JStat
moveRegs2 :: JStat
moveRegs2 = FastString -> Ident
TxtI FastString
"h$moveRegs2" Ident -> JExpr -> JStat
||= forall a. ToSat a => a -> JExpr
jLam JExpr -> JExpr -> JStat
moveSwitch
  where
    moveSwitch :: JExpr -> JExpr -> JStat
moveSwitch JExpr
n JExpr
m = JExpr -> [(JExpr, JStat)] -> JStat -> JStat
SwitchStat ((JExpr
n JExpr -> JExpr -> JExpr
.<<. JExpr
8) JExpr -> JExpr -> JExpr
.|. JExpr
m) [(JExpr, JStat)]
switchCases (JExpr -> JExpr -> JStat
defaultCase JExpr
n JExpr
m)
    -- fast cases
    switchCases :: [(JExpr, JStat)]
switchCases = [Int -> Int -> (JExpr, JStat)
switchCase Int
n Int
m | Int
n <- [Int
1..Int
5], Int
m <- [Int
1..Int
4]]
    switchCase :: Int -> Int -> (JExpr, JStat)
    switchCase :: Int -> Int -> (JExpr, JStat)
switchCase Int
n Int
m = (forall a. ToJExpr a => a -> JExpr
toJExpr forall a b. (a -> b) -> a -> b
$
                      (Int
n forall a. Bits a => a -> Int -> a
`Bits.shiftL` Int
8) forall a. Bits a => a -> a -> a
Bits..|. Int
m
                     , forall a. Monoid a => [a] -> a
mconcat (forall a b. (a -> b) -> [a] -> [b]
map (Int -> Int -> JStat
`moveRegFast` Int
m) [Int
nforall a. Num a => a -> a -> a
+Int
1,Int
n..Int
2])
                       forall a. Semigroup a => a -> a -> a
<> Maybe JsLabel -> JStat
BreakStat forall a. Maybe a
Nothing {-[j| break; |]-})
    moveRegFast :: Int -> Int -> JStat
moveRegFast Int
n Int
m = Int -> JExpr
jsReg (Int
nforall a. Num a => a -> a -> a
+Int
m) JExpr -> JExpr -> JStat
|= Int -> JExpr
jsReg Int
n
    -- fallback
    defaultCase :: JExpr -> JExpr -> JStat
defaultCase JExpr
n JExpr
m =
      JExpr -> (JExpr -> JExpr) -> (JExpr -> JStat) -> JStat
loop JExpr
n (JExpr -> JExpr -> JExpr
.>.JExpr
0) (\JExpr
i -> FastString -> [JExpr] -> JStat
appS FastString
"h$setReg" [JExpr
iforall a. Num a => a -> a -> a
+JExpr
1forall a. Num a => a -> a -> a
+JExpr
m, FastString -> [JExpr] -> JExpr
app FastString
"h$getReg" [JExpr
iforall a. Num a => a -> a -> a
+JExpr
1]] forall a. Monoid a => a -> a -> a
`mappend` JExpr -> JStat
postDecrS JExpr
i)


-- Initalize a variable sized object from an array of values
initClosure :: StgToJSConfig -> JExpr -> JExpr -> JExpr -> JExpr
initClosure :: StgToJSConfig -> JExpr -> JExpr -> JExpr -> JExpr
initClosure StgToJSConfig
cfg JExpr
entry JExpr
values JExpr
ccs = FastString -> [JExpr] -> JExpr
app FastString
"h$init_closure"
  [ Closure -> JExpr
newClosure forall a b. (a -> b) -> a -> b
$ Closure
      { clEntry :: JExpr
clEntry  = JExpr
entry
      , clField1 :: JExpr
clField1 = JExpr
null_
      , clField2 :: JExpr
clField2 = JExpr
null_
      , clMeta :: JExpr
clMeta   = JExpr
0
      , clCC :: Maybe JExpr
clCC     = if StgToJSConfig -> Bool
csProf StgToJSConfig
cfg then forall a. a -> Maybe a
Just JExpr
ccs else forall a. Maybe a
Nothing
      }
  , JExpr
values
  ]

-- | Return an expression for every field of the given Id
getIdFields :: Id -> G [TypedExpr]
getIdFields :: Id -> G [TypedExpr]
getIdFields Id
i = Id -> [JExpr] -> [TypedExpr]
assocIdExprs Id
i forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> G [JExpr]
varsForId Id
i

-- | Store fields of Id into the given target expressions
storeIdFields :: Id -> [TypedExpr] -> G JStat
storeIdFields :: Id -> [TypedExpr] -> G JStat
storeIdFields Id
i [TypedExpr]
dst = do
  [TypedExpr]
fields <- Id -> G [TypedExpr]
getIdFields Id
i
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (HasDebugCallStack => [TypedExpr] -> [TypedExpr] -> JStat
assignCoerce1 [TypedExpr]
dst [TypedExpr]
fields)