{-# 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.Unsat.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.Utils
import GHC.StgToJS.Rts.Types
import GHC.StgToJS.Stack
import GHC.StgToJS.Ids

import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Types.CostCentre
import GHC.Types.RepType (mightBeFunTy)

import GHC.Stg.Syntax

import GHC.Builtin.Names

import GHC.Core.TyCon
import GHC.Core.DataCon
import GHC.Core.Type hiding (typeSize)

import GHC.Utils.Misc
import GHC.Utils.Monad
import GHC.Utils.Panic
import GHC.Utils.Outputable (vcat, ppr)
import GHC.Data.FastString

import qualified Data.Bits as Bits
import Data.Monoid
import Data.Array

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


-- | 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

    -- let-no-escape
    | Just Int
n <- ExprCtx -> Id -> Maybe Int
ctxLneBindingStackSize ExprCtx
ctx Id
i
    = do
      [JExpr]
as'      <- (StgArg -> StateT GenState IO [JExpr])
-> [StgArg] -> StateT GenState IO [JExpr]
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Traversable f) =>
(a -> m [b]) -> f a -> m [b]
concatMapM HasDebugCallStack => StgArg -> StateT GenState IO [JExpr]
StgArg -> StateT GenState IO [JExpr]
genArg [StgArg]
args
      JExpr
ei       <- Id -> G JExpr
varForEntryId Id
i
      let ra :: JStat
ra = [JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat ([JStat] -> JStat) -> ([JStat] -> [JStat]) -> [JStat] -> JStat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [JStat] -> [JStat]
forall a. [a] -> [a]
reverse ([JStat] -> JStat) -> [JStat] -> JStat
forall a b. (a -> b) -> a -> b
$
                 (StgReg -> JExpr -> JStat) -> [StgReg] -> [JExpr] -> [JStat]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\StgReg
r JExpr
a -> StgReg -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr StgReg
r JExpr -> JExpr -> JStat
|= JExpr
a) [StgReg
R1 ..] [JExpr]
as'
      JStat
p <- Int -> ExprCtx -> G JStat
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)
      (JStat, ExprResult) -> G (JStat, ExprResult)
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStat
ra JStat -> JStat -> JStat
forall a. Semigroup a => a -> a -> a
<> JStat
p JStat -> JStat -> JStat
forall a. Semigroup a => a -> a -> a
<> JStat
a JStat -> JStat -> JStat
forall a. Semigroup a => a -> a -> a
<> JExpr -> JStat
returnS JExpr
ei, ExprResult
ExprCont)

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

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

    -- 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]
Id -> [VarType]
idVt Id
i
    , VarType -> Bool
isUnboxable VarType
vt
    , ExprCtx -> Id -> Bool
ctxIsEvaluated ExprCtx
ctx Id
i
    = do
      let c :: JExpr
c = [JExpr] -> JExpr
forall a. HasCallStack => [a] -> a
head ((TypedExpr -> [JExpr]) -> [TypedExpr] -> [JExpr]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TypedExpr -> [JExpr]
typex_expr ([TypedExpr] -> [JExpr]) -> [TypedExpr] -> [JExpr]
forall a b. (a -> b) -> a -> b
$ ExprCtx -> [TypedExpr]
ctxTarget ExprCtx
ctx)
      [JExpr]
is <- Id -> StateT GenState IO [JExpr]
varsForId Id
i
      case [JExpr]
is of
        [JExpr
i'] ->
          (JStat, ExprResult) -> G (JStat, ExprResult)
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ( JExpr
c JExpr -> JExpr -> JStat
|= JExpr -> JExpr -> JExpr -> JExpr
if_ (JExpr -> JExpr
isObject JExpr
i') (JExpr -> JExpr
closureField1 JExpr
i') JExpr
i'
                 , Maybe [JExpr] -> ExprResult
ExprInline Maybe [JExpr]
forall a. Maybe a
Nothing
                 )
        [JExpr]
_ -> [Char] -> G (JStat, ExprResult)
forall a. HasCallStack => [Char] -> a
panic [Char]
"genApp: invalid size"

    -- 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
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 (TypedExpr -> [JExpr]) -> [TypedExpr] -> [JExpr]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TypedExpr -> [JExpr]
typex_expr (ExprCtx -> [TypedExpr]
ctxTarget ExprCtx
ctx) of
                 [JExpr
t] | StgToJSConfig -> Bool
csAssertRts StgToJSConfig
settings ->
                         JExpr -> JStat -> JStat -> JStat
ifS (JExpr -> JExpr
isObject JExpr
t JExpr -> JExpr -> JExpr
.&&. JExpr -> JExpr
isThunk JExpr
t)
                             (FastString -> [JExpr] -> JStat
appS FastString
"throw" [FastString -> JExpr
String FastString
"unexpected thunk"]) -- yuck
                             JStat
forall a. Monoid a => a
mempty
                 [JExpr]
_   -> JStat
forall a. Monoid a => a
mempty
      (JStat, ExprResult) -> G (JStat, ExprResult)
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStat
a JStat -> JStat -> JStat
forall a. Monoid a => a -> a -> a
`mappend` JStat
ww, Maybe [JExpr] -> ExprResult
ExprInline Maybe [JExpr]
forall a. Maybe a
Nothing)


    -- 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 <- (StgArg -> StateT GenState IO [JExpr])
-> [StgArg] -> StateT GenState IO [JExpr]
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Traversable f) =>
(a -> m [b]) -> f a -> m [b]
concatMapM HasDebugCallStack => StgArg -> StateT GenState IO [JExpr]
StgArg -> StateT GenState IO [JExpr]
genArg [StgArg]
args
      case [JExpr]
as of
        [JExpr
ai] -> do
          let t :: JExpr
t = [JExpr] -> JExpr
forall a. HasCallStack => [a] -> a
head ((TypedExpr -> [JExpr]) -> [TypedExpr] -> [JExpr]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TypedExpr -> [JExpr]
typex_expr (ExprCtx -> [TypedExpr]
ctxTarget ExprCtx
ctx))
              a' :: Id
a' = case [StgArg]
args of
                [StgVarArg Id
a'] -> Id
a'
                [StgArg]
_              -> [Char] -> Id
forall a. HasCallStack => [Char] -> a
panic [Char]
"genApp: unexpected arg"
          if Id -> Bool
isStrictId Id
a' Bool -> Bool -> Bool
|| ExprCtx -> Id -> Bool
ctxIsEvaluated ExprCtx
ctx Id
a'
            then (JStat, ExprResult) -> G (JStat, ExprResult)
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JExpr
t JExpr -> JExpr -> JStat
|= JExpr
ai, Maybe [JExpr] -> ExprResult
ExprInline Maybe [JExpr]
forall a. Maybe a
Nothing)
            else (JStat, ExprResult) -> G (JStat, ExprResult)
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JExpr -> JStat
returnS (FastString -> [JExpr] -> JExpr
app FastString
"h$e" [JExpr
ai]), ExprResult
ExprCont)
        [JExpr]
