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

-----------------------------------------------------------------------------
-- |
-- 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.JStg.Syntax
import GHC.JS.JStg.Monad
import GHC.JS.Ident
import GHC.JS.Make

import GHC.StgToJS.Arg
import GHC.StgToJS.Closure
import GHC.StgToJS.DataCon
import GHC.StgToJS.ExprCtx
import GHC.StgToJS.Heap
import GHC.StgToJS.Ids
import GHC.StgToJS.Monad
import GHC.StgToJS.Profiling
import GHC.StgToJS.Regs
import GHC.StgToJS.Rts.Types
import GHC.StgToJS.Stack
import GHC.StgToJS.Symbols
import GHC.StgToJS.Types
import GHC.StgToJS.Utils
import GHC.StgToJS.Linker.Utils (decodeModifiedUTF8)

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

import GHC.Stg.Syntax

import GHC.Builtin.Names

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

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

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

-- | Pre-generated functions for fast Apply.
-- These are bundled with the RTS.
rtsApply :: StgToJSConfig -> JSM JStgStat
rtsApply :: StgToJSConfig -> JSM JStgStat
rtsApply StgToJSConfig
cfg = [JSM JStgStat] -> JSM JStgStat
forall a. Monoid a => [JSM a] -> JSM a
jBlock
     [ [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat ([JStgStat] -> JStgStat)
-> StateT JEnv Identity [JStgStat] -> JSM JStgStat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ApplySpec -> JSM JStgStat)
-> [ApplySpec] -> StateT JEnv Identity [JStgStat]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (StgToJSConfig -> ApplySpec -> JSM JStgStat
specApply StgToJSConfig
cfg) [ApplySpec]
applySpec
     , [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat ([JStgStat] -> JStgStat)
-> StateT JEnv Identity [JStgStat] -> JSM JStgStat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> JSM JStgStat) -> [Int] -> StateT JEnv Identity [JStgStat]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (StgToJSConfig -> Int -> JSM JStgStat
pap StgToJSConfig
cfg)       [Int]
specPap
     , JSM JStgStat
mkApplyArr
     , StgToJSConfig -> JSM JStgStat
genericStackApply StgToJSConfig
cfg
     , StgToJSConfig -> JSM JStgStat
genericFastApply  StgToJSConfig
cfg
     , StgToJSConfig -> JSM JStgStat
zeroApply         StgToJSConfig
cfg
     , StgToJSConfig -> JSM JStgStat
updates           StgToJSConfig
cfg
     , StgToJSConfig -> JSM JStgStat
papGen            StgToJSConfig
cfg
     , StgToJSConfig -> JSM JStgStat
selectors         StgToJSConfig
cfg
     , JSM JStgStat
moveRegs2
     ]

-- | 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 (JStgStat, ExprResult)
genApp :: HasDebugCallStack =>
ExprCtx -> Id -> [StgArg] -> G (JStgStat, ExprResult)
genApp ExprCtx
ctx Id
i [StgArg]
args
    -- Test case moved to T24744
    -- See: https://github.com/ghcjs/ghcjs/blob/b7711fbca7c3f43a61f1dba526e6f2a2656ef44c/src/Gen2/Generator.hs#L876
    -- Comment by Luite Stegeman <luite.stegeman@iohk.io>
    -- Special cases for JSString literals.
    -- We could handle unpackNBytes# here, but that's probably not common
    -- enough to warrant a special case.
    -- See: https://gitlab.haskell.org/ghc/ghc/-/merge_requests/10588/#note_503978
    -- Comment by Jeffrey Young  <jeffrey.young@iohk.io>
    -- We detect if the Id is unsafeUnpackJSStringUtf8## applied to a string literal,
    -- if so then we convert the unsafeUnpack to a call to h$decode.
    | [StgVarArg Id
v] <- [StgArg]
args
    , Id -> Name
idName Id
i Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
unsafeUnpackJSStringUtf8ShShName
    -- See: https://gitlab.haskell.org/ghc/ghc/-/merge_requests/10588
    -- Comment by Josh Meredith  <josh.meredith@iohk.io>
    -- `typex_expr` can throw an error for certain bindings so it's important
    -- that this condition comes after matching on the function name
    , [JStgExpr
top] <- (TypedExpr -> [JStgExpr]) -> [TypedExpr] -> [JStgExpr]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TypedExpr -> [JStgExpr]
typex_expr (ExprCtx -> [TypedExpr]
ctxTarget ExprCtx
ctx)
    = (,ExprResult
ExprInline) (JStgStat -> (JStgStat, ExprResult))
-> ([JStgExpr] -> JStgStat) -> [JStgExpr] -> (JStgStat, ExprResult)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JStgExpr -> JStgExpr -> JStgStat
(|=) JStgExpr
top (JStgExpr -> JStgStat)
-> ([JStgExpr] -> JStgExpr) -> [JStgExpr] -> JStgStat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FastString -> [JStgExpr] -> JStgExpr
app FastString
hdDecodeUtf8Z ([JStgExpr] -> (JStgStat, ExprResult))
-> StateT GenState IO [JStgExpr] -> G (JStgStat, ExprResult)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> StateT GenState IO [JStgExpr]
varsForId Id
v

    -- Test case T23479
    | [StgLitArg (LitString ByteString
bs)] <- [StgArg]
args
    , Just FastString
d <- ByteString -> Maybe FastString
decodeModifiedUTF8 ByteString
bs
    , Id -> Name
idName Id
i Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
unsafeUnpackJSStringUtf8ShShName
    , [JStgExpr
top] <- (TypedExpr -> [JStgExpr]) -> [TypedExpr] -> [JStgExpr]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TypedExpr -> [JStgExpr]
typex_expr (ExprCtx -> [TypedExpr]
ctxTarget ExprCtx
ctx)
    = (JStgStat, ExprResult) -> G (JStgStat, ExprResult)
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((JStgStat, ExprResult) -> G (JStgStat, ExprResult))
-> (JStgStat -> (JStgStat, ExprResult))
-> JStgStat
-> G (JStgStat, ExprResult)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,ExprResult
ExprInline) (JStgStat -> G (JStgStat, ExprResult))
-> JStgStat -> G (JStgStat, ExprResult)
forall a b. (a -> b) -> a -> b
$ JStgExpr
top JStgExpr -> JStgExpr -> JStgStat
|= FastString -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr FastString
d

    -- Test case T24495 with single occurrence at -02 and third occurrence at -01
    -- Moved back from removal at https://gitlab.haskell.org/ghc/ghc/-/merge_requests/12308
    -- See commit hash b36ee57bfbecc628b7f0919e1e59b7066495034f
    --
    -- Case: unpackCStringAppend# "some string"# str
    --
    -- Generates h$appendToHsStringA(str, "some string"), which has a faster
    -- decoding loop.
    | [StgLitArg (LitString ByteString
bs), StgArg
x] <- [StgArg]
args
    , Just FastString
d <- ByteString -> Maybe FastString
decodeModifiedUTF8 ByteString
bs
    , Id -> Unique
forall a. Uniquable a => a -> Unique
getUnique Id
i Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
unpackCStringAppendIdKey
    , [JStgExpr
top] <- (TypedExpr -> [JStgExpr]) -> [TypedExpr] -> [JStgExpr]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TypedExpr -> [JStgExpr]
typex_expr (ExprCtx -> [TypedExpr]
ctxTarget ExprCtx
ctx)
    = do
        prof <- StgToJSConfig -> Bool
csProf (StgToJSConfig -> Bool)
-> StateT GenState IO StgToJSConfig -> StateT GenState IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT GenState IO StgToJSConfig
getSettings
        let profArg = if Bool
prof then [JStgExpr
jCafCCS] else []
        a <- genArg x
        return ( top |= app "h$appendToHsStringA" (toJExpr d : a ++ profArg)
               , ExprInline
               )
    | [StgLitArg (LitString ByteString
bs), StgArg
x] <- [StgArg]
args
    , Just FastString
d <- ByteString -> Maybe FastString
decodeModifiedUTF8 ByteString
bs
    , Id -> Unique
forall a. Uniquable a => a -> Unique
getUnique Id
i Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
unpackCStringAppendUtf8IdKey
    , [JStgExpr
top] <- (TypedExpr -> [JStgExpr]) -> [TypedExpr] -> [JStgExpr]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TypedExpr -> [JStgExpr]
typex_expr (ExprCtx -> [TypedExpr]
ctxTarget ExprCtx
ctx)
    = do
        prof <- StgToJSConfig -> Bool
csProf (StgToJSConfig -> Bool)
-> StateT GenState IO StgToJSConfig -> StateT GenState IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT GenState IO StgToJSConfig
getSettings
        let profArg = if Bool
prof then [JStgExpr
jCafCCS] else []
        a <- genArg x
        return ( top |= app "h$appendToHsString" (toJExpr d : a ++ profArg)
               , ExprInline
               )

    -- Case: unpackCString# "some string"#
    --
    -- Generates h$toHsString("some string"), which has a faster
    -- decoding loop.
    -- + Utf8 version below
    | [StgLitArg (LitString ByteString
bs)] <- [StgArg]
args
    , Just FastString
d <- ByteString -> Maybe FastString
decodeModifiedUTF8 ByteString
bs
    , Id -> Name
idName Id
i Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
unpackCStringName
    , [JStgExpr
top] <- (TypedExpr -> [JStgExpr]) -> [TypedExpr] -> [JStgExpr]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TypedExpr -> [JStgExpr]
typex_expr (ExprCtx -> [TypedExpr]
ctxTarget ExprCtx
ctx)
    = (JStgStat, ExprResult) -> G (JStgStat, ExprResult)
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
        ( JStgExpr
top JStgExpr -> JStgExpr -> JStgStat
|= FastString -> [JStgExpr] -> JStgExpr
app FastString
"h$toHsStringA" [FastString -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr FastString
d]
        , ExprResult
ExprInline
        )
    | [StgLitArg (LitString ByteString
bs)] <- [StgArg]
args
    , Just FastString
d <- ByteString -> Maybe FastString
decodeModifiedUTF8 ByteString
bs
    , Id -> Name
idName Id
i Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
unpackCStringUtf8Name
    , [JStgExpr
top] <- (TypedExpr -> [JStgExpr]) -> [TypedExpr] -> [JStgExpr]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TypedExpr -> [JStgExpr]
typex_expr (ExprCtx -> [TypedExpr]
ctxTarget ExprCtx
ctx)
    = (JStgStat, ExprResult) -> G (JStgStat, ExprResult)
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
        ( JStgExpr
top JStgExpr -> JStgExpr -> JStgStat
|= FastString -> [JStgExpr] -> JStgExpr
app FastString
"h$toHsString" [FastString -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr FastString
d]
        , ExprResult
ExprInline
        )

    -- let-no-escape
    | Just Int
n <- ExprCtx -> Id -> Maybe Int
ctxLneBindingStackSize ExprCtx
ctx Id
i
    = do
      as'      <- (StgArg -> StateT GenState IO [JStgExpr])