_ -> [Char] -> G (JStat, ExprResult)
forall a. HasCallStack => [Char] -> a
panic [Char]
"genApp: invalid size"

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

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

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

    -- 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 ([JExpr] -> JStat) -> StateT GenState IO [JExpr] -> G JStat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> StateT GenState IO [JExpr]
varsForId Id
i
      JStat
jmp <- [StgArg] -> JStat -> G JStat
HasDebugCallStack => [StgArg] -> JStat -> G JStat
jumpToFast [StgArg]
args JStat
is
      (JStat, ExprResult) -> G (JStat, ExprResult)
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStat
jmp, ExprResult
ExprCont)

-- 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
     JStat -> G JStat
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStat -> G JStat) -> JStat -> G JStat
forall a b. (a -> b) -> a -> b
$ [JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat
      [ [JExpr] -> [JExpr] -> JStat
assignAllReverseOrder [JExpr]
jsRegsFromR2 [JExpr]
vars
      , JStat
load_app_in_r1
      , JExpr -> JStat
returnS (JExpr -> JExpr
closureEntry JExpr
ii)
      ]
  | Bool
otherwise   = do
     JExpr
ei <- Id -> G JExpr
varForEntryId Id
i
     JStat -> G JStat
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStat -> G JStat) -> JStat -> G JStat
forall a b. (a -> b) -> a -> b
$ [JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat
      [ [JExpr] -> [JExpr] -> JStat
assignAllReverseOrder [JExpr]
jsRegsFromR2 [JExpr]
vars
      , JStat
load_app_in_r1
      , JExpr -> JStat
returnS JExpr
ei
      ]

-- | 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 <- (StgArg -> StateT GenState IO [JExpr])
-> [StgArg] -> StateT GenState IO [JExpr]
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Traversable f) =>
(a -> m [b]) -> f a -> m [b]
concatMapM HasDebugCallStack => StgArg -> StateT GenState IO [JExpr]
StgArg -> StateT GenState IO [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
  JStat -> G JStat
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JStat -> G JStat) -> JStat -> G JStat
forall a b. (a -> b) -> a -> b
$ [JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat
    [ [JExpr] -> [JExpr] -> JStat
assignAllReverseOrder [JExpr]
jsRegsFromR2 [JExpr]
vars
    , JStat
load_app_in_r1
    , case Either JExpr JExpr
ap_fun of
        -- 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]
(Int -> ApplyConv -> ShowS)
-> (ApplyConv -> [Char])
-> ([ApplyConv] -> ShowS)
-> Show ApplyConv
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ApplyConv -> ShowS
showsPrec :: Int -> ApplyConv -> ShowS
$cshow :: ApplyConv -> [Char]
show :: ApplyConv -> [Char]
$cshowList :: [ApplyConv] -> ShowS
showList :: [ApplyConv] -> ShowS
Show,ApplyConv -> ApplyConv -> Bool
(ApplyConv -> ApplyConv -> Bool)
-> (ApplyConv -> ApplyConv -> Bool) -> Eq ApplyConv
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ApplyConv -> ApplyConv -> Bool
== :: ApplyConv -> ApplyConv -> Bool
$c/= :: ApplyConv -> ApplyConv -> Bool
/= :: ApplyConv -> ApplyConv -> Bool
Eq,Eq ApplyConv
Eq ApplyConv =>
(ApplyConv -> ApplyConv -> Ordering)
-> (ApplyConv -> ApplyConv -> Bool)
-> (ApplyConv -> ApplyConv -> Bool)
-> (ApplyConv -> ApplyConv -> Bool)
-> (ApplyConv -> ApplyConv -> Bool)
-> (ApplyConv -> ApplyConv -> ApplyConv)
-> (ApplyConv -> ApplyConv -> ApplyConv)
-> Ord ApplyConv
ApplyConv -> ApplyConv -> Bool
ApplyConv -> ApplyConv -> Ordering
ApplyConv -> ApplyConv -> ApplyConv
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: ApplyConv -> ApplyConv -> Ordering
compare :: ApplyConv -> ApplyConv -> Ordering
$c< :: ApplyConv -> ApplyConv -> Bool
< :: ApplyConv -> ApplyConv -> Bool
$c<= :: ApplyConv -> ApplyConv -> Bool
<= :: ApplyConv -> ApplyConv -> Bool
$c> :: ApplyConv -> ApplyConv -> Bool
> :: ApplyConv -> ApplyConv -> Bool
$c>= :: ApplyConv -> ApplyConv -> Bool
>= :: ApplyConv -> ApplyConv -> Bool
$cmax :: ApplyConv -> ApplyConv -> ApplyConv
max :: ApplyConv -> ApplyConv -> ApplyConv
$cmin :: ApplyConv -> ApplyConv -> ApplyConv
min :: ApplyConv -> ApplyConv -> ApplyConv
Ord)

-- | 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 ([Char] -> FastString) -> [Char] -> FastString
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
forall a. Monoid a => [a] -> a
mconcat
                                  [ [Char]
"h$ap_", Int -> [Char]
forall a. Show a => a -> [Char]
show Int
nargs
                                  , [Char]
"_"    , Int -> [Char]
forall a. Show a => a -> [Char]
show Int
nvars
                                  , case ApplyConv
conv of
                                      ApplyConv
RegsConv  -> [Char]
"_fast"
                                      ApplyConv
StackConv -> [Char]
""
                                  ]

-- | 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 ApplySpec -> [ApplySpec] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ApplySpec]
applySpec
    then JExpr -> Maybe JExpr
forall a. a -> Maybe a
Just (ApplySpec -> JExpr
specApplyExpr ApplySpec
spec)
    else Maybe JExpr
forall a. Maybe a
Nothing

-- | 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 = [StgArg] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [StgArg]
args
  , specVars :: Int
specVars = [JExpr] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [JExpr]
vars
  }

-- | 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  -> Either JExpr JExpr -> G (Either JExpr JExpr)
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JExpr -> Either JExpr JExpr
forall a b. b -> Either a b
Right JExpr
e)
    Maybe JExpr
Nothing -> Either JExpr JExpr -> G (Either JExpr JExpr)
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JExpr -> Either JExpr JExpr
forall a b. a -> Either a b
Left (ApplyConv -> JExpr
genericApplyExpr (ApplySpec -> ApplyConv
specConv ApplySpec
spec)))


-- | 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]
(Int -> ApplySpec -> ShowS)
-> (ApplySpec -> [Char])
-> ([ApplySpec] -> ShowS)
-> Show ApplySpec
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ApplySpec -> ShowS
showsPrec :: Int -> ApplySpec -> ShowS
$cshow :: ApplySpec -> [Char]
show :: ApplySpec -> [Char]
$cshowList :: [ApplySpec] -> ShowS
showList :: [ApplySpec] -> ShowS
Show,ApplySpec -> ApplySpec -> Bool
(ApplySpec -> ApplySpec -> Bool)
-> (ApplySpec -> ApplySpec -> Bool) -> Eq ApplySpec
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ApplySpec -> ApplySpec -> Bool
== :: ApplySpec -> ApplySpec -> Bool
$c/= :: ApplySpec -> ApplySpec -> Bool
/= :: ApplySpec -> ApplySpec -> Bool
Eq,Eq ApplySpec
Eq ApplySpec =>
(ApplySpec -> ApplySpec -> Ordering)
-> (ApplySpec -> ApplySpec -> Bool)
-> (ApplySpec -> ApplySpec -> Bool)
-> (ApplySpec -> ApplySpec -> Bool)
-> (ApplySpec -> ApplySpec -> Bool)
-> (ApplySpec -> ApplySpec -> ApplySpec)
-> (ApplySpec -> ApplySpec -> ApplySpec)
-> Ord ApplySpec
ApplySpec -> ApplySpec -> Bool
ApplySpec -> ApplySpec -> Ordering
ApplySpec -> ApplySpec -> ApplySpec
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: ApplySpec -> ApplySpec -> Ordering
compare :: ApplySpec -> ApplySpec -> Ordering
$c< :: ApplySpec -> ApplySpec -> Bool
< :: ApplySpec -> ApplySpec -> Bool
$c<= :: ApplySpec -> ApplySpec -> Bool
<= :: ApplySpec -> ApplySpec -> Bool
$c> :: ApplySpec -> ApplySpec -> Bool
> :: ApplySpec -> ApplySpec -> Bool
$c>= :: ApplySpec -> ApplySpec -> Bool
>= :: ApplySpec -> ApplySpec -> Bool
$cmax :: ApplySpec -> ApplySpec -> ApplySpec
max :: ApplySpec -> ApplySpec -> ApplySpec
$cmin :: ApplySpec -> ApplySpec -> ApplySpec
min :: ApplySpec -> ApplySpec -> ApplySpec
Ord)

-- | 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 <- [Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int
nargsInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)..(Int
nargsInt -> Int -> Int
forall a. Num a => a -> a -> a
*Int
2)]
            ]

-- | 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 = Int -> Int -> Int
forall a. Bits a => a -> Int -> a
Bits.shiftL (ApplySpec -> Int
specVars ApplySpec
spec) Int
8 Int -> Int -> Int
forall a. Bits a => a -> a -> a
Bits..|. (ApplySpec -> Int
specArgs ApplySpec
spec)

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