-> [StgArg] -> StateT GenState IO [JStgExpr]
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Traversable f) =>
(a -> m [b]) -> f a -> m [b]
concatMapM HasDebugCallStack => StgArg -> StateT GenState IO [JStgExpr]
StgArg -> StateT GenState IO [JStgExpr]
genArg [StgArg]
args
      ei       <- varForEntryId i
      let ra = [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat ([JStgStat] -> JStgStat)
-> ([JStgStat] -> [JStgStat]) -> [JStgStat] -> JStgStat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [JStgStat] -> [JStgStat]
forall a. [a] -> [a]
reverse ([JStgStat] -> JStgStat) -> [JStgStat] -> JStgStat
forall a b. (a -> b) -> a -> b
$
                 (StgReg -> JStgExpr -> JStgStat)
-> [StgReg] -> [JStgExpr] -> [JStgStat]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\StgReg
r JStgExpr
a -> StgReg -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr StgReg
r JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
a) [StgReg
R1 ..] [JStgExpr]
as'
      p <- pushLneFrame n ctx
      a <- adjSp 1 -- for the header (which will only be written when the thread is suspended)
      return (ra <> p <> a <> returnS ei, 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
    , [JStgExpr
top] <- (TypedExpr -> [JStgExpr]) -> [TypedExpr] -> [JStgExpr]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TypedExpr -> [JStgExpr]
typex_expr (ExprCtx -> [TypedExpr]
ctxTarget ExprCtx
ctx)
    = (JStgStat, ExprResult) -> G (JStgStat, ExprResult)
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStgExpr
top JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
null_, ExprResult
ExprInline)

    -- 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
      a <- Id -> [TypedExpr] -> G JStgStat
storeIdFields Id
i (ExprCtx -> [TypedExpr]
ctxTarget ExprCtx
ctx)
      return (a, ExprInline)

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

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


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

    -- 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
      enter_id <- HasDebugCallStack => Id -> StateT GenState IO [JStgExpr]
Id -> StateT GenState IO [JStgExpr]
genIdArg Id
i StateT GenState IO [JStgExpr]
-> ([JStgExpr] -> G JStgExpr) -> G JStgExpr
forall a b.
StateT GenState IO a
-> (a -> StateT GenState IO b) -> StateT GenState IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                    \case
                       [JStgExpr
x] -> JStgExpr -> G JStgExpr
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return JStgExpr
x
                       [JStgExpr]
xs  -> [Char] -> SDoc -> G JStgExpr
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"genApp: unexpected multi-var argument"
                                ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr ([JStgExpr] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [JStgExpr]
xs), Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
i])
      return (returnS (app (identFS hdEntry) [enter_id]), ExprCont)

    -- 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
      as' <- (StgArg -> StateT GenState IO [JStgExpr])
-> [StgArg] -> StateT GenState IO [JStgExpr]
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Traversable f) =>
(a -> m [b]) -> f a -> m [b]
concatMapM HasDebugCallStack => StgArg -> StateT GenState IO [JStgExpr]
StgArg -> StateT GenState IO [JStgExpr]
genArg [StgArg]
args
      is  <- assignAll jsRegsFromR1 <$> varsForId i
      jmp <- jumpToII i as' is
      return (jmp, ExprCont)

    -- 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
      reg' <- (StgArg -> StateT GenState IO [JStgExpr])
-> [StgArg] -> StateT GenState IO [JStgExpr]
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Traversable f) =>
(a -> m [b]) -> f a -> m [b]
concatMapM HasDebugCallStack => StgArg -> StateT GenState IO [JStgExpr]
StgArg -> StateT GenState IO [JStgExpr]
genArg [StgArg]
reg
      pc   <- pushCont over
      is   <- assignAll jsRegsFromR1 <$> varsForId i
      jmp  <- jumpToII i reg' is
      return (pc <> jmp, ExprCont)

    -- 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
      is  <- [JStgExpr] -> [JStgExpr] -> JStgStat
assignAll [JStgExpr]
jsRegsFromR1 ([JStgExpr] -> JStgStat)
-> StateT GenState IO [JStgExpr] -> G JStgStat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> StateT GenState IO [JStgExpr]
varsForId Id
i
      jmp <- jumpToFast args is
      return (jmp, ExprCont)

-- avoid one indirection for global ids
-- fixme in many cases we can also jump directly to the entry for local?
jumpToII :: Id -> [JStgExpr] -> JStgStat -> G JStgStat
jumpToII :: Id -> [JStgExpr] -> JStgStat -> G JStgStat
jumpToII Id
i [JStgExpr]
vars JStgStat
load_app_in_r1
  | Id -> Bool
isLocalId Id
i = do
     ii <- Id -> G JStgExpr
varForId Id
i
     return $ mconcat
      [ assignAllReverseOrder jsRegsFromR2 vars
      , load_app_in_r1
      , returnS (closureInfo ii)
      ]
  | Bool
otherwise   = do
     ei <- Id -> G JStgExpr
varForEntryId Id
i
     return $ mconcat
      [ assignAllReverseOrder jsRegsFromR2 vars
      , load_app_in_r1
      , returnS ei
      ]

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