-- | 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 = [JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat
  [ FastString -> Ident
TxtI FastString
"h$apply" Ident -> JExpr -> JStat
||= JVal -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr ([JExpr] -> JVal
JList [])
  , FastString -> Ident
TxtI FastString
"h$paps"  Ident -> JExpr -> JStat
||= JVal -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr ([JExpr] -> JVal
JList [])
  , JExpr -> [JExpr] -> JStat
ApplStat (FastString -> JExpr
var FastString
"h$initStatic" JExpr -> FastString -> JExpr
.^ FastString
"push")
    [ JVal -> JExpr
ValExpr (JVal -> JExpr) -> JVal -> JExpr
forall a b. (a -> b) -> a -> b
$ [Ident] -> JStat -> JVal
JFunc [] (JStat -> JVal) -> JStat -> JVal
forall a b. (a -> b) -> a -> b
$ [JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat
        [ (JExpr -> JStat)
-> (JExpr -> JExpr)
-> (JExpr -> JStat)
-> (JExpr -> JStat)
-> JStat
jFor (JExpr -> JExpr -> JStat
|= JExpr
zero_) (JExpr -> JExpr -> JExpr
.<. Integer -> JExpr
Int Integer
65536) JExpr -> JStat
preIncrS
          (\JExpr
j -> FastString -> JExpr
var FastString
"h$apply" JExpr -> JExpr -> JExpr
.! JExpr
j JExpr -> JExpr -> JStat
|= FastString -> JExpr
var FastString
"h$ap_gen")
        , (JExpr -> JStat)
-> (JExpr -> JExpr)
-> (JExpr -> JStat)
-> (JExpr -> JStat)
-> JStat
jFor (JExpr -> JExpr -> JStat
|= JExpr
zero_) (JExpr -> JExpr -> JExpr
.<. Integer -> JExpr
Int Integer
128) JExpr -> JStat
preIncrS
          (\JExpr
j -> FastString -> JExpr
var FastString
"h$paps" JExpr -> JExpr -> JExpr
.! JExpr
j JExpr -> JExpr -> JStat
|= FastString -> JExpr
var FastString
"h$pap_gen")
        , [JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat ((ApplySpec -> JStat) -> [ApplySpec] -> [JStat]
forall a b. (a -> b) -> [a] -> [b]
map ApplySpec -> JStat
assignSpec [ApplySpec]
applySpec)
        , [JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat ((Int -> JStat) -> [Int] -> [JStat]
forall a b. (a -> b) -> [a] -> [b]
map Int -> JStat
assignPap [Int]
specPap)
        ]
    ]
  ]
  where
    assignSpec :: ApplySpec -> JStat
    assignSpec :: ApplySpec -> JStat
assignSpec ApplySpec
spec = case ApplySpec -> ApplyConv
specConv ApplySpec
spec of
      -- 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  -> JStat
forall a. Monoid a => a
mempty

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

-- | 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 <- (StgArg -> StateT GenState IO [JExpr])
-> [StgArg] -> StateT GenState IO [JExpr]
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Traversable f) =>
(a -> m [b]) -> f a -> m [b]
concatMapM HasDebugCallStack => StgArg -> StateT GenState IO [JExpr]
StgArg -> StateT GenState IO [JExpr]
genArg [StgArg]
args
  let spec :: ApplySpec
spec = ApplyConv -> [StgArg] -> [JExpr] -> ApplySpec
mkApplySpec ApplyConv
StackConv [StgArg]
args [JExpr]
vars
  ApplySpec -> G (Either JExpr JExpr)
selectApply ApplySpec
spec G (Either JExpr JExpr)
-> (Either JExpr JExpr -> G JStat) -> G JStat
forall a b.
StateT GenState IO a
-> (a -> StateT GenState IO b) -> StateT GenState IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Right JExpr
app -> [JExpr] -> G JStat
push ([JExpr] -> G JStat) -> [JExpr] -> G JStat
forall a b. (a -> b) -> a -> b
$ [JExpr] -> [JExpr]
forall a. [a] -> [a]
reverse ([JExpr] -> [JExpr]) -> [JExpr] -> [JExpr]
forall a b. (a -> b) -> a -> b
$ JExpr
app JExpr -> [JExpr] -> [JExpr]
forall a. a -> [a] -> [a]
: [JExpr]
vars
    Left  JExpr
app -> [JExpr] -> G JStat
push ([JExpr] -> G JStat) -> [JExpr] -> G JStat
forall a b. (a -> b) -> a -> b
$ [JExpr] -> [JExpr]
forall a. [a] -> [a]
reverse ([JExpr] -> [JExpr]) -> [JExpr] -> [JExpr]
forall a b. (a -> b) -> a -> b
$ JExpr
app JExpr -> [JExpr] -> [JExpr]
forall a. a -> [a] -> [a]
: ApplySpec -> JExpr
specTagExpr ApplySpec
spec JExpr -> [JExpr] -> [JExpr]
forall a. a -> [a] -> [a]
: [JExpr]
vars

-- | 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 = (JExpr -> [JStat]) -> JStat
forall a. ToSat a => a -> JStat
jVar \JExpr
cf ->
      [ StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
cfg (FastString -> JExpr
jString FastString
"h$ap_gen")
      , JExpr
cf JExpr -> JExpr -> JStat
|= JExpr -> JExpr
closureEntry JExpr
r1
        -- switch on closure type
      , JExpr -> [(JExpr, JStat)] -> JStat -> JStat
SwitchStat (JExpr -> JExpr
entryClosureType JExpr
cf)
        [ (ClosureType -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr ClosureType
Thunk    , StgToJSConfig -> JExpr -> JStat
thunk_case StgToJSConfig
cfg JExpr
cf)
        , (ClosureType -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr ClosureType
Fun      , JExpr -> JExpr -> JStat
fun_case JExpr
cf (JExpr -> JExpr
funArity' JExpr
cf))
        , (ClosureType -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr ClosureType
Pap      , JExpr -> JExpr -> JStat
fun_case JExpr
cf (JExpr -> JExpr
papArity JExpr
r1))
        , (ClosureType -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr ClosureType
Blackhole, StgToJSConfig -> JStat
blackhole_case StgToJSConfig
cfg)
        ]
        (JExpr -> JStat
default_case JExpr
cf)
      ]

    -- info 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  = CIStatic
forall a. Monoid a => a
mempty
      }

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

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

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

    fun_case :: JExpr -> JExpr -> JStat
fun_case JExpr
c JExpr
arity = (JExpr
 -> JExpr
 -> JExpr
 -> JExpr
 -> JExpr
 -> JExpr
 -> JExpr
 -> JExpr
 -> JExpr
 -> [JStat])
-> JStat
forall a. ToSat a => a -> JStat
jVar \JExpr
tag JExpr
needed_args JExpr
needed_regs JExpr
given_args JExpr
given_regs JExpr
newTag JExpr
newAp JExpr
p JExpr
dat ->
      [ JExpr
tag         JExpr -> JExpr -> JStat
|= JExpr
stack JExpr -> JExpr -> JExpr
.! (JExpr
sp JExpr -> JExpr -> JExpr
forall a. Num a => a -> a -> a
- JExpr
1) -- 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: " JExpr -> JExpr -> JExpr
forall a. Num a => a -> a -> a
+ JExpr
given_args
                    JExpr -> JExpr -> JExpr
forall a. Num a => a -> a -> a
+ FastString -> JExpr
jString FastString
" regs: " JExpr -> JExpr -> JExpr
forall a. Num a => a -> a -> a
+ JExpr
given_regs)
      , JExpr -> [JStat] -> [JStat] -> JStat
ifBlockS (JExpr
given_args JExpr -> JExpr -> JExpr
.===. JExpr
needed_args)
        --------------------------------
        -- 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 -> [JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat
            [ FastString -> [JExpr] -> JStat
appS FastString
"h$setReg" [JExpr
iJExpr -> JExpr -> JExpr
forall a. Num a => a -> a -> a
+JExpr
2, JExpr
stack JExpr -> JExpr -> JExpr
.! (JExpr
spJExpr -> JExpr -> JExpr
forall a. Num a => a -> a -> a
-JExpr
2JExpr -> JExpr -> JExpr
forall a. Num a => a -> a -> a
-JExpr
i)]
            , JExpr -> JStat
postIncrS JExpr
i
            ]
        -- drop register values from the stack
        , JExpr
sp JExpr -> JExpr -> JStat
|= JExpr
sp JExpr -> JExpr -> JExpr
forall a. Num a => a -> a -> a
- JExpr
given_regs JExpr -> JExpr -> JExpr
forall a. Num a => a -> a -> a
- JExpr
2
        -- 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: " JExpr -> JExpr -> JExpr
forall a. Num a => a -> a -> a
+ JExpr
needed_args
                          JExpr -> JExpr -> JExpr
forall a. Num a => a -> a -> a
+ FastString -> JExpr
jString FastString
" regs: " JExpr -> JExpr -> JExpr
forall a. Num a => a -> a -> a
+ JExpr
needed_regs)
            -- load needed register values
            , JExpr -> (JExpr -> JExpr) -> (JExpr -> JStat) -> JStat
loop JExpr
0 (JExpr -> JExpr -> JExpr
.<. JExpr
needed_regs) \JExpr
i -> [JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat
                [ StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
cfg (FastString -> JExpr
jString FastString
"h$ap_gen: loading register: " JExpr -> JExpr -> JExpr
forall a. Num a => a -> a -> a
+ JExpr
i)
                , FastString -> [JExpr] -> JStat
appS FastString
"h$setReg" [JExpr
iJExpr -> JExpr -> JExpr
forall a. Num a => a -> a -> a
+JExpr
2, JExpr
stack JExpr -> JExpr -> JExpr
.! (JExpr
spJExpr -> JExpr -> JExpr
forall a. Num a => a -> a -> a
-JExpr
2JExpr -> JExpr -> JExpr
forall a. Num a => a -> a -> a
-JExpr
i)]
                , JExpr -> JStat
postIncrS JExpr
i
                ]
            -- compute new tag with consumed register values and args removed
            , JExpr
newTag JExpr -> JExpr -> JStat
|= ((JExpr
given_regsJExpr -> JExpr -> JExpr
forall a. Num a => a -> a -> a
-JExpr
needed_regs)JExpr -> JExpr -> JExpr
.<<.JExpr
8) JExpr -> JExpr -> JExpr
.|. (JExpr
given_args JExpr -> JExpr -> JExpr
forall a. Num a => a -> a -> a
- JExpr
needed_args)
            -- 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: " JExpr -> JExpr -> JExpr
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 JExpr -> JExpr -> JExpr
forall a. Num a => a -> a -> a
- JExpr
needed_regs) JStat -> JStat -> JStat
forall a. Semigroup a => a -> a -> a
<> (JExpr
stack JExpr -> JExpr -> JExpr
.! (JExpr
sp JExpr -> JExpr -> JExpr
forall a. Num a => a -> a -> a
- JExpr
1) JExpr -> JExpr -> JStat
|= JExpr
newTag))
                   (JExpr
sp JExpr -> JExpr -> JStat
|= JExpr
sp JExpr -> JExpr -> JExpr
forall a. Num a => a -> a -> a
- JExpr
needed_regs JExpr -> JExpr -> JExpr
forall a. Num a => a -> a -> a
- JExpr
1)

            -- 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_regsJExpr -> JExpr -> JExpr
forall a. Num a => a -> a -> a
-JExpr
given_regs) JExpr -> JExpr -> JExpr
.<<. JExpr
8) JExpr -> JExpr -> JExpr
.|. (JExpr
needed_argsJExpr -> JExpr -> JExpr
forall a. Num a => a -> a -> a
-JExpr
given_args)
            , JExpr
dat    JExpr -> JExpr -> JStat
|= [JExpr] -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr [JExpr
r1, JExpr
newTag]
            , JExpr -> (JExpr -> JExpr) -> (JExpr -> JStat) -> JStat
loop JExpr
0 (JExpr -> JExpr -> JExpr
.<. JExpr
given_regs) \JExpr
i -> [JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat
                [ (JExpr
dat JExpr -> FastString -> JExpr
.^ FastString
"push") JExpr -> [JExpr] -> JStat
`ApplStat` [JExpr
stack JExpr -> JExpr -> JExpr
.! (JExpr
sp JExpr -> JExpr -> JExpr
forall a. Num a => a -> a -> a
- JExpr
i JExpr -> JExpr -> JExpr
forall a. Num a => a -> a -> a
- JExpr
2)]
                , JExpr -> JStat
postIncrS JExpr
i
                ]

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

            -- 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 =
   Ident -> (JExpr -> JStat) -> JStat
forall a. ToSat a => Ident -> a -> JStat
jFun (FastString -> Ident
TxtI FastString
"h$ap_gen_fast") \JExpr
tag -> (JExpr -> [JStat]) -> JStat
forall a. ToSat a => a -> JStat
jVar \JExpr
c ->
      [StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (FastString -> JExpr
jString FastString
"h$ap_gen_fast: " JExpr -> JExpr -> JExpr
forall a. Num a => a -> a -> a
+ JExpr
tag)
      , JExpr
c JExpr -> JExpr -> JStat
|= JExpr -> JExpr
closureEntry JExpr
r1
      , JExpr -> [(JExpr, JStat)] -> JStat -> JStat
SwitchStat (JExpr -> JExpr
entryClosureType JExpr
c)
        [ (ClosureType -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr ClosureType
Thunk, StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (FastString -> JExpr
jString FastString
"h$ap_gen_fast: thunk")
           JStat -> JStat -> JStat
forall a. Semigroup a => a -> a -> a
<> JExpr -> JExpr -> JStat
pushStackApply JExpr
c JExpr
tag
           JStat -> JStat -> JStat
forall a. Semigroup a => a -> a -> a
<> JExpr -> JStat
returnS JExpr
c)
        , (ClosureType -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr ClosureType
Fun, (JExpr -> [JStat]) -> JStat
forall a. ToSat a => a -> JStat
jVar \JExpr
farity ->
                               [ JExpr
farity JExpr -> JExpr -> JStat
|= JExpr -> JExpr
funArity' JExpr
c
                               , StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (FastString -> JExpr
jString FastString
"h$ap_gen_fast: fun " JExpr -> JExpr -> JExpr
forall a. Num a => a -> a -> a
+ JExpr
farity)
                               , JExpr -> JExpr -> JExpr -> JStat
funCase JExpr
c JExpr
tag JExpr
farity
                               ])
        , (ClosureType -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr ClosureType
Pap, (JExpr -> [JStat]) -> JStat
forall a. ToSat a => a -> JStat
jVar \JExpr
parity ->
                               [ JExpr
parity JExpr -> JExpr -> JStat
|= JExpr -> JExpr
papArity JExpr
r1
                               , StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (FastString -> JExpr
jString FastString
"h$ap_gen_fast: pap " JExpr -> JExpr -> JExpr
forall a. Num a => a -> a -> a
+ JExpr
parity)
                               , JExpr -> JExpr -> JExpr -> JStat
funCase JExpr
c JExpr
tag JExpr
parity
                               ])
        , (ClosureType -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr ClosureType
Con, StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (FastString -> JExpr
jString FastString
"h$ap_gen_fast: con")
            JStat -> JStat -> JStat
forall a. Semigroup a => a -> a -> a
<> JExpr -> JStat -> JStat
jwhenS (JExpr
tag JExpr -> JExpr -> JExpr
.!=. JExpr
0)
                (FastString -> [JExpr] -> JStat
appS FastString
"throw" [FastString -> JExpr
jString FastString
"h$ap_gen_fast: invalid apply"])
                        JStat -> JStat -> JStat
forall a. Semigroup a => a -> a -> a
<> JExpr -> JStat
returnS JExpr
c)
        , (ClosureType -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr ClosureType
Blackhole, StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (FastString -> JExpr
jString FastString
"h$ap_gen_fast: blackhole")
            JStat -> JStat -> JStat
forall a. Semigroup a => a -> a -> a
<> JExpr -> JExpr -> JStat
pushStackApply JExpr
c JExpr
tag
            JStat -> JStat -> JStat
forall a. Semigroup a => a -> a -> a
<> StgToJSConfig -> [JExpr] -> JStat
push' StgToJSConfig
s [JExpr
r1, FastString -> JExpr
var FastString
"h$return"]
            JStat -> JStat -> JStat
forall a. Semigroup a => a -> a -> a
<> JExpr -> JStat
returnS (FastString -> [JExpr] -> JExpr
app FastString
"h$blockOnBlackhole" [JExpr
r1]))
        ] (JStat -> JStat) -> JStat -> JStat
forall a b. (a -> b) -> a -> b
$ FastString -> [JExpr] -> JStat
appS FastString
"throw" [FastString -> JExpr
jString FastString
"h$ap_gen_fast: unexpected closure type: " JExpr -> JExpr -> JExpr
forall a. Num a => a -> a -> a
+ JExpr -> JExpr
entryClosureType JExpr
c]
      ]

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

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


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

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

-- | 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 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
&& Int
nvars Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
    then ClosureInfo -> JStat -> JStat
closure ClosureInfo
info0 JStat
body0
    else ClosureInfo -> JStat -> JStat
closure ClosureInfo
info JStat
body
  where
    info :: ClosureInfo
info  = Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo (FastString -> Ident
TxtI FastString
fun_name) (Int -> [VarType] -> CIRegs
CIRegs Int
0 [VarType
PtrV]) FastString
fun_name (Int -> CILayout
CILayoutUnknown Int
nvars) CIType
CIStackFrame CIStatic
forall a. Monoid a => a
mempty
    info0 :: ClosureInfo
info0 = Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo (FastString -> Ident
TxtI FastString
fun_name) (Int -> [VarType] -> CIRegs
CIRegs Int
0 [VarType
PtrV]) FastString
fun_name (Int -> [VarType] -> CILayout
CILayoutFixed Int
0 [])    CIType
CIStackFrame CIStatic
forall a. Monoid a => a
mempty

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

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

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

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


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


    -- 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 =
      (JExpr -> JExpr -> [JStat]) -> JStat
forall a. ToSat a => a -> JStat
jVar \JExpr
rs JExpr
newAp ->
        [ JExpr
rs JExpr -> JExpr -> JStat
|= (JExpr
arity JExpr -> JExpr -> JExpr
.>>. JExpr
8)
        , JExpr -> JStat
loadRegs JExpr
rs
        , JExpr
sp JExpr -> JExpr -> JStat
|= JExpr
sp JExpr -> JExpr -> JExpr
forall a. Num a => a -> a -> a
- JExpr
rs
        , JExpr
newAp JExpr -> JExpr -> JStat
|= (FastString -> JExpr
var FastString
"h$apply" JExpr -> JExpr -> JExpr
.! ((Int -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr Int
nargsJExpr -> JExpr -> JExpr
forall a. Num a => a -> a -> a
-JExpr
arity0)JExpr -> JExpr -> JExpr
.|.((Int -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr Int
nvarsJExpr -> JExpr -> JExpr
forall a. Num a => a -> a -> a
-JExpr
rs)JExpr -> JExpr -> JExpr
.<<.JExpr
8)))
        , JExpr
stack JExpr -> JExpr -> JExpr
.! JExpr
sp JExpr -> JExpr -> JStat
|= JExpr
newAp
        , StgToJSConfig -> JStat -> JStat
profStat StgToJSConfig
s JStat
pushRestoreCCS
        , StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (FastString -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr (FastString
fun_name FastString -> FastString -> FastString
forall a. Semigroup a => a -> a -> a
<> FastString
": new stack frame: ") JExpr -> JExpr -> JExpr
forall a. Num a => a -> a -> a
+ (JExpr
newAp JExpr -> FastString -> JExpr
.^ FastString
"n"))
        , JExpr -> JStat
returnS JExpr
c
        ]
      where
        loadRegs :: JExpr -> JStat
loadRegs JExpr
rs = JExpr -> [(JExpr, JStat)] -> JStat -> JStat
SwitchStat JExpr
rs [(JExpr, JStat)]
switchAlts JStat
forall a. Monoid a => a
mempty
          where
            switchAlts :: [(JExpr, JStat)]
switchAlts = (Int -> (JExpr, JStat)) -> [Int] -> [(JExpr, JStat)]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
x -> (Int -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr Int
x, Int -> JExpr
jsReg (Int
xInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) JExpr -> JExpr -> JStat
|= JExpr
stack JExpr -> JExpr -> JExpr
.! (JExpr
sp JExpr -> JExpr -> JExpr
forall a. Num a => a -> a -> a
- Int -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr Int
x))) [Int
nvars,Int
nvarsInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1..Int
1]