-- | Expr of the generic apply function
genericApplyExpr :: ApplyConv -> JStgExpr
genericApplyExpr :: ApplyConv -> JStgExpr
genericApplyExpr ApplyConv
conv = FastString -> JStgExpr
global (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 -> JStgExpr
specApplyExpr :: ApplySpec -> JStgExpr
specApplyExpr ApplySpec
spec = FastString -> JStgExpr
global (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 JStgExpr
specApplyExprMaybe :: ApplySpec -> Maybe JStgExpr
specApplyExprMaybe ApplySpec
spec =
  if ApplySpec
spec ApplySpec -> [ApplySpec] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ApplySpec]
applySpec
    then JStgExpr -> Maybe JStgExpr
forall a. a -> Maybe a
Just (ApplySpec -> JStgExpr
specApplyExpr ApplySpec
spec)
    else Maybe JStgExpr
forall a. Maybe a
Nothing

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

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


-- | 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 -> JStgExpr
specTagExpr :: ApplySpec -> JStgExpr
specTagExpr = Int -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr (Int -> JStgExpr) -> (ApplySpec -> Int) -> ApplySpec -> JStgExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ApplySpec -> Int
specTag

-- | 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 :: JSM JStgStat
mkApplyArr :: JSM JStgStat
mkApplyArr =
  do mk_ap_gens  <- (JStgExpr -> JStgStat)
-> (JStgExpr -> JStgExpr)
-> (JStgExpr -> JStgStat)
-> (JStgExpr -> JStgStat)
-> JSM JStgStat
jFor (JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
zero_) (JStgExpr -> JStgExpr -> JStgExpr
.<. Integer -> JStgExpr
Int Integer
65536) JStgExpr -> JStgStat
preIncrS
                    \JStgExpr
j -> JStgExpr
hdApply JStgExpr -> JStgExpr -> JStgExpr
.! JStgExpr
j JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
hdApGen
     mk_pap_gens <- jFor (|= zero_) (.<. Int 128) preIncrS
                    \JStgExpr
j -> JStgExpr
hdPaps JStgExpr -> JStgExpr -> JStgExpr
.! JStgExpr
j JStgExpr -> JStgExpr -> JStgStat
|=  JStgExpr
hdPapGen
     return $ mconcat
       [ name hdApplyStr ||= toJExpr (JList [])
       , name hdPapsStr  ||= toJExpr (JList [])
       , ApplStat (hdInitStatic .^ "push")
         [ jLam' $
           mconcat
           [ mk_ap_gens
           , mk_pap_gens
           , mconcat (map assignSpec applySpec)
           , mconcat (map assignPap specPap)
           ]
         ]
       ]
  where
    assignSpec :: ApplySpec -> JStgStat
    assignSpec :: ApplySpec -> JStgStat
assignSpec ApplySpec
spec = case ApplySpec -> ApplyConv
specConv ApplySpec
spec of
      -- 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 -> JStgExpr
hdApply JStgExpr -> JStgExpr -> JStgExpr
.! ApplySpec -> JStgExpr
specTagExpr ApplySpec
spec JStgExpr -> JStgExpr -> JStgStat
|= ApplySpec -> JStgExpr
specApplyExpr ApplySpec
spec
      ApplyConv
RegsConv  -> JStgStat
forall a. Monoid a => a
mempty

    hdPap_ :: [Char]
hdPap_ = FastString -> [Char]
unpackFS FastString
hdPapStr_

    assignPap :: Int -> JStgStat
    assignPap :: Int -> JStgStat
assignPap Int
p = JStgExpr
hdPaps JStgExpr -> JStgExpr -> JStgExpr
.! Int -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr Int
p JStgExpr -> JStgExpr -> JStgStat
|= FastString -> JStgExpr
global ([Char] -> FastString
mkFastString ([Char]
hdPap_ [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
p))

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

-- | 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 -> JSM JStgStat
genericStackApply :: StgToJSConfig -> JSM JStgStat
genericStackApply StgToJSConfig
cfg = ClosureInfo -> JSM JStgStat -> JSM JStgStat
closure ClosureInfo
info JSM JStgStat
body
  where
    -- h$ap_gen body
    body :: JSM JStgStat
body = (JStgExpr -> JSM JStgStat) -> JSM JStgStat
forall t.
(JVarMagic t, ToJExpr t) =>
(t -> JSM JStgStat) -> JSM JStgStat
jVar ((JStgExpr -> JSM JStgStat) -> JSM JStgStat)
-> (JStgExpr -> JSM JStgStat) -> JSM JStgStat
forall a b. (a -> b) -> a -> b
$ \JStgExpr
cf ->
      do fun <- JStgExpr -> JStgExpr -> JSM JStgStat
fun_case JStgExpr
cf (JStgExpr -> JStgExpr
infoFunArity JStgExpr
cf)
         pap <- fun_case cf (papArity r1)
         return $
           mconcat $
           [ traceRts cfg (jString $ identFS hdApGenStr)
           , cf |= closureInfo r1
           -- switch on closure type
           , SwitchStat (infoClosureType cf)
             [ (toJExpr Thunk    , thunk_case cfg cf)
             , (toJExpr Fun      , fun)
             , (toJExpr Pap      , pap)
             , (toJExpr Blackhole, blackhole_case cfg)
             ]
             (default_case cf)
           ]

    -- info table for h$ap_gen
    info :: ClosureInfo
info = ClosureInfo
      { ciVar :: Ident
ciVar     = Ident
hdApGenStr
      , ciRegs :: CIRegs
ciRegs    = Int -> [JSRep] -> CIRegs
CIRegs Int
0 [JSRep
PtrV] -- closure to apply to
      , ciName :: FastString
ciName    = Ident -> FastString
identFS Ident
hdApGenStr
      , ciLayout :: CILayout
ciLayout  = CILayout
CILayoutVariable
      , ciType :: CIType
ciType    = CIType
CIStackFrame
      , ciStatic :: CIStatic
ciStatic  = CIStatic
forall a. Monoid a => a
mempty
      }

    default_case :: JStgExpr -> JStgStat
default_case JStgExpr
cf = FastString -> [JStgExpr] -> JStgStat
appS FastString
throwStr [FastString -> JStgExpr
jString FastString
"h$ap_gen: unexpected closure type "
                                     JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
+ (JStgExpr -> JStgExpr
infoClosureType JStgExpr
cf)]

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

    blackhole_case :: StgToJSConfig -> JStgStat
blackhole_case StgToJSConfig
cfg = [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat
      [ StgToJSConfig -> [JStgExpr] -> JStgStat
push' StgToJSConfig
cfg [JStgExpr
r1, JStgExpr
hdReturn]
      , JStgExpr -> JStgStat
returnS (FastString -> [JStgExpr] -> JStgExpr
app FastString
hdBlockOnBlackHoleStr [JStgExpr
r1])
      ]

    fun_case :: JStgExpr -> JStgExpr -> JSM JStgStat
fun_case JStgExpr
c JStgExpr
arity = ((JStgExpr, JStgExpr, JStgExpr, JStgExpr, JStgExpr, JStgExpr,
  JStgExpr, JStgExpr, JStgExpr)
 -> JSM JStgStat)
-> JSM JStgStat
forall args.
JSArgument args =>
(args -> JSM JStgStat) -> JSM JStgStat
jVars \(JStgExpr
tag, JStgExpr
needed_args, JStgExpr
needed_regs, JStgExpr
given_args, JStgExpr
given_regs, JStgExpr
newTag, JStgExpr
newAp, JStgExpr
p, JStgExpr
dat) ->
      do build_pap_payload <- JStgExpr
-> (JStgExpr -> JStgExpr)
-> (JStgExpr -> JSM JStgStat)
-> JSM JStgStat
loop JStgExpr
0 (JStgExpr -> JStgExpr -> JStgExpr
.<. JStgExpr
given_regs)
                              \JStgExpr
i -> JStgStat -> JSM JStgStat
forall a. a -> StateT JEnv Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStgStat -> JSM JStgStat) -> JStgStat -> JSM JStgStat
forall a b. (a -> b) -> a -> b
$ [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat [ (JStgExpr
dat JStgExpr -> FastString -> JStgExpr
.^ FastString
"push") JStgExpr -> [JStgExpr] -> JStgStat
`ApplStat` [JStgExpr
stack JStgExpr -> JStgExpr -> JStgExpr
.! (JStgExpr
sp JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
- JStgExpr
i JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
- JStgExpr
2)]
                                                     , JStgExpr -> JStgStat
postIncrS JStgExpr
i
                                                     ]
         load_reg_values <- loop 0 (.<. needed_regs)
                            \JStgExpr
i -> JStgStat -> JSM JStgStat
forall a. a -> StateT JEnv Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStgStat -> JSM JStgStat) -> JStgStat -> JSM JStgStat
forall a b. (a -> b) -> a -> b
$
                                  [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat [ StgToJSConfig -> JStgExpr -> JStgStat
traceRts StgToJSConfig
cfg (FastString -> JStgExpr
jString FastString
"h$ap_gen: loading register: " JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
+ JStgExpr
i)
                                          , FastString -> [JStgExpr] -> JStgStat
appS FastString
hdSetRegStr [ JStgExpr
iJStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
+JStgExpr
2 , JStgExpr
stack JStgExpr -> JStgExpr -> JStgExpr
.! (JStgExpr
spJStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
-JStgExpr
2JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
-JStgExpr
i)]
                                          , JStgExpr -> JStgStat
postIncrS JStgExpr
i
                                          ]
         set_reg_values <- loop 0 (.<. given_regs)
           \JStgExpr
i -> JStgStat -> JSM JStgStat
forall a. a -> StateT JEnv Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStgStat -> JSM JStgStat) -> JStgStat -> JSM JStgStat
forall a b. (a -> b) -> a -> b
$
                 [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat [ FastString -> [JStgExpr] -> JStgStat
appS FastString
hdSetRegStr [ JStgExpr
iJStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
+JStgExpr
2, JStgExpr
stack JStgExpr -> JStgExpr -> JStgExpr
.! (JStgExpr
spJStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
-JStgExpr
2JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
-JStgExpr
i)]
                         , JStgExpr -> JStgStat
postIncrS JStgExpr
i
                         ]
         return $
           mconcat $ [ tag         |= stack .! (sp - 1) -- tag on the stack
                     , given_args  |= mask8 tag         -- indicates the number of passed args
                     , given_regs  |= tag .>>. 8        -- and the number of passed values for registers
                     , needed_args |= mask8 arity
                     , needed_regs |= arity .>>. 8
                     , traceRts cfg (jString "h$ap_gen: args: " + given_args
                                     + jString " regs: " + given_regs)
                     , ifBlockS (given_args .===. needed_args)
                       --------------------------------
                       -- exactly saturated application
                       --------------------------------
                       [ traceRts cfg (jString "h$ap_gen: exact")
                       -- Set registers to register values on the stack
                       , set_reg_values
                       -- drop register values from the stack
                       , sp |= sp - given_regs - 2
                       -- enter closure in R1
                       , returnS c
                       ]
                       [ ifBlockS (given_args .>. needed_args)
                         ----------------------------
                         -- oversaturated application
                         ----------------------------
                         [ traceRts cfg (jString "h$ap_gen: oversat: arity: " + needed_args
                                         + jString " regs: " + needed_regs)

                         -- load needed register values
                         , load_reg_values

                         -- compute new tag with consumed register values and args removed
                         , newTag |= ((given_regs-needed_regs).<<.8) .|. (given_args - needed_args)
                         -- find application function for the remaining regs/args
                         , newAp |= hdApply .! newTag
                         , traceRts cfg (jString "h$ap_gen: next: " + (newAp .^ "n"))

                         -- Drop used registers from the stack.
                         -- Test if the application function needs a tag and push it.
                         , ifS (newAp .===. hdApGen )
                           ((sp |= sp - needed_regs) <> (stack .! (sp - 1) |= newTag))
                           (sp |= sp - needed_regs - 1)

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

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

                         -- enter closure in R1
                         , returnS c
                         ]

                         -----------------------------
                         -- undersaturated application
                         -----------------------------
                         [ traceRts cfg (jString "h$ap_gen: undersat")
                         -- find PAP entry function corresponding to given_regs count
                         , p      |= hdPaps .! given_regs

                         -- build PAP payload: R1 + tag + given register values
                         , newTag |= ((needed_regs-given_regs) .<<. 8) .|. (needed_args-given_args)
                         , dat    |= toJExpr [r1, newTag]
                         , build_pap_payload

                         -- remove register values from the stack.
                         , sp  |= sp - given_regs - 2

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

                         -- return to the continuation on the stack
                         , 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 -> JSM JStgStat
genericFastApply :: StgToJSConfig -> JSM JStgStat
genericFastApply StgToJSConfig
s =
   Ident -> (Solo JStgExpr -> JSM JStgStat) -> JSM JStgStat
forall args.
JSArgument args =>
Ident -> (args -> JSM JStgStat) -> JSM JStgStat
jFunction (FastString -> Ident
name FastString
"h$ap_gen_fast")
   \(MkSolo JStgExpr
tag) -> (JStgExpr -> JSM JStgStat) -> JSM JStgStat
forall t.
(JVarMagic t, ToJExpr t) =>
(t -> JSM JStgStat) -> JSM JStgStat
jVar ((JStgExpr -> JSM JStgStat) -> JSM JStgStat)
-> (JStgExpr -> JSM JStgStat) -> JSM JStgStat
forall a b. (a -> b) -> a -> b
$ \JStgExpr
c ->
     do push_stk_app <- JStgExpr -> JStgExpr -> JSM JStgStat
pushStackApply JStgExpr
c JStgExpr
tag
        fast_fun     <- jVar \JStgExpr
farity ->
                               do fast_fun <- JStgExpr -> JStgExpr -> JStgExpr -> JSM JStgStat
funCase JStgExpr
c JStgExpr
tag JStgExpr
farity
                                  return $ mconcat $
                                    [ farity |= infoFunArity c
                                    , traceRts s (jString "h$ap_gen_fast: fun " + farity)
                                    , fast_fun]
        fast_pap     <- jVar \JStgExpr
parity ->
                               do fast_pap <- JStgExpr -> JStgExpr -> JStgExpr -> JSM JStgStat
funCase JStgExpr
c JStgExpr
tag JStgExpr
parity
                                  return $ mconcat $
                                    [ parity |= papArity r1
                                    , traceRts s (jString "h$ap_gen_fast: pap " + parity)
                                    , fast_pap
                                    ]
        return $ mconcat $
          [traceRts s (jString "h$ap_gen_fast: " + tag)
          , c |= closureInfo r1
          , SwitchStat (infoClosureType c)
            [ (toJExpr Thunk, traceRts s (jString "h$ap_gen_fast: thunk")
                <> push_stk_app
                <> returnS c)
            , (toJExpr Fun, fast_fun)
            , (toJExpr Pap, fast_pap)
            , (toJExpr Con, traceRts s (jString "h$ap_gen_fast: con")
                <> jwhenS (tag .!=. 0)
                            (appS throwStr [jString "h$ap_gen_fast: invalid apply"])
                            <> returnS c)
            , (toJExpr Blackhole, traceRts s (jString "h$ap_gen_fast: blackhole")
                <> push_stk_app
                <> push' s [r1, hdReturn]
                <> returnS (app hdBlockOnBlackHoleStr [r1]))
            ] $ appS throwStr [jString "h$ap_gen_fast: unexpected closure type: " + infoClosureType c]
          ]

  where
     -- thunk: push everything to stack frame, enter thunk first
    pushStackApply :: JStgExpr -> JStgExpr -> JSM JStgStat
    pushStackApply :: JStgExpr -> JStgExpr -> JSM JStgStat
pushStackApply JStgExpr
_c JStgExpr
tag =
      (JStgExpr -> JSM JStgStat) -> JSM JStgStat
forall t.
(JVarMagic t, ToJExpr t) =>
(t -> JSM JStgStat) -> JSM JStgStat
jVar \JStgExpr
ap ->
             do push_all_regs <- JStgExpr -> JSM JStgStat
pushAllRegs JStgExpr
tag
                return $ mconcat $
                  [ push_all_regs
                  , ap |= hdApply .! tag
                  , ifS (ap .===. hdApGen)
                    ((sp |= sp + 2) <> (stack .! (sp-1) |= tag))
                    (sp |= sp + 1)
                  , stack .! sp |= ap
                  , profStat s pushRestoreCCS
                  ]

    funCase :: JStgExpr -> JStgExpr -> JStgExpr -> JSM JStgStat
    funCase :: JStgExpr -> JStgExpr -> JStgExpr -> JSM JStgStat
funCase JStgExpr
c JStgExpr
tag JStgExpr
arity = ((JStgExpr, JStgExpr, JStgExpr, JStgExpr, JStgExpr, JStgExpr,
  JStgExpr, JStgExpr)
 -> JSM JStgStat)
-> JSM JStgStat
forall args.
JSArgument args =>
(args -> JSM JStgStat) -> JSM JStgStat
jVars (((JStgExpr, JStgExpr, JStgExpr, JStgExpr, JStgExpr, JStgExpr,
   JStgExpr, JStgExpr)
  -> JSM JStgStat)
 -> JSM JStgStat)
-> ((JStgExpr, JStgExpr, JStgExpr, JStgExpr, JStgExpr, JStgExpr,
     JStgExpr, JStgExpr)
    -> JSM JStgStat)
-> JSM JStgStat
forall a b. (a -> b) -> a -> b
$
      \(JStgExpr
ar, JStgExpr
myAr, JStgExpr
myRegs, JStgExpr
regsStart, JStgExpr
newTag, JStgExpr
newAp, JStgExpr
dat, JStgExpr
p) ->

        do get_regs <- JStgExpr
-> (JStgExpr -> JStgExpr)
-> (JStgExpr -> JSM JStgStat)
-> JSM JStgStat
loop JStgExpr
0 (JStgExpr -> JStgExpr -> JStgExpr
.<. JStgExpr
myRegs) ((JStgExpr -> JSM JStgStat) -> JSM JStgStat)
-> (JStgExpr -> JSM JStgStat) -> JSM JStgStat
forall a b. (a -> b) -> a -> b
$
             \JStgExpr
i -> JStgStat -> JSM JStgStat
forall a. a -> StateT JEnv Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStgStat -> JSM JStgStat) -> JStgStat -> JSM JStgStat
forall a b. (a -> b) -> a -> b
$
                   (JStgExpr
dat JStgExpr -> FastString -> JStgExpr
.^ FastString
"push") JStgExpr -> [JStgExpr] -> JStgStat
`ApplStat` [FastString -> [JStgExpr] -> JStgExpr
app FastString
hdGetRegStr [JStgExpr
iJStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
+JStgExpr
2]] JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> JStgExpr -> JStgStat
postIncrS JStgExpr
i
           push_args <- pushArgs regsStart myRegs

           return $ mconcat $
             [ ar     |= mask8 arity
             , myAr   |= mask8 tag
             , myRegs |= tag .>>. 8
             , traceRts s (jString "h$ap_gen_fast: args: " + myAr
                           + jString " regs: "             + myRegs)
             , ifS (myAr .===. ar)
             -- call the function directly
               (traceRts s (jString "h$ap_gen_fast: exact") <> returnS c)
               (ifBlockS (myAr .>. ar)
               -- push stack frame with remaining args, then call fun
                [ traceRts s (jString "h$ap_gen_fast: oversat " + sp)
                , regsStart |= (arity .>>. 8) + 1
                , sp |= sp + myRegs - regsStart + 1
                , traceRts s (jString "h$ap_gen_fast: oversat " + sp)
                , push_args
                , newTag |= ((myRegs-( arity.>>.8)).<<.8).|.myAr-ar
                , newAp |= hdApply .! newTag
                , ifS (newAp .===. hdApGen)
                  ((sp |= sp + 2) <> (stack .! (sp - 1) |= newTag))
                  (sp |= sp + 1)
                , stack .! sp |= newAp
                , profStat s pushRestoreCCS
                , returnS c
                ]
               -- else
                [traceRts s (jString "h$ap_gen_fast: undersat: " + myRegs + jString " " + tag)
                , jwhenS (tag .!=. 0) $ mconcat
                  [ p |= hdPaps .! myRegs
                  , dat |= toJExpr [r1, ((arity .>>. 8)-myRegs)*256+ar-myAr]
                  , get_regs
                  , r1 |= initClosure s p dat jCurrentCCS
                  ]
                , returnStack
                ])
             ]

    pushAllRegs :: JStgExpr -> JSM JStgStat
    pushAllRegs :: JStgExpr -> JSM JStgStat
pushAllRegs JStgExpr
tag =
      (JStgExpr -> JSM JStgStat) -> JSM JStgStat
forall t.
(JVarMagic t, ToJExpr t) =>
(t -> JSM JStgStat) -> JSM JStgStat
jVar \JStgExpr
regs ->
             JStgStat -> JSM JStgStat
forall a. a -> StateT JEnv Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStgStat -> JSM JStgStat) -> JStgStat -> JSM JStgStat
forall a b. (a -> b) -> a -> b
$ [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat ([JStgStat] -> JStgStat) -> [JStgStat] -> JStgStat
forall a b. (a -> b) -> a -> b
$
             [ JStgExpr
regs JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
tag JStgExpr -> JStgExpr -> JStgExpr
.>>. JStgExpr
8
             , JStgExpr
sp JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
sp JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
+ JStgExpr
regs
             , JStgExpr -> [(JStgExpr, JStgStat)] -> JStgStat -> JStgStat
SwitchStat JStgExpr
regs ((Int -> (JStgExpr, JStgStat)) -> [Int] -> [(JStgExpr, JStgStat)]
forall a b. (a -> b) -> [a] -> [b]
map Int -> (JStgExpr, JStgStat)
pushReg [Int
65,Int
64..Int
2]) JStgStat
forall a. Monoid a => a
mempty
             ]
      where
        pushReg :: Int -> (JStgExpr, JStgStat)
        pushReg :: Int -> (JStgExpr, JStgStat)
pushReg Int
r = (Int -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr (Int
rInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1),  JStgExpr
stack JStgExpr -> JStgExpr -> JStgExpr
.! (JStgExpr
sp JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
- Int -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr (Int
r Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2)) JStgExpr -> JStgExpr -> JStgStat
|= Int -> JStgExpr
jsReg Int
r)

    pushArgs :: JStgExpr -> JStgExpr -> JSM JStgStat
    pushArgs :: JStgExpr -> JStgExpr -> JSM JStgStat
pushArgs JStgExpr
start JStgExpr
end =
      JStgExpr
-> (JStgExpr -> JStgExpr)
-> (JStgExpr -> JSM JStgStat)
-> JSM JStgStat
loop JStgExpr
end (JStgExpr -> JStgExpr -> JStgExpr
.>=.JStgExpr
start)
      \JStgExpr
i -> JStgStat -> JSM JStgStat
forall a. a -> StateT JEnv Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStgStat -> JSM JStgStat) -> JStgStat -> JSM JStgStat
forall a b. (a -> b) -> a -> b
$
            StgToJSConfig -> JStgExpr -> JStgStat
traceRts StgToJSConfig
s (FastString -> JStgExpr
jString FastString
"pushing register: " JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
+ JStgExpr
i)
            JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> (JStgExpr
stack JStgExpr -> JStgExpr -> JStgExpr
.! (JStgExpr
sp JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
+ JStgExpr
start JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
- JStgExpr
i) JStgExpr -> JStgExpr -> JStgStat
|= FastString -> [JStgExpr] -> JStgExpr
app FastString
hdGetRegStr [JStgExpr
iJStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
+JStgExpr
1])
            JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> JStgExpr -> JStgStat
postDecrS JStgExpr
i

-- | Make specialized apply function for the given ApplySpec
specApply :: StgToJSConfig -> ApplySpec -> JSM JStgStat
specApply :: StgToJSConfig -> ApplySpec -> JSM JStgStat
specApply StgToJSConfig
cfg spec :: ApplySpec
spec@(ApplySpec ApplyConv
conv Int
nargs Int
nvars) =
  let fun_name :: FastString
fun_name = ApplySpec -> FastString
specApplyName ApplySpec
spec
  in case ApplyConv
conv of
    ApplyConv
RegsConv  -> StgToJSConfig -> FastString -> Int -> Int -> JSM JStgStat
fastApply  StgToJSConfig
cfg FastString
fun_name Int
nargs Int
nvars
    ApplyConv
StackConv -> StgToJSConfig -> FastString -> Int -> Int -> JSM JStgStat
stackApply StgToJSConfig
cfg FastString
fun_name Int
nargs Int
nvars

-- | Make specialized apply function with Stack calling convention
stackApply
  :: StgToJSConfig
  -> FastString
  -> Int
  -> Int
  -> JSM JStgStat
stackApply :: StgToJSConfig -> FastString -> Int -> Int -> JSM JStgStat
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 -> JSM JStgStat -> JSM JStgStat
closure ClosureInfo
info0 JSM JStgStat
body0
    else ClosureInfo -> JSM JStgStat -> JSM JStgStat
closure ClosureInfo
info JSM JStgStat
body
  where
    info :: ClosureInfo
info  = ClosureInfo
              { ciVar :: Ident
ciVar = FastString -> Ident
name FastString
fun_name
              , ciRegs :: CIRegs
ciRegs = Int -> [JSRep] -> CIRegs
CIRegs Int
0 [JSRep
PtrV]
              , ciName :: FastString
ciName = FastString
fun_name
              , ciLayout :: CILayout
ciLayout = Int -> CILayout
CILayoutUnknown Int
nvars
              , ciType :: CIType
ciType = CIType
CIStackFrame
              , ciStatic :: CIStatic
ciStatic = CIStatic
forall a. Monoid a => a
mempty
              }
    info0 :: ClosureInfo
info0 = ClosureInfo
              { ciVar :: Ident
ciVar = FastString -> Ident
name FastString
fun_name
              , ciRegs :: CIRegs
ciRegs = Int -> [JSRep] -> CIRegs
CIRegs Int
0 [JSRep
PtrV]
              , ciName :: FastString
ciName = FastString
fun_name
              , ciLayout :: CILayout
ciLayout = Int -> [JSRep] -> CILayout
CILayoutFixed Int
0 []
              , ciType :: CIType
ciType = CIType
CIStackFrame
              , ciStatic :: CIStatic
ciStatic = CIStatic
forall a. Monoid a => a
mempty
              }

    body0 :: JSM JStgStat
body0 = (Int -> JStgStat
adjSpN' Int
1 JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<>) (JStgStat -> JStgStat) -> JSM JStgStat -> JSM JStgStat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StgToJSConfig -> JStgExpr -> JSM JStgStat
enter StgToJSConfig
s JStgExpr
r1

    body :: JSM JStgStat
body = (JStgExpr -> JSM JStgStat) -> JSM JStgStat
forall t.
(JVarMagic t, ToJExpr t) =>
(t -> JSM JStgStat) -> JSM JStgStat
jVar ((JStgExpr -> JSM JStgStat) -> JSM JStgStat)
-> (JStgExpr -> JSM JStgStat) -> JSM JStgStat
forall a b. (a -> b) -> a -> b
$ \JStgExpr
c ->
      do fun_case <- JStgExpr -> JSM JStgStat
funCase JStgExpr
c
         pap_case <- papCase c
         return $ mconcat
           [ c |= closureInfo r1
           , traceRts s (toJExpr fun_name
                          + jString " "
                          + (c .^ "n")
                          + jString " sp: " + sp
                          + jString " a: "  + (c .^ "a"))
           , SwitchStat (infoClosureType c)
             [ (toJExpr Thunk, traceRts s (toJExpr $ fun_name <> ": thunk") <> profStat s pushRestoreCCS <> returnS c)
             , (toJExpr Fun, traceRts s (toJExpr $ fun_name <> ": fun") <> fun_case)
             , (toJExpr Pap, traceRts s (toJExpr $ fun_name <> ": pap") <> pap_case)
             , (toJExpr Blackhole, push' s [r1, hdReturn] <> returnS (app hdBlockOnBlackHoleStr [r1]))
             ] (appS throwStr [toJExpr ("panic: " <> fun_name <> ", unexpected closure type: ") + (infoClosureType c)])
           ]

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

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


    funCase :: JStgExpr -> JSM JStgStat
    funCase :: JStgExpr -> JSM JStgStat
funCase JStgExpr
c = ((JStgExpr, JStgExpr, JStgExpr) -> JSM JStgStat) -> JSM JStgStat
forall args.
JSArgument args =>
(args -> JSM JStgStat) -> JSM JStgStat
jVars \(JStgExpr
expr, JStgExpr
ar0, JStgExpr
ar) ->
      do oversat_case <- JStgExpr -> JStgExpr -> JStgExpr -> JSM JStgStat
oversatCase JStgExpr
c JStgExpr
ar0 JStgExpr
ar
         return $ mconcat $
           case expr of
             ValExpr (JVar Ident
pap) -> [ JStgExpr
ar0 JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr -> JStgExpr
infoFunArity JStgExpr
c
                                   , JStgExpr
ar JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr -> JStgExpr
mask8 JStgExpr
ar0
                                   , JStgExpr -> JStgStat -> JStgStat -> JStgStat
ifS (Int -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr Int
nargs JStgExpr -> JStgExpr -> JStgExpr
.===. JStgExpr
ar)
                                     (StgToJSConfig -> JStgExpr -> JStgStat
traceRts StgToJSConfig
s (FastString -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr (FastString
fun_name FastString -> FastString -> FastString
forall a. Semigroup a => a -> a -> a
<> FastString
": exact")) JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> JStgExpr -> JStgStat
funExact JStgExpr
c)
                                     (JStgExpr -> JStgStat -> JStgStat -> JStgStat
ifS (Int -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr Int
nargs JStgExpr -> JStgExpr -> JStgExpr
.>. JStgExpr
ar)
                                      (StgToJSConfig -> JStgExpr -> JStgStat
traceRts StgToJSConfig
s (FastString -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr (FastString
fun_name FastString -> FastString -> FastString
forall a. Semigroup a => a -> a -> a
<> FastString
": oversat"))
                                       JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> JStgStat
oversat_case)
                                      (StgToJSConfig -> JStgExpr -> JStgStat
traceRts StgToJSConfig
s (FastString -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr (FastString
fun_name FastString -> FastString -> FastString
forall a. Semigroup a => a -> a -> a
<> FastString
": undersat"))
                                       JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> StgToJSConfig
-> Ident -> JStgExpr -> JStgExpr -> [JStgExpr] -> JStgStat
mkPap StgToJSConfig
s Ident
pap (StgReg -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr StgReg
R1) (Int -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr Int
nargs) [JStgExpr]
stackArgs
                                       JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> (JStgExpr
sp JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
sp JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
- Int -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr (Int
nvarsInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1))
                                       JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> (JStgExpr
r1 JStgExpr -> JStgExpr -> JStgStat
|= Ident -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr Ident
pap)
                                       JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> JStgStat
returnStack))
                                   ]
             JStgExpr
_                  -> [JStgStat]
forall a. Monoid a => a
mempty


    -- oversat: call the function but keep enough on the stack for the next
    oversatCase :: JStgExpr -- function
                -> JStgExpr -- the arity tag
                -> JStgExpr -- real arity (arity & 0xff)
                -> JSM JStgStat
    oversatCase :: JStgExpr -> JStgExpr -> JStgExpr -> JSM JStgStat
oversatCase JStgExpr
c JStgExpr
arity JStgExpr
arity0 =
      ((JStgExpr, JStgExpr) -> JSM JStgStat) -> JSM JStgStat
forall args.
JSArgument args =>
(args -> JSM JStgStat) -> JSM JStgStat
jVars \(JStgExpr
rs, JStgExpr
newAp) ->
             JStgStat -> JSM JStgStat
forall a. a -> StateT JEnv Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStgStat -> JSM JStgStat) -> JStgStat -> JSM JStgStat
forall a b. (a -> b) -> a -> b
$ [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat ([JStgStat] -> JStgStat) -> [JStgStat] -> JStgStat
forall a b. (a -> b) -> a -> b
$
             [ JStgExpr
rs JStgExpr -> JStgExpr -> JStgStat
|= (JStgExpr
arity JStgExpr -> JStgExpr -> JStgExpr
.>>. JStgExpr
8)
             , JStgExpr -> JStgStat
loadRegs JStgExpr
rs
             , JStgExpr
sp JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
sp JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
- JStgExpr
rs
             , JStgExpr
newAp JStgExpr -> JStgExpr -> JStgStat
|= (JStgExpr
hdApply JStgExpr -> JStgExpr -> JStgExpr
.! ((Int -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr Int
nargsJStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
-JStgExpr
arity0)JStgExpr -> JStgExpr -> JStgExpr
.|.((Int -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr Int
nvarsJStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
-JStgExpr
rs)JStgExpr -> JStgExpr -> JStgExpr
.<<.JStgExpr
8)))
             , JStgExpr
stack JStgExpr -> JStgExpr -> JStgExpr
.! JStgExpr
sp JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
newAp
             , StgToJSConfig -> JStgStat -> JStgStat
profStat StgToJSConfig
s JStgStat
pushRestoreCCS
             , StgToJSConfig -> JStgExpr -> JStgStat
traceRts StgToJSConfig
s (FastString -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr (FastString
fun_name FastString -> FastString -> FastString
forall a. Semigroup a => a -> a -> a
<> FastString
": new stack frame: ") JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
+ (JStgExpr
newAp JStgExpr -> FastString -> JStgExpr
.^ FastString
"n"))
             , JStgExpr -> JStgStat
returnS JStgExpr
c
             ]
      where
        loadRegs :: JStgExpr -> JStgStat
loadRegs JStgExpr
rs = JStgExpr -> [(JStgExpr, JStgStat)] -> JStgStat -> JStgStat
SwitchStat JStgExpr
rs [(JStgExpr, JStgStat)]
switchAlts JStgStat
forall a. Monoid a => a
mempty
          where
            switchAlts :: [(JStgExpr, JStgStat)]
switchAlts = (Int -> (JStgExpr, JStgStat)) -> [Int] -> [(JStgExpr, JStgStat)]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
x -> (Int -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr Int
x, Int -> JStgExpr
jsReg (Int
xInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
stack JStgExpr -> JStgExpr -> JStgExpr
.! (JStgExpr
sp JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
- Int -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr Int
x))) [Int
nvars,Int
nvarsInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1..Int
1]

-- | 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 -> JSM JStgStat
fastApply :: StgToJSConfig -> FastString -> Int -> Int -> JSM JStgStat
fastApply StgToJSConfig
s FastString
fun_name Int
nargs Int
nvars = if Int
nargs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
&& Int
nvars Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
                                   -- special case for h$ap_0_0_fast
                                   then Ident -> JSM JStgStat -> JSM JStgStat
jFunction' Ident
func JSM JStgStat
ap_fast
                                   -- general case
                                   else Ident -> JSM JStgStat -> JSM JStgStat
jFunction' Ident
func JSM JStgStat
body
  where
      func :: Ident
func    = FastString -> Ident
name FastString
fun_name
      ap_fast :: JSM JStgStat
      ap_fast :: JSM JStgStat
ap_fast = StgToJSConfig -> JStgExpr -> JSM JStgStat
enter StgToJSConfig
s JStgExpr
r1

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

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

      body :: JSM JStgStat
body = ((JStgExpr, JStgExpr, JStgExpr) -> JSM JStgStat) -> JSM JStgStat
forall args.
JSArgument args =>
(args -> JSM JStgStat) -> JSM JStgStat
jVars (((JStgExpr, JStgExpr, JStgExpr) -> JSM JStgStat) -> JSM JStgStat)
-> ((JStgExpr, JStgExpr, JStgExpr) -> JSM JStgStat) -> JSM JStgStat
forall a b. (a -> b) -> a -> b
$ \(JStgExpr
c, JStgExpr
farity, JStgExpr
arity)  ->
        do fun_case_fun <- JStgExpr -> JStgExpr -> JSM JStgStat
funCase JStgExpr
c JStgExpr
farity
           fun_case_pap <- funCase c arity
           return $ mconcat $
             [ c |= closureInfo r1
             , traceRts s (toJExpr (fun_name <> ": sp ") + sp)
             , SwitchStat (infoClosureType c)
               [(toJExpr Fun, traceRts s (toJExpr (fun_name <> ": ")
                                          + clName c
                                          + jString " (arity: " + (c .^ "a") + jString ")")
                              <> (farity |= infoFunArity c)
                              <> fun_case_fun)
               ,(toJExpr Pap, traceRts s (toJExpr (fun_name <> ": pap")) <> (arity |= papArity r1) <> fun_case_pap)
               ,(toJExpr Thunk, traceRts s (toJExpr (fun_name <> ": thunk")) <> push' s (reverse regArgs ++ mkAp nargs nvars) <> profStat s pushRestoreCCS <> returnS c)
               ,(toJExpr Blackhole, traceRts s (toJExpr (fun_name <> ": blackhole")) <> push' s (reverse regArgs ++ mkAp nargs nvars) <> push' s [r1, global "h$return"] <> returnS (app "h$blockOnBlackhole" [r1]))]
               (appS throwStr [toJExpr (fun_name <> ": unexpected closure type: ") + infoClosureType c])
             ]

      funCase :: JStgExpr -> JStgExpr -> JSM JStgStat
      funCase :: JStgExpr -> JStgExpr -> JSM JStgStat
funCase JStgExpr
c JStgExpr
arity = ((JStgExpr, JStgExpr) -> JSM JStgStat) -> JSM JStgStat
forall args.
JSArgument args =>
(args -> JSM JStgStat) -> JSM JStgStat
jVars \(JStgExpr
arg, JStgExpr
ar) ->
        do oversat_case <- JStgExpr -> JStgExpr -> JSM JStgStat
oversatCase JStgExpr
c JStgExpr
arity
           return $ mconcat $
             case arg of
               ValExpr (JVar Ident
pap) -> [ JStgExpr
ar JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr -> JStgExpr
mask8 JStgExpr
arity
                                     ,  JStgExpr -> JStgStat -> JStgStat -> JStgStat
ifS (Int -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr Int
nargs JStgExpr -> JStgExpr -> JStgExpr
.===. JStgExpr
ar)
                                     -- then
                                       (StgToJSConfig -> JStgExpr -> JStgStat
traceRts StgToJSConfig
s (FastString -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr (FastString
fun_name FastString -> FastString -> FastString
forall a. Semigroup a => a -> a -> a
<> FastString
": exact")) JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> JStgExpr -> JStgStat
returnS JStgExpr
c)
                                     -- else
                                       (JStgExpr -> JStgStat -> JStgStat -> JStgStat
ifS (Int -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr Int
nargs JStgExpr -> JStgExpr -> JStgExpr
.>. JStgExpr
ar)
                                       --then
                                        (StgToJSConfig -> JStgExpr -> JStgStat
traceRts StgToJSConfig
s (FastString -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr (FastString
fun_name FastString -> FastString -> FastString
forall a. Semigroup a => a -> a -> a
<> FastString
": oversat")) JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> JStgStat
oversat_case)
                                       -- else
                                        (StgToJSConfig -> JStgExpr -> JStgStat
traceRts StgToJSConfig
s (FastString -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr (FastString
fun_name FastString -> FastString -> FastString
forall a. Semigroup a => a -> a -> a
<> FastString
": undersat"))
                                         JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> StgToJSConfig
-> Ident -> JStgExpr -> JStgExpr -> [JStgExpr] -> JStgStat
mkPap StgToJSConfig
s Ident
pap JStgExpr
r1 (Int -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr Int
nargs) [JStgExpr]
regArgs
                                         JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> (JStgExpr
r1 JStgExpr -> JStgExpr -> JStgStat
|= Ident -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr Ident
pap)
                                         JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> JStgStat
returnStack))
                                     ]
               JStgExpr
_             -> [JStgStat]
forall a. Monoid a => a
mempty

      oversatCase :: JStgExpr -> JStgExpr -> JSM JStgStat
      oversatCase :: JStgExpr -> JStgExpr -> JSM JStgStat
oversatCase JStgExpr
c JStgExpr
arity =
         ((JStgExpr, JStgExpr) -> JSM JStgStat) -> JSM JStgStat
forall args.
JSArgument args =>
(args -> JSM JStgStat) -> JSM JStgStat
jVars \(JStgExpr
rs, JStgExpr
rsRemain) ->
                JStgStat -> JSM JStgStat
forall a. a -> StateT JEnv Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStgStat -> JSM JStgStat) -> JStgStat -> JSM JStgStat
forall a b. (a -> b) -> a -> b
$ [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat ([JStgStat] -> JStgStat) -> [JStgStat] -> JStgStat
forall a b. (a -> b) -> a -> b
$
                [ JStgExpr
rs JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
arity JStgExpr -> JStgExpr -> JStgExpr
.>>. JStgExpr
8
                , JStgExpr
rsRemain JStgExpr -> JStgExpr -> JStgStat
|= Int -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr Int
nvars JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
- JStgExpr
rs
                , StgToJSConfig -> JStgExpr -> JStgStat
traceRts StgToJSConfig
s (FastString -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr
                              (FastString
fun_name FastString -> FastString -> FastString
forall a. Semigroup a => a -> a -> a
<> FastString
" regs oversat ")
                              JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
+ JStgExpr
rs
                              JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
+ FastString -> JStgExpr
jString FastString
" remain: "
                              JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
+ JStgExpr
rsRemain)
                , JStgExpr -> JStgStat
saveRegs JStgExpr
rs
                , JStgExpr
sp JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
sp JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
+ JStgExpr
rsRemain JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
+ JStgExpr
1
                , JStgExpr
stack JStgExpr -> JStgExpr -> JStgExpr
.! JStgExpr
sp JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
hdApply JStgExpr -> JStgExpr -> JStgExpr
.! ((JStgExpr
rsRemainJStgExpr -> JStgExpr -> JStgExpr
.<<.JStgExpr
8)JStgExpr -> JStgExpr -> JStgExpr
.|. (Int -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr Int
nargs JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
- JStgExpr -> JStgExpr
mask8 JStgExpr
arity))
                , StgToJSConfig -> JStgStat -> JStgStat
profStat StgToJSConfig
s JStgStat
pushRestoreCCS
                , JStgExpr -> JStgStat
returnS JStgExpr
c
                ]
        where
          saveRegs :: JStgExpr -> JStgStat
saveRegs JStgExpr
n = JStgExpr -> [(JStgExpr, JStgStat)] -> JStgStat -> JStgStat
SwitchStat JStgExpr
n [(JStgExpr, JStgStat)]
switchAlts JStgStat
forall a. Monoid a => a
mempty
            where
              switchAlts :: [(JStgExpr, JStgStat)]
switchAlts = (Int -> (JStgExpr, JStgStat)) -> [Int] -> [(JStgExpr, JStgStat)]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
x -> (Int -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr Int
x, JStgExpr
stack JStgExpr -> JStgExpr -> JStgExpr
.! (JStgExpr
sp JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
+ Int -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr (Int
nvarsInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
x)) JStgExpr -> JStgExpr -> JStgStat
|= Int -> JStgExpr
jsReg (Int
xInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
2))) [Int
0..Int
nvarsInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]

zeroApply :: StgToJSConfig -> JSM JStgStat
zeroApply :: StgToJSConfig -> JSM JStgStat
zeroApply StgToJSConfig
s = Ident -> (Solo JStgExpr -> JSM JStgStat) -> JSM JStgStat
forall args.
JSArgument args =>
Ident -> (args -> JSM JStgStat) -> JSM JStgStat
jFunction Ident
hdEntry
              ((Solo JStgExpr -> JSM JStgStat) -> JSM JStgStat)
-> (Solo JStgExpr -> JSM JStgStat) -> JSM JStgStat
forall a b. (a -> b) -> a -> b
$ \(MkSolo JStgExpr
c) -> (JStgStat -> JStgStat) -> JSM JStgStat -> JSM JStgStat
forall a b.
(a -> b) -> StateT JEnv Identity a -> StateT JEnv Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((JStgExpr
r1 JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
c) JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<>) (JSM JStgStat -> JSM JStgStat) -> JSM JStgStat -> JSM JStgStat
forall a b. (a -> b) -> a -> b
$ StgToJSConfig -> JStgExpr -> JSM JStgStat
enter StgToJSConfig
s JStgExpr
c

-- 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 -> JStgExpr -> JSM JStgStat
enter :: StgToJSConfig -> JStgExpr -> JSM JStgStat
enter StgToJSConfig
s JStgExpr
ex = (JStgExpr -> JSM JStgStat) -> JSM JStgStat
forall t.
(JVarMagic t, ToJExpr t) =>
(t -> JSM JStgStat) -> JSM JStgStat
jVar \JStgExpr
c ->
  JStgStat -> JSM JStgStat
forall a. a -> StateT JEnv Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStgStat -> JSM JStgStat) -> JStgStat -> JSM JStgStat
forall a b. (a -> b) -> a -> b
$ [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat ([JStgStat] -> JStgStat) -> [JStgStat] -> JStgStat
forall a b. (a -> b) -> a -> b
$
  [ JStgExpr -> JStgStat -> JStgStat
jwhenS (FastString -> [JStgExpr] -> JStgExpr
app FastString
typeof [JStgExpr
ex] JStgExpr -> JStgExpr -> JStgExpr
.!==. JStgExpr
jTyObject) JStgStat
returnStack
  , JStgExpr
c JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr -> JStgExpr
closureInfo JStgExpr
ex
  , JStgExpr -> JStgStat -> JStgStat
jwhenS (JStgExpr
c JStgExpr -> JStgExpr -> JStgExpr
.===. JStgExpr
hdUnboxEntry) ((JStgExpr
r1 JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr -> JStgExpr
closureField1 JStgExpr
ex) JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> JStgStat
returnStack)
  , JStgExpr -> [(JStgExpr, JStgStat)] -> JStgStat -> JStgStat
SwitchStat (JStgExpr -> JStgExpr
infoClosureType JStgExpr
c)
    [ (ClosureType -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr ClosureType
Con, JStgStat
forall a. Monoid a => a
mempty)
    , (ClosureType -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr ClosureType
Fun, JStgStat
forall a. Monoid a => a
mempty)
    , (ClosureType -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr ClosureType
Pap, JStgStat
returnStack)
    , (ClosureType -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr ClosureType
Blackhole, StgToJSConfig -> [JStgExpr] -> JStgStat
push' StgToJSConfig
s [JStgExpr
hdAp00, JStgExpr
ex, JStgExpr
hdReturn]
        JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> JStgExpr -> JStgStat
returnS (FastString -> [JStgExpr] -> JStgExpr
app FastString
hdBlockOnBlackHoleStr [JStgExpr
ex]))
    ] (JStgExpr -> JStgStat
returnS JStgExpr
c)
  ]

updates :: StgToJSConfig -> JSM JStgStat
updates :: StgToJSConfig -> JSM JStgStat
updates StgToJSConfig
s = do
  upd_frm <- JSM JStgStat
update_frame
  upd_frm_lne <- update_frame_lne
  return $ BlockStat [upd_frm, upd_frm_lne]
  where
    unbox_closure :: JStgExpr -> Closure
unbox_closure JStgExpr
f1 = Closure { clInfo :: JStgExpr
clInfo   = JStgExpr
hdUnboxEntry -- global "h$unbox_e"
                               , clField1 :: JStgExpr
clField1 = JStgExpr
f1
                               , clField2 :: JStgExpr
clField2 = JStgExpr
null_
                               , clMeta :: JStgExpr
clMeta   = JStgExpr
0
                               , clCC :: Maybe JStgExpr
clCC     = Maybe JStgExpr
forall a. Maybe a
Nothing
                               }
    upd_loop' :: JStgExpr -> JStgExpr -> JStgExpr -> JSM JStgStat
upd_loop' JStgExpr
ss' JStgExpr
si' JStgExpr
sir' = JStgExpr
-> (JStgExpr -> JStgExpr)
-> (JStgExpr -> JSM JStgStat)
-> JSM JStgStat
loop JStgExpr
zero_ (JStgExpr -> JStgExpr -> JStgExpr
.<. JStgExpr
ss' JStgExpr -> FastString -> JStgExpr
.^ FastString
"length")
                        ((JStgExpr -> JSM JStgStat) -> JSM JStgStat)
-> (JStgExpr -> JSM JStgStat) -> JSM JStgStat
forall a b. (a -> b) -> a -> b
$ \JStgExpr
i -> JStgStat -> JSM JStgStat
forall a. a -> StateT JEnv Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStgStat -> JSM JStgStat) -> JStgStat -> JSM JStgStat
forall a b. (a -> b) -> a -> b
$ [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat
                          [ JStgExpr
si' JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
ss' JStgExpr -> JStgExpr -> JStgExpr
.! JStgExpr
i
                          , JStgExpr
sir' JStgExpr -> JStgExpr -> JStgStat
|= (JStgExpr -> JStgExpr
closureField2 JStgExpr
si') JStgExpr -> [JStgExpr] -> JStgExpr
`ApplExpr` [JStgExpr
r1]
                          , JStgExpr -> JStgStat -> JStgStat -> JStgStat
ifS (FastString -> [JStgExpr] -> JStgExpr
app FastString
"typeof" [JStgExpr
sir'] JStgExpr -> JStgExpr -> JStgExpr
.===. JStgExpr
jTyObject)
                            (CopyCC -> JStgExpr -> JStgExpr -> JStgStat
copyClosure CopyCC
DontCopyCC JStgExpr
si' JStgExpr
sir')
                            (JStgExpr -> Closure -> JStgStat
assignClosure JStgExpr
si' (Closure -> JStgStat) -> Closure -> JStgStat
forall a b. (a -> b) -> a -> b
$ JStgExpr -> Closure
unbox_closure JStgExpr
sir')
                          , JStgExpr -> JStgStat
postIncrS JStgExpr
i
                          ]
    update_frame :: JSM JStgStat
update_frame = ClosureInfo -> JSM JStgStat -> JSM JStgStat
closure
                   (ClosureInfo
                      { ciVar :: Ident
ciVar = Ident
hdUpdFrameStr
                      , ciRegs :: CIRegs
ciRegs = Int -> [JSRep] -> CIRegs
CIRegs Int
0 [JSRep
PtrV]
                      , ciName :: FastString
ciName = Ident -> FastString
identFS Ident
hdUpdFrameStr
                      , ciLayout :: CILayout
ciLayout = Int -> [JSRep] -> CILayout
CILayoutFixed Int
1 [JSRep
PtrV]
                      , ciType :: CIType
ciType = CIType
CIStackFrame
                      , ciStatic :: CIStatic
ciStatic = CIStatic
forall a. Monoid a => a
mempty
                      })
                   (JSM JStgStat -> JSM JStgStat) -> JSM JStgStat -> JSM JStgStat
forall a b. (a -> b) -> a -> b
$ ((JStgExpr, JStgExpr, JStgExpr, JStgExpr, JStgExpr)
 -> JSM JStgStat)
-> JSM JStgStat
forall args.
JSArgument args =>
(args -> JSM JStgStat) -> JSM JStgStat
jVars \(JStgExpr
updatee, JStgExpr
waiters, JStgExpr
ss, JStgExpr
si, JStgExpr
sir) ->
                       do upd_loop         <- JStgExpr -> JStgExpr -> JStgExpr -> JSM JStgStat
upd_loop' JStgExpr
ss JStgExpr
si JStgExpr
sir
                          wake_thread_loop <- loop zero_ (.<. waiters .^ "length")
                                              \JStgExpr
i -> JStgStat -> JSM JStgStat
forall a. a -> StateT JEnv Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStgStat -> JSM JStgStat) -> JStgStat -> JSM JStgStat
forall a b. (a -> b) -> a -> b
$
                                                    FastString -> [JStgExpr] -> JStgStat
appS FastString
hdWakeupThread [JStgExpr
waiters JStgExpr -> JStgExpr -> JStgExpr
.! JStgExpr
i]
                                                    JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> JStgExpr -> JStgStat
postIncrS JStgExpr
i
                          let updateCC JStgExpr
updatee = JStgExpr -> JStgExpr
closureCC JStgExpr
updatee JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
jCurrentCCS

                          return $ mconcat $
                            [ updatee |= stack .! (sp - 1)
                               , traceRts s (jString "h$upd_frame updatee alloc: " + updatee .^ "alloc")
                               , -- wake up threads blocked on blackhole
                                 waiters |= closureField2 updatee
                               , jwhenS (waiters .!==. null_) wake_thread_loop
                               , -- update selectors
                                 jwhenS ((app typeof [closureMeta updatee] .===. jTyObject) .&&. (closureMeta updatee .^ "sel"))
                                 ((ss |= closureMeta updatee .^ "sel")
                                  <> upd_loop)
                               , -- overwrite the object
                                 ifS (app typeof [r1] .===. jTyObject)
                                 (mconcat [ traceRts s (jString "$upd_frame: boxed: " + ((closureInfo r1) .^ "n"))
                                          , copyClosure DontCopyCC updatee 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.
                                 (assignClosure updatee (unbox_closure r1))
                               , profStat s (updateCC updatee)
                               , adjSpN' 2
                               , traceRts s (jString "h$upd_frame: updating: "
                                             + updatee
                                             + jString " -> "
                                             + r1)
                               , returnStack
                               ]

    update_frame_lne :: JSM JStgStat
update_frame_lne = ClosureInfo -> JSM JStgStat -> JSM JStgStat
closure
                     (ClosureInfo
                        { ciVar :: Ident
ciVar = FastString -> Ident
name (FastString -> Ident) -> FastString -> Ident
forall a b. (a -> b) -> a -> b
$ [Char] -> FastString
fsLit [Char]
"h$upd_frame_lne"
                        , ciRegs :: CIRegs
ciRegs = Int -> [JSRep] -> CIRegs
CIRegs Int
0 [JSRep
PtrV]
                        , ciName :: FastString
ciName = FastString
"h$upd_frame_lne"
                        , ciLayout :: CILayout
ciLayout = Int -> [JSRep] -> CILayout
CILayoutFixed Int
1 [JSRep
PtrV]
                        , ciType :: CIType
ciType = CIType
CIStackFrame
                        , ciStatic :: CIStatic
ciStatic = CIStatic
forall a. Monoid a => a
mempty
                        })
                     (JSM JStgStat -> JSM JStgStat) -> JSM JStgStat -> JSM JStgStat
forall a b. (a -> b) -> a -> b
$ (JStgExpr -> JSM JStgStat) -> JSM JStgStat
forall t.
(JVarMagic t, ToJExpr t) =>
(t -> JSM JStgStat) -> JSM JStgStat
jVar \JStgExpr
updateePos ->
                         JStgStat -> JSM JStgStat
forall a. a -> StateT JEnv Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStgStat -> JSM JStgStat) -> JStgStat -> JSM JStgStat
forall a b. (a -> b) -> a -> b
$ [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat ([JStgStat] -> JStgStat) -> [JStgStat] -> JStgStat
forall a b. (a -> b) -> a -> b
$
                         [ JStgExpr
updateePos JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
stack JStgExpr -> JStgExpr -> JStgExpr
.! (JStgExpr
sp JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
- JStgExpr
1)
                         , JStgExpr
stack JStgExpr -> JStgExpr -> JStgExpr
.! JStgExpr
updateePos JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
r1
                         , Int -> JStgStat
adjSpN' Int
2
                         , StgToJSConfig -> JStgExpr -> JStgStat
traceRts StgToJSConfig
s (FastString -> JStgExpr
jString FastString
"h$upd_frame_lne: updating: "
                                       JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
+ JStgExpr
updateePos
                                       JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
+ FastString -> JStgExpr
jString FastString
" -> "
                                       JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
+ JStgExpr
r1)
                         , JStgStat
returnStack
                         ]

selectors :: StgToJSConfig -> JSM JStgStat
selectors :: StgToJSConfig -> JSM JStgStat
selectors StgToJSConfig
s =
  do
    sel_one  <- FastString -> (JStgExpr -> JStgExpr) -> JSM JStgStat
mkSel FastString
"1"      JStgExpr -> JStgExpr
closureField1
    sel_twoA <- mkSel "2a"  closureField2
    sel_twoB <- mkSel "2b"  (closureField1 . closureField2)
    rest     <- mconcat <$> mapM mkSelN [3..16]
    return $
      sel_one <> sel_twoA <> sel_twoB <> rest
   where
    mkSelN :: Int -> JSM JStgStat
    mkSelN :: Int -> JSM JStgStat
mkSelN Int
x = FastString -> (JStgExpr -> JStgExpr) -> JSM JStgStat
mkSel ([Char] -> FastString
mkFastString ([Char] -> FastString) -> [Char] -> FastString
forall a b. (a -> b) -> a -> b
$ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
x)
                     (\JStgExpr
e -> JStgExpr -> Ident -> JStgExpr
SelExpr (JStgExpr -> JStgExpr
closureField2 (JStgExpr -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr JStgExpr
e))
                            (FastString -> Ident
name (FastString -> Ident) -> FastString -> Ident
forall a b. (a -> b) -> a -> b
$ [Char] -> FastString
mkFastString ([Char]
"d" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (Int
xInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1))))


    mkSel :: FastString -> (JStgExpr -> JStgExpr) -> JSM JStgStat
    mkSel :: FastString -> (JStgExpr -> JStgExpr) -> JSM JStgStat
mkSel FastString
name_ JStgExpr -> JStgExpr
sel = [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat ([JStgStat] -> JStgStat)
-> StateT JEnv Identity [JStgStat] -> JSM JStgStat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [JSM JStgStat] -> StateT JEnv Identity [JStgStat]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence
      [Ident -> (Solo JStgExpr -> JSM JStgStat) -> JSM JStgStat
forall args.
JSArgument args =>
Ident -> (args -> JSM JStgStat) -> JSM JStgStat
jFunction (FastString -> Ident
name FastString
createName) ((Solo JStgExpr -> JSM JStgStat) -> JSM JStgStat)
-> (Solo JStgExpr -> JSM JStgStat) -> JSM JStgStat
forall a b. (a -> b) -> a -> b
$
       \(MkSolo JStgExpr
r) -> JStgStat -> JSM JStgStat
forall a. a -> StateT JEnv Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStgStat -> JSM JStgStat) -> JStgStat -> JSM JStgStat
forall a b. (a -> b) -> a -> b
$ [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat
          [ StgToJSConfig -> JStgExpr -> JStgStat
traceRts StgToJSConfig
s (FastString -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr (FastString
"selector create: " FastString -> FastString -> FastString
forall a. Semigroup a => a -> a -> a
<> FastString
name_ FastString -> FastString -> FastString
forall a. Semigroup a => a -> a -> a
<> FastString
" for ") JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
+ (JStgExpr
r JStgExpr -> FastString -> JStgExpr
.^ FastString
"alloc"))
          , JStgExpr -> JStgStat -> JStgStat -> JStgStat
ifS (JStgExpr -> JStgExpr
isThunk JStgExpr
r JStgExpr -> JStgExpr -> JStgExpr
.||. JStgExpr -> JStgExpr
isBlackhole JStgExpr
r)
              (JStgExpr -> JStgStat
returnS (FastString -> [JStgExpr] -> JStgExpr
app FastString
"h$mkSelThunk" [JStgExpr
r, JVal -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr (FastString -> JVal
v FastString
entryName), JVal -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr (FastString -> JVal
v FastString
resName)]))
              (JStgExpr -> JStgStat
returnS (JStgExpr -> JStgExpr
sel JStgExpr
r))
          ]
      , Ident -> (Solo JStgExpr -> JSM JStgStat) -> JSM JStgStat
forall args.
JSArgument args =>
Ident -> (args -> JSM JStgStat) -> JSM JStgStat
jFunction (FastString -> Ident
name FastString
resName) ((Solo JStgExpr -> JSM JStgStat) -> JSM JStgStat)
-> (Solo JStgExpr -> JSM JStgStat) -> JSM JStgStat
forall a b. (a -> b) -> a -> b
$
        \(MkSolo JStgExpr
r) -> JStgStat -> JSM JStgStat
forall a. a -> StateT JEnv Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStgStat -> JSM JStgStat) -> JStgStat -> JSM JStgStat
forall a b. (a -> b) -> a -> b
$ [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat
          [ StgToJSConfig -> JStgExpr -> JStgStat
traceRts StgToJSConfig
s (FastString -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr (FastString
"selector result: " FastString -> FastString -> FastString
forall a. Semigroup a => a -> a -> a
<> FastString
name_ FastString -> FastString -> FastString
forall a. Semigroup a => a -> a -> a
<> FastString
" for ") JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
+ (JStgExpr
r JStgExpr -> FastString -> JStgExpr
.^ FastString
"alloc"))
          , JStgExpr -> JStgStat
returnS (JStgExpr -> JStgExpr
sel JStgExpr
r)
          ]
      , ClosureInfo -> JSM JStgStat -> JSM JStgStat
closure
        (ClosureInfo
          { ciVar :: Ident
ciVar = FastString -> Ident
name FastString
entryName
          , ciRegs :: CIRegs
ciRegs = Int -> [JSRep] -> CIRegs
CIRegs Int
0 [JSRep
PtrV]
          , ciName :: FastString
ciName = FastString
"select " FastString -> FastString -> FastString
forall a. Semigroup a => a -> a -> a
<> FastString
name_
          , ciLayout :: CILayout
ciLayout = Int -> [JSRep] -> CILayout
CILayoutFixed Int
1 [JSRep
PtrV]
          , ciType :: CIType
ciType = CIType
CIThunk
          , ciStatic :: CIStatic
ciStatic = CIStatic
forall a. Monoid a => a
mempty
          })
        ((JStgExpr -> JSM JStgStat) -> JSM JStgStat
forall t.
(JVarMagic t, ToJExpr t) =>
(t -> JSM JStgStat) -> JSM JStgStat
jVar ((JStgExpr -> JSM JStgStat) -> JSM JStgStat)
-> (JStgExpr -> JSM JStgStat) -> JSM JStgStat
forall a b. (a -> b) -> a -> b
$ \JStgExpr
tgt ->
          JStgStat -> JSM JStgStat
forall a. a -> StateT JEnv Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStgStat -> JSM JStgStat) -> JStgStat -> JSM JStgStat
forall a b. (a -> b) -> a -> b
$ [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat ([JStgStat] -> JStgStat) -> [JStgStat] -> JStgStat
forall a b. (a -> b) -> a -> b
$
          [ JStgExpr
tgt JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr -> JStgExpr
closureField1 JStgExpr
r1
          , StgToJSConfig -> JStgExpr -> JStgStat
traceRts StgToJSConfig
s (FastString -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr (FastString
"selector entry: " FastString -> FastString -> FastString
forall a. Semigroup a => a -> a -> a
<> FastString
name_ FastString -> FastString -> FastString
forall a. Semigroup a => a -> a -> a
<> FastString
" for ") JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
+ (JStgExpr
tgt JStgExpr -> FastString -> JStgExpr
.^ FastString
"alloc"))
          , JStgExpr -> JStgStat -> JStgStat -> JStgStat
ifS (JStgExpr -> JStgExpr
isThunk JStgExpr
tgt JStgExpr -> JStgExpr -> JStgExpr
.||. JStgExpr -> JStgExpr
isBlackhole JStgExpr
tgt)
              (JStgExpr -> JStgStat
preIncrS JStgExpr
sp
               JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> (JStgExpr
stack JStgExpr -> JStgExpr -> JStgExpr
.! JStgExpr
sp JStgExpr -> JStgExpr -> JStgStat
|= FastString -> JStgExpr
global FastString
frameName)
               JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> JStgExpr -> JStgStat
returnS (FastString -> [JStgExpr] -> JStgExpr
app FastString
"h$e" [JStgExpr
tgt]))
              (JStgExpr -> JStgStat
returnS (FastString -> [JStgExpr] -> JStgExpr
app FastString
"h$e" [JStgExpr -> JStgExpr
sel JStgExpr
tgt]))
          ])
      , ClosureInfo -> JSM JStgStat -> JSM JStgStat
closure
        (ClosureInfo
          { ciVar :: Ident
ciVar = FastString -> Ident
name FastString
frameName
          , ciRegs :: CIRegs
ciRegs = Int -> [JSRep] -> CIRegs
CIRegs Int
0 [JSRep
PtrV]
          , ciName :: FastString
ciName = FastString
"select " FastString -> FastString -> FastString
forall a. Semigroup a => a -> a -> a
<> FastString
name_ FastString -> FastString -> FastString
forall a. Semigroup a => a -> a -> a
<> FastString
" frame"
          , ciLayout :: CILayout
ciLayout = Int -> [JSRep] -> CILayout
CILayoutFixed Int
0 []
          , ciType :: CIType
ciType = CIType
CIStackFrame
          , ciStatic :: CIStatic
ciStatic = CIStatic
forall a. Monoid a => a
mempty
          })
        (JSM JStgStat -> JSM JStgStat) -> JSM JStgStat -> JSM JStgStat
forall a b. (a -> b) -> a -> b
$ JStgStat -> JSM JStgStat
forall a. a -> StateT JEnv Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStgStat -> JSM JStgStat) -> JStgStat -> JSM JStgStat
forall a b. (a -> b) -> a -> b
$
        [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat [ StgToJSConfig -> JStgExpr -> JStgStat
traceRts StgToJSConfig
s (FastString -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr (FastString
"selector frame: " FastString -> FastString -> FastString
forall a. Semigroup a => a -> a -> a
<> FastString
name_))
                , JStgExpr -> JStgStat
postDecrS JStgExpr
sp
                , JStgExpr -> JStgStat
returnS (FastString -> [JStgExpr] -> JStgExpr
app FastString
"h$e" [JStgExpr -> JStgExpr
sel JStgExpr
r1])
                ]
      ]

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


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

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

-- | 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
name (FastString -> Ident) -> (Int -> FastString) -> Int -> Ident
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> FastString
mkFastString ([Char] -> FastString) -> (Int -> [Char]) -> Int -> FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
"h$pap_"[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> (Int -> [Char]) -> Int -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Char]
forall a. Show a => a -> [Char]
show) [Int]
specPap

pap :: StgToJSConfig
    -> Int
    -> JSM JStgStat
pap :: StgToJSConfig -> Int -> JSM JStgStat
pap StgToJSConfig
s Int
r = ClosureInfo -> JSM JStgStat -> JSM JStgStat
closure (ClosureInfo
                    { ciVar :: Ident
ciVar = Ident
funcIdent
                    , ciRegs :: CIRegs
ciRegs = CIRegs
CIRegsUnknown
                    , ciName :: FastString
ciName = FastString
funcName
                    , ciLayout :: CILayout
ciLayout = Int -> CILayout
CILayoutUnknown (Int
rInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
2)
                    , ciType :: CIType
ciType = CIType
CIPap
                    , ciStatic :: CIStatic
ciStatic = CIStatic
forall a. Monoid a => a
mempty
                    }) JSM JStgStat
body
  where
    funcIdent :: Ident
funcIdent = FastString -> Ident
name FastString
funcName
    funcName :: FastString
funcName = [Char] -> FastString
mkFastString ([Char]
"h$pap_" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
r)

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

-- Construct a generic PAP
papGen :: StgToJSConfig -> JSM JStgStat
papGen :: StgToJSConfig -> JSM JStgStat
papGen StgToJSConfig
cfg =
   ClosureInfo -> JSM JStgStat -> JSM JStgStat
closure (ClosureInfo
              { ciVar :: Ident
ciVar = Ident
funcIdent
              , ciRegs :: CIRegs
ciRegs = CIRegs
CIRegsUnknown
              , ciName :: FastString
ciName = FastString
funcName
              , ciLayout :: CILayout
ciLayout = CILayout
CILayoutVariable
              , ciType :: CIType
ciType = CIType
CIPap
              , ciStatic :: CIStatic
ciStatic = CIStatic
forall a. Monoid a => a
mempty
              })
           (((JStgExpr, JStgExpr, JStgExpr, JStgExpr, JStgExpr, JStgExpr)
 -> JSM JStgStat)
-> JSM JStgStat
forall args.
JSArgument args =>
(args -> JSM JStgStat) -> JSM JStgStat
jVars (((JStgExpr, JStgExpr, JStgExpr, JStgExpr, JStgExpr, JStgExpr)
  -> JSM JStgStat)
 -> JSM JStgStat)
-> ((JStgExpr, JStgExpr, JStgExpr, JStgExpr, JStgExpr, JStgExpr)
    -> JSM JStgStat)
-> JSM JStgStat
forall a b. (a -> b) -> a -> b
$ \(JStgExpr
c, JStgExpr
f, JStgExpr
d, JStgExpr
pr, JStgExpr
or, JStgExpr
r) ->
              JStgStat -> JSM JStgStat
forall a. a -> StateT JEnv Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStgStat -> JSM JStgStat) -> JStgStat -> JSM JStgStat
forall a b. (a -> b) -> a -> b
$ [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat
              [ JStgExpr
c JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr -> JStgExpr
closureField1 JStgExpr
r1
              , JStgExpr
d JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr -> JStgExpr
closureField2 JStgExpr
r1
              , JStgExpr
f JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr -> JStgExpr
closureInfo  JStgExpr
c
              , JStgExpr
pr JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr -> Maybe JStgExpr -> JStgExpr
funOrPapArity JStgExpr
c (JStgExpr -> Maybe JStgExpr
forall a. a -> Maybe a
Just JStgExpr
f) JStgExpr -> JStgExpr -> JStgExpr
.>>. JStgExpr
8
              , JStgExpr
or JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr -> JStgExpr
papArity JStgExpr
r1 JStgExpr -> JStgExpr -> JStgExpr
.>>. JStgExpr
8
              , JStgExpr
r JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
pr JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
- JStgExpr
or
              , StgToJSConfig -> JStgExpr -> JStgExpr -> JStgStat
forall a. ToJExpr a => StgToJSConfig -> JStgExpr -> a -> JStgStat
assertRts StgToJSConfig
cfg
                (JStgExpr -> JStgExpr
isFun' JStgExpr
f JStgExpr -> JStgExpr -> JStgExpr
.||. JStgExpr -> JStgExpr
isPap' JStgExpr
f)
                (FastString -> JStgExpr
jString FastString
"h$pap_gen: expected function or pap")
              , StgToJSConfig -> JStgStat -> JStgStat
profStat StgToJSConfig
cfg (CostCentreStack -> JStgStat
enterCostCentreFun CostCentreStack
currentCCS)
              , StgToJSConfig -> JStgExpr -> JStgStat
traceRts StgToJSConfig
cfg (FastString -> JStgExpr
jString FastString
"h$pap_gen: generic pap extra args moving: " JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
+ JStgExpr
or)
              , FastString -> [JStgExpr] -> JStgStat
appS FastString
hdMoveRegs2 [JStgExpr
or, JStgExpr
r]
              , JStgExpr -> JStgExpr -> JStgStat
loadOwnArgs JStgExpr
d JStgExpr
r
              , JStgExpr
r1 JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
c
              , JStgExpr -> JStgStat
returnS JStgExpr
f
              ])


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

-- general utilities
-- move the first n registers, starting at R2, m places up (do not use with negative m)
moveRegs2 :: JSM JStgStat
moveRegs2 :: JSM JStgStat
moveRegs2 = Ident -> ((JStgExpr, JStgExpr) -> JSM JStgStat) -> JSM JStgStat
forall args.
JSArgument args =>
Ident -> (args -> JSM JStgStat) -> JSM JStgStat
jFunction (FastString -> Ident
name FastString
hdMoveRegs2) (JStgExpr, JStgExpr) -> JSM JStgStat
moveSwitch
  where
    moveSwitch :: (JStgExpr, JStgExpr) -> JSM JStgStat
moveSwitch (JStgExpr
n,JStgExpr
m) = JStgExpr -> JStgExpr -> JSM JStgStat
defaultCase JStgExpr
n JStgExpr
m JSM JStgStat -> (JStgStat -> JSM JStgStat) -> JSM JStgStat
forall a b.
StateT JEnv Identity a
-> (a -> StateT JEnv Identity b) -> StateT JEnv Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= JStgStat -> JSM JStgStat
forall a. a -> StateT JEnv Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStgStat -> JSM JStgStat)
-> (JStgStat -> JStgStat) -> JStgStat -> JSM JStgStat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JStgExpr -> [(JStgExpr, JStgStat)] -> JStgStat -> JStgStat
SwitchStat ((JStgExpr
n JStgExpr -> JStgExpr -> JStgExpr
.<<. JStgExpr
8) JStgExpr -> JStgExpr -> JStgExpr
.|. JStgExpr
m) [(JStgExpr, JStgStat)]
switchCases
    -- fast cases
    switchCases :: [(JStgExpr, JStgStat)]
switchCases = [Int -> Int -> (JStgExpr, JStgStat)
switchCase Int
n Int
m | Int
n <- [Int
1..Int
5], Int
m <- [Int
1..Int
4]]
    switchCase :: Int -> Int -> (JStgExpr, JStgStat)
    switchCase :: Int -> Int -> (JStgExpr, JStgStat)
switchCase Int
n Int
m = (Int -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr (Int -> JStgExpr) -> Int -> JStgExpr
forall a b. (a -> b) -> a -> b
$
                      (Int
n Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`Bits.shiftL` Int
8) Int -> Int -> Int
forall a. Bits a => a -> a -> a
Bits..|. Int
m
                     , [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat ((Int -> JStgStat) -> [Int] -> [JStgStat]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Int -> JStgStat
`moveRegFast` Int
m) [Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1,Int
n..Int
2])
                       JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> Maybe JsLabel -> JStgStat
BreakStat Maybe JsLabel
forall a. Maybe a
Nothing {-[j| break; |]-})
    moveRegFast :: Int -> Int -> JStgStat
moveRegFast Int
n Int
m = Int -> JStgExpr
jsReg (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
m) JStgExpr -> JStgExpr -> JStgStat
|= Int -> JStgExpr
jsReg Int
n
    -- fallback
    defaultCase :: JStgExpr -> JStgExpr -> JSM JStgStat
defaultCase JStgExpr
n JStgExpr
m =
      JStgExpr
-> (JStgExpr -> JStgExpr)
-> (JStgExpr -> JSM JStgStat)
-> JSM JStgStat
loop JStgExpr
n (JStgExpr -> JStgExpr -> JStgExpr
.>.JStgExpr
0) (\JStgExpr
i -> JStgStat -> JSM JStgStat
forall a. a -> StateT JEnv Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStgStat -> JSM JStgStat) -> JStgStat -> JSM JStgStat
forall a b. (a -> b) -> a -> b
$
                           FastString -> [JStgExpr] -> JStgStat
appS FastString
hdSetRegStr [JStgExpr
iJStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
+JStgExpr
1JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
+JStgExpr
m, FastString -> [JStgExpr] -> JStgExpr
app FastString
hdGetRegStr [JStgExpr
iJStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
+JStgExpr
1]]
                           JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> JStgExpr -> JStgStat
postDecrS JStgExpr
i)


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

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

-- | Store fields of Id into the given target expressions
storeIdFields :: Id -> [TypedExpr] -> G JStgStat
storeIdFields :: Id -> [TypedExpr] -> G JStgStat
storeIdFields Id
i [TypedExpr]
dst = do
  fields <- Id -> G [TypedExpr]
getIdFields Id
i
  pure (assignCoerce1 dst fields)