-- | 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 = JStat
body0
  where
      -- special case for h$ap_0_0_fast
      body0 :: JStat
body0 = if Int
nargs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
&& Int
nvars Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
        then Ident -> JStat -> JStat
forall a. ToSat a => Ident -> a -> JStat
jFun Ident
func (StgToJSConfig -> JExpr -> JStat
enter StgToJSConfig
s JExpr
r1)
        else Ident -> [Ident] -> JStat -> JStat
FuncStat Ident
func [Ident]
forall a. [a]
myFunArgs JStat
body

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

      myFunArgs :: [a]
myFunArgs = []

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

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

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

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

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

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

-- 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 = (JExpr -> [JStat]) -> JStat
forall a. ToSat a => a -> JStat
jVar \JExpr
c ->
  [ JExpr -> JStat -> JStat
jwhenS (FastString -> [JExpr] -> JExpr
app FastString
"typeof" [JExpr
ex] JExpr -> JExpr -> JExpr
.!==. JExpr
jTyObject) JStat
returnStack
  , JExpr
c JExpr -> JExpr -> JStat
|= JExpr -> JExpr
closureEntry JExpr
ex
  , JExpr -> JStat -> JStat
jwhenS (JExpr
c JExpr -> JExpr -> JExpr
.===. FastString -> JExpr
var FastString
"h$unbox_e") ((JExpr
r1 JExpr -> JExpr -> JStat
|= JExpr -> JExpr
closureField1 JExpr
ex) JStat -> JStat -> JStat
forall a. Semigroup a => a -> a -> a
<> JStat
returnStack)
  , JExpr -> [(JExpr, JStat)] -> JStat -> JStat
SwitchStat (JExpr -> JExpr
entryClosureType JExpr
c)
    [ (ClosureType -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr ClosureType
Con, JStat
forall a. Monoid a => a
mempty)
    , (ClosureType -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr ClosureType
Fun, JStat
forall a. Monoid a => a
mempty)
    , (ClosureType -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr ClosureType
Pap, JStat
returnStack)
    , (ClosureType -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr ClosureType
Blackhole, StgToJSConfig -> [JExpr] -> JStat
push' StgToJSConfig
s [FastString -> JExpr
var FastString
"h$ap_0_0", JExpr
ex, FastString -> JExpr
var FastString
"h$return"]
        JStat -> JStat -> JStat
forall a. Semigroup a => a -> a -> a
<> JExpr -> JStat
returnS (FastString -> [JExpr] -> JExpr
app FastString
"h$blockOnBlackhole" [JExpr
ex]))
    ] (JExpr -> JStat
returnS JExpr
c)
  ]

updates :: StgToJSConfig -> JStat
updates :: StgToJSConfig -> JStat
updates StgToJSConfig
s = [JStat] -> JStat
BlockStat
  [ ClosureInfo -> JStat -> JStat
closure
      (Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo (FastString -> Ident
TxtI FastString
"h$upd_frame") (Int -> [VarType] -> CIRegs
CIRegs Int
0 [VarType
PtrV]) FastString
"h$upd_frame" (Int -> [VarType] -> CILayout
CILayoutFixed Int
1 [VarType
PtrV]) CIType
CIStackFrame CIStatic
forall a. Monoid a => a
mempty)
      (JStat -> JStat) -> JStat -> JStat
forall a b. (a -> b) -> a -> b
$ (JExpr -> JExpr -> JExpr -> JExpr -> JExpr -> [JStat]) -> JStat
forall a. ToSat a => a -> JStat
jVar \JExpr
updatee JExpr
waiters JExpr
ss JExpr
si JExpr
sir ->
            let unbox_closure :: Closure
unbox_closure = Closure
                  { clEntry :: JExpr
clEntry  = FastString -> JExpr
var FastString
"h$unbox_e"
                  , clField1 :: JExpr
clField1 = JExpr
sir
                  , clField2 :: JExpr
clField2 = JExpr
null_
                  , clMeta :: JExpr
clMeta   = JExpr
0
                  , clCC :: Maybe JExpr
clCC     = Maybe JExpr
forall a. Maybe a
Nothing
                  }
                updateCC :: JExpr -> JStat
updateCC JExpr
updatee = JExpr -> JExpr
closureCC JExpr
updatee JExpr -> JExpr -> JStat
|= JExpr
jCurrentCCS
            in [ JExpr
updatee JExpr -> JExpr -> JStat
|= JExpr
stack JExpr -> JExpr -> JExpr
.! (JExpr
sp JExpr -> JExpr -> JExpr
forall a. Num a => a -> a -> a
- JExpr
1)
               , StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (FastString -> JExpr
jString FastString
"h$upd_frame updatee alloc: " JExpr -> JExpr -> JExpr
forall a. Num a => a -> a -> a
+ JExpr
updatee JExpr -> FastString -> JExpr
.^ FastString
"alloc")
               , -- 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] JStat -> JStat -> JStat
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")
                   JStat -> JStat -> JStat
forall a. Semigroup a => a -> a -> a
<> JExpr -> (JExpr -> JExpr) -> (JExpr -> JStat) -> JStat
loop JExpr
0 (JExpr -> JExpr -> JExpr
.<. JExpr
ss JExpr -> FastString -> JExpr
.^ FastString
"length") \JExpr
i -> [JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat
                        [ JExpr
si JExpr -> JExpr -> JStat
|= JExpr
ss JExpr -> JExpr -> JExpr
.! JExpr
i
                        , JExpr
sir JExpr -> JExpr -> JStat
|= (JExpr -> JExpr
closureField2 JExpr
si) JExpr -> [JExpr] -> JExpr
`ApplExpr` [JExpr
r1]
                        , JExpr -> JStat -> JStat -> JStat
ifS (FastString -> [JExpr] -> JExpr
app FastString
"typeof" [JExpr
sir] JExpr -> JExpr -> JExpr
.===. JExpr
jTyObject)
                            (CopyCC -> JExpr -> JExpr -> JStat
copyClosure CopyCC
DontCopyCC JExpr
si JExpr
sir)
                            (JExpr -> Closure -> JStat
assignClosure JExpr
si Closure
unbox_closure)
                        , JExpr -> JStat
postIncrS JExpr
i
                        ])
               , -- overwrite the object
                 JExpr -> JStat -> JStat -> JStat
ifS (FastString -> [JExpr] -> JExpr
app FastString
"typeof" [JExpr
r1] JExpr -> JExpr -> JExpr
.===. JExpr
jTyObject)
                     ([JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat [ StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (FastString -> JExpr
jString FastString
"$upd_frame: boxed: " JExpr -> JExpr -> JExpr
forall a. Num a => a -> a -> a
+ ((JExpr -> JExpr
closureEntry JExpr
r1) JExpr -> FastString -> JExpr
.^ FastString
"n"))
                              , CopyCC -> JExpr -> JExpr -> JStat
copyClosure CopyCC
DontCopyCC JExpr
updatee JExpr
r1
                              ])
                     -- 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 = r1 }))
               , StgToJSConfig -> JStat -> JStat
profStat StgToJSConfig
s (JExpr -> JStat
updateCC JExpr
updatee)
               , Int -> JStat
adjSpN' Int
2
               , StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s (FastString -> JExpr
jString FastString
"h$upd_frame: updating: "
                             JExpr -> JExpr -> JExpr
forall a. Num a => a -> a -> a
+ JExpr
updatee
                             JExpr -> JExpr -> JExpr
forall a. Num a => a -> a -> a
+ FastString -> JExpr
jString FastString
" -> "
                             JExpr -> JExpr -> JExpr
forall a. Num a => a -> a -> a
+ JExpr
r1)
               , JStat
returnStack
               ]

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

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


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

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


-- 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 ([Char] -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr ([Char] -> JExpr) -> [Char] -> JExpr
forall a b. (a -> b) -> a -> b
$ [Char]
"making pap with: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show ([JExpr] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [JExpr]
values) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" items")
      JStat -> JStat -> JStat
forall a. Monoid a => a -> a -> a
`mappend`
      StgToJSConfig
-> Bool -> Ident -> JExpr -> [JExpr] -> Maybe JExpr -> JStat
allocDynamic StgToJSConfig
s Bool
True Ident
tgt (Ident -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr Ident
entry) (JExpr
funJExpr -> [JExpr] -> [JExpr]
forall a. a -> [a] -> [a]
:JExpr
papArJExpr -> [JExpr] -> [JExpr]
forall a. a -> [a] -> [a]
:(JExpr -> JExpr) -> [JExpr] -> [JExpr]
forall a b. (a -> b) -> [a] -> [b]
map JExpr -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr [JExpr]
values')
        (if StgToJSConfig -> Bool
csProf StgToJSConfig
s then JExpr -> Maybe JExpr
forall a. a -> Maybe a
Just JExpr
jCurrentCCS else Maybe JExpr
forall a. Maybe a
Nothing)
  where
    papAr :: JExpr
papAr = JExpr -> Maybe JExpr -> JExpr
funOrPapArity JExpr
fun Maybe JExpr
forall a. Maybe a
Nothing JExpr -> JExpr -> JExpr
forall a. Num a => a -> a -> a
- Int -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr ([JExpr] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [JExpr]
values Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
256) JExpr -> JExpr -> JExpr
forall a. Num a => a -> a -> a
- JExpr
n

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

-- | 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 = (Int, Int) -> [Ident] -> Array Int Ident
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0,Int
numSpecPap) ([Ident] -> Array Int Ident) -> [Ident] -> Array Int Ident
forall a b. (a -> b) -> a -> b
$ (Int -> Ident) -> [Int] -> [Ident]
forall a b. (a -> b) -> [a] -> [b]
map (FastString -> Ident
TxtI (FastString -> Ident) -> (Int -> FastString) -> Int -> Ident
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> FastString
mkFastString ([Char] -> FastString) -> (Int -> [Char]) -> Int -> FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
"h$pap_"[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> (Int -> [Char]) -> Int -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Char]
forall a. Show a => a -> [Char]
show) [Int]
specPap

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

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

-- 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 CIStatic
forall a. Monoid a => a
mempty)
           ((JExpr -> JExpr -> JExpr -> JExpr -> JExpr -> JExpr -> [JStat])
-> JStat
forall a. ToSat a => a -> JStat
jVar \JExpr
c JExpr
f JExpr
d JExpr
pr JExpr
or JExpr
r ->
              [ JExpr
c JExpr -> JExpr -> JStat
|= JExpr -> JExpr
closureField1 JExpr
r1
              , JExpr
d JExpr -> JExpr -> JStat
|= JExpr -> JExpr
closureField2 JExpr
r1
              , JExpr
f JExpr -> JExpr -> JStat
|= JExpr -> JExpr
closureEntry  JExpr
c
              , JExpr
pr JExpr -> JExpr -> JStat
|= JExpr -> Maybe JExpr -> JExpr
funOrPapArity JExpr
c (JExpr -> Maybe JExpr
forall a. a -> Maybe a
Just JExpr
f) JExpr -> JExpr -> JExpr
.>>. JExpr
8
              , JExpr
or JExpr -> JExpr -> JStat
|= JExpr -> JExpr
papArity JExpr
r1 JExpr -> JExpr -> JExpr
.>>. JExpr
8
              , JExpr
r JExpr -> JExpr -> JStat
|= JExpr
pr JExpr -> JExpr -> JExpr
forall a. Num a => a -> a -> a
- JExpr
or
              , StgToJSConfig -> JExpr -> JExpr -> JStat
forall a. ToJExpr a => StgToJSConfig -> JExpr -> a -> JStat
assertRts StgToJSConfig
cfg
                (JExpr -> JExpr
isFun' JExpr
f JExpr -> JExpr -> JExpr
.||. JExpr -> JExpr
isPap' JExpr
f)
                (FastString -> JExpr
jString FastString
"h$pap_gen: expected function or pap")
              , StgToJSConfig -> JStat -> JStat
profStat StgToJSConfig
cfg (CostCentreStack -> JStat
enterCostCentreFun CostCentreStack
currentCCS)
              , StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
cfg (FastString -> JExpr
jString FastString
"h$pap_gen: generic pap extra args moving: " JExpr -> JExpr -> JExpr
forall a. Num a => a -> a -> a
+ JExpr
or)
              , FastString -> [JExpr] -> JStat
appS FastString
"h$moveRegs2" [JExpr
or, JExpr
r]
              , JExpr -> JExpr -> JStat
loadOwnArgs JExpr
d JExpr
r
              , JExpr
r1 JExpr -> JExpr -> JStat
|= JExpr
c
              , JExpr -> JStat
returnS JExpr
f
              ])


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

-- general utilities
-- move the first n registers, starting at R2, m places up (do not use with negative m)
moveRegs2 :: JStat
moveRegs2 :: JStat
moveRegs2 = Ident -> (JExpr -> JExpr -> JStat) -> JStat
forall a. ToSat a => Ident -> a -> JStat
jFun (FastString -> Ident
TxtI FastString
"h$moveRegs2") 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 = (Int -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr (Int -> JExpr) -> Int -> JExpr
forall a b. (a -> b) -> a -> b
$
                      (Int
n Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`Bits.shiftL` Int
8) Int -> Int -> Int
forall a. Bits a => a -> a -> a
Bits..|. Int
m
                     , [JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat ((Int -> JStat) -> [Int] -> [JStat]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Int -> JStat
`moveRegFast` Int
m) [Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1,Int
n..Int
2])
                       JStat -> JStat -> JStat
forall a. Semigroup a => a -> a -> a
<> Maybe JsLabel -> JStat
BreakStat Maybe JsLabel
forall a. Maybe a
Nothing {-[j| break; |]-})
    moveRegFast :: Int -> Int -> JStat
moveRegFast Int
n Int
m = Int -> JExpr
jsReg (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
m) JExpr -> JExpr -> JStat
|= Int -> JExpr
jsReg Int
n
    -- 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
iJExpr -> JExpr -> JExpr
forall a. Num a => a -> a -> a
+JExpr
1JExpr -> JExpr -> JExpr
forall a. Num a => a -> a -> a
+JExpr
m, FastString -> [JExpr] -> JExpr
app FastString
"h$getReg" [JExpr
iJExpr -> JExpr -> JExpr
forall a. Num a => a -> a -> a
+JExpr
1]] JStat -> JStat -> JStat
forall a. Monoid a => a -> a -> a
`mappend` JExpr -> JStat
postDecrS JExpr
i)


-- 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 (Closure -> JExpr) -> Closure -> JExpr
forall a b. (a -> b) -> a -> b
$ Closure
      { clEntry :: JExpr
clEntry  = JExpr
entry
      , clField1 :: JExpr
clField1 = JExpr
null_
      , clField2 :: JExpr
clField2 = JExpr
null_
      , clMeta :: JExpr
clMeta   = JExpr
0
      , clCC :: Maybe JExpr
clCC     = if StgToJSConfig -> Bool
csProf StgToJSConfig
cfg then JExpr -> Maybe JExpr
forall a. a -> Maybe a
Just JExpr
ccs else Maybe JExpr
forall a. Maybe a
Nothing
      }
  , JExpr
values
  ]

-- | 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 ([JExpr] -> [TypedExpr])
-> StateT GenState IO [JExpr] -> G [TypedExpr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> StateT GenState IO [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
  JStat -> G JStat
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TypedExpr] -> [TypedExpr] -> JStat
assignCoerce1 [TypedExpr]
dst [TypedExpr]
fields)