{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications  #-}
{-# LANGUAGE BlockArguments    #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  GHC.StgToJS.Rts.Rts
-- 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
--
-- Top level driver of the JavaScript Backend RTS. This file is an
-- implementation of the JS RTS for the JS backend written as an EDSL in
-- Haskell. It assumes the existence of pre-generated JS functions, included as
-- js-sources in base. These functions are similarly assumed for non-inline
-- Primops, See 'GHC.StgToJS.Prim'. Most of the elements in this module are
-- constants in Haskell Land which define pieces of the JS RTS.
--
-----------------------------------------------------------------------------

module GHC.StgToJS.Rts.Rts
  ( rts
  , assignRegs
  )
where

import GHC.Prelude

import GHC.JS.JStg.Syntax
import GHC.JS.JStg.Monad
import GHC.JS.Make hiding (trace)
import GHC.JS.Ident

import GHC.StgToJS.Apply
import GHC.StgToJS.Closure
import GHC.StgToJS.Heap
import GHC.StgToJS.Profiling
import GHC.StgToJS.Regs
import GHC.StgToJS.Types
import GHC.StgToJS.Stack

import GHC.Data.FastString
import GHC.Types.Unique.Map

import Data.Array
import Data.Monoid
import Data.Char (toLower, toUpper)
import qualified Data.Bits          as Bits

-- | The garbageCollector resets registers and result variables.
garbageCollector :: JSM JStgStat
garbageCollector :: JSM JStgStat
garbageCollector = [JSM JStgStat] -> JSM JStgStat
forall a. Monoid a => [JSM a] -> JSM a
jBlock
    [ Ident -> JSM JStgStat -> JSM JStgStat
jFunction' (FastString -> Ident
global FastString
"h$resetRegisters")  (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
$ (StgReg -> JStgStat) -> [StgReg] -> [JStgStat]
forall a b. (a -> b) -> [a] -> [b]
map StgReg -> JStgStat
resetRegister [StgReg
forall a. Bounded a => a
minBound..StgReg
forall a. Bounded a => a
maxBound])
    , Ident -> JSM JStgStat -> JSM JStgStat
jFunction' (FastString -> Ident
global FastString
"h$resetResultVars") (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
$ (StgRet -> JStgStat) -> [StgRet] -> [JStgStat]
forall a b. (a -> b) -> [a] -> [b]
map StgRet -> JStgStat
resetResultVar [StgRet
forall a. Bounded a => a
minBound..StgRet
forall a. Bounded a => a
maxBound])
    ]

-- | Reset the register 'r' in JS Land. Note that this "resets" by setting the
-- register to a dummy variable called "null", /not/ by setting to JS's nil
-- value.
resetRegister :: StgReg -> JStgStat
resetRegister :: StgReg -> JStgStat
resetRegister StgReg
r = StgReg -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr StgReg
r JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
null_

-- | Reset the return variable 'r' in JS Land. Note that this "resets" by
-- setting the register to a dummy variable called "null", /not/ by setting to
-- JS's nil value.
resetResultVar :: StgRet -> JStgStat
resetResultVar :: StgRet -> JStgStat
resetResultVar StgRet
r = StgRet -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr StgRet
r JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
null_

-- | Define closures based on size, these functions are syntactic sugar, e.g., a
-- Haskell function which generates some useful JS. Each Closure constructor
-- follows the naming convention h$cN, where N is a natural number. For example,
-- h$c (with the nat omitted) is a JS Land Constructor for a closure in JS land
-- which has a single entry function 'f', and no fields; identical to h$c0. h$c1
-- is a JS Land Constructor for a closure with an entry function 'f', and a
-- /single/ field 'x1', 'Just foo' is an example of this kind of closure. h$c2
-- is a JS Land Constructor for a closure with an entry function and two data
-- fields: 'x1' and 'x2'. And so on. Note that this has JIT performance
-- implications; you should use h$c1, h$c2, h$c3, ... h$c24 instead of making
-- objects manually so layouts and fields can be changed more easily and so the
-- JIT can optimize better.
closureConstructors :: StgToJSConfig -> JSM JStgStat
closureConstructors :: StgToJSConfig -> JSM JStgStat
closureConstructors StgToJSConfig
s = do
 closures <- (Maybe Int -> JSM JStgStat)
-> [Maybe 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 Maybe Int -> JSM JStgStat
mkClosureCon (Maybe Int
forall a. Maybe a
Nothing Maybe Int -> [Maybe Int] -> [Maybe Int]
forall a. a -> [a] -> [a]
: (Int -> Maybe Int) -> [Int] -> [Maybe Int]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Maybe Int
forall a. a -> Maybe a
Just [Int
0..Int
jsClosureCount])
 fillers  <- mapM mkDataFill [1..jsClosureCount]
 return $ BlockStat $ closures ++ fillers

  where
    prof :: Bool
prof = StgToJSConfig -> Bool
csProf StgToJSConfig
s
    ([JStgExpr]
ccArg,Maybe JStgExpr
ccVal)
      -- the cc argument happens to be named just like the cc field...
      | Bool
prof      = ([Ident -> JStgExpr
Var (Ident -> JStgExpr) -> Ident -> JStgExpr
forall a b. (a -> b) -> a -> b
$ FastString -> Ident
global FastString
closureCC_], JStgExpr -> Maybe JStgExpr
forall a. a -> Maybe a
Just (FastString -> JStgExpr
var FastString
closureCC_))
      | Bool
otherwise = ([], Maybe JStgExpr
forall a. Maybe a
Nothing)

    addCCArg' :: [JStgExpr] -> [JStgExpr]
addCCArg' [JStgExpr]
as = [JStgExpr]
as [JStgExpr] -> [JStgExpr] -> [JStgExpr]
forall a. [a] -> [a] -> [a]
++ [JStgExpr]
ccArg

    traceAlloc :: JStgExpr -> JStgStat
traceAlloc JStgExpr
x | StgToJSConfig -> Bool
csTraceRts StgToJSConfig
s = FastString -> [JStgExpr] -> JStgStat
appS FastString
"h$traceAlloc" [JStgExpr
x]
                 | Bool
otherwise    = JStgStat
forall a. Monoid a => a
mempty

    notifyAlloc :: JStgExpr -> JStgStat
notifyAlloc JStgExpr
x | StgToJSConfig -> Bool
csDebugAlloc StgToJSConfig
s = FastString -> [JStgExpr] -> JStgStat
appS FastString
"h$debugAlloc_notifyAlloc" [JStgExpr
x]
                  | Bool
otherwise      = JStgStat
forall a. Monoid a => a
mempty

    -- only JSVal can typically contain undefined or null
    -- although it's possible (and legal) to make other Haskell types
    -- to contain JS refs directly
    -- this can cause false positives here
    checkC :: JSM JStgStat
    checkC :: JSM JStgStat
checkC | StgToJSConfig -> Bool
csAssertRts StgToJSConfig
s =
      (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
msg ->
        JStgExpr -> JStgStat -> JStgStat
jwhenS (FastString -> JStgExpr
var FastString
"arguments" JStgExpr -> JStgExpr -> JStgExpr
.! JStgExpr
0 JStgExpr -> JStgExpr -> JStgExpr
.!==. FastString -> JStgExpr
jString FastString
"h$ghczminternalZCGHCziInternalziJSziPrimziJSVal_con_e")
        (JStgStat -> JStgStat) -> JSM JStgStat -> JSM JStgStat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        (JStgExpr
-> (JStgExpr -> JStgExpr)
-> (JStgExpr -> JSM JStgStat)
-> JSM JStgStat
loop JStgExpr
1 (JStgExpr -> JStgExpr -> JStgExpr
.<. FastString -> JStgExpr
var FastString
"arguments" JStgExpr -> FastString -> JStgExpr
.^ FastString
"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
$
              [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat [JStgExpr
msg JStgExpr -> JStgExpr -> JStgStat
|= FastString -> JStgExpr
jString FastString
"warning: undefined or null in argument: "
                        JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
+ JStgExpr
i
                        JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
+ FastString -> JStgExpr
jString FastString
" allocating closure: " JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
+ (FastString -> JStgExpr
var FastString
"arguments" JStgExpr -> JStgExpr -> JStgExpr
.! JStgExpr
0 JStgExpr -> FastString -> JStgExpr
.^ FastString
"n")
                      , FastString -> [JStgExpr] -> JStgStat
appS FastString
"h$log" [JStgExpr
msg]
                      , JStgExpr -> JStgStat -> JStgStat
jwhenS (FastString -> JStgExpr
var FastString
"console" JStgExpr -> JStgExpr -> JStgExpr
.&&. (FastString -> JStgExpr
var FastString
"console" JStgExpr -> FastString -> JStgExpr
.^ FastString
"trace")) ((FastString -> JStgExpr
var FastString
"console" JStgExpr -> FastString -> JStgExpr
.^ FastString
"trace") JStgExpr -> [JStgExpr] -> JStgStat
`ApplStat` [JStgExpr
msg])
                      , JStgExpr -> JStgStat
postIncrS JStgExpr
i
                      ]))
           | Bool
otherwise = JStgStat -> JSM JStgStat
forall a. a -> StateT JEnv Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure JStgStat
forall a. Monoid a => a
mempty

    -- h$d is never used for JSVal (since it's only for constructors with
    -- at least three fields, so we always warn here
    checkD :: JSM JStgStat
checkD | StgToJSConfig -> Bool
csAssertRts StgToJSConfig
s =
                     JStgExpr
-> (JStgExpr -> JStgExpr)
-> (JStgExpr -> JSM JStgStat)
-> JSM JStgStat
loop JStgExpr
0 (JStgExpr -> JStgExpr -> JStgExpr
.<. FastString -> JStgExpr
var FastString
"arguments" JStgExpr -> FastString -> JStgExpr
.^ FastString
"length")
                     (\JStgExpr
i -> JStgExpr -> JStgStat -> JStgStat
jwhenS ((FastString -> JStgExpr
var FastString
"arguments" JStgExpr -> JStgExpr -> JStgExpr
.! JStgExpr
i JStgExpr -> JStgExpr -> JStgExpr
.===. JStgExpr
null_)
                                    JStgExpr -> JStgExpr -> JStgExpr
.||. (FastString -> JStgExpr
var FastString
"arguments" JStgExpr -> JStgExpr -> JStgExpr
.! JStgExpr
i JStgExpr -> JStgExpr -> JStgExpr
.===. JStgExpr
undefined_))
                            (JStgStat -> JStgStat) -> JSM JStgStat -> JSM JStgStat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                            ((JStgExpr -> JSM JStgStat) -> JSM JStgStat
forall t.
(JVarMagic t, ToJExpr t) =>
(t -> JSM JStgStat) -> JSM JStgStat
jVar \JStgExpr
msg->
                                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
msg JStgExpr -> JStgExpr -> JStgStat
|= FastString -> JStgExpr
jString FastString
"warning: undefined or null in argument: " JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
+ JStgExpr
i JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
+ FastString -> JStgExpr
jString FastString
" allocating fields"
                                        , JStgExpr -> JStgStat -> JStgStat
jwhenS (FastString -> JStgExpr
var FastString
"console" JStgExpr -> JStgExpr -> JStgExpr
.&&. (FastString -> JStgExpr
var FastString
"console" JStgExpr -> FastString -> JStgExpr
.^ FastString
"trace"))
                                                ((FastString -> JStgExpr
var FastString
"console" JStgExpr -> FastString -> JStgExpr
.^ FastString
"trace") JStgExpr -> [JStgExpr] -> JStgStat
`ApplStat` [JStgExpr
msg])
                                        ]))

           | Bool
otherwise = JStgStat -> JSM JStgStat
forall a. a -> StateT JEnv Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure JStgStat
forall a. Monoid a => a
mempty

    -- special case handler, the key difference is a call to @jFunction@ instead
    -- of @jFunctionSized@
    singleton_closure_con :: String -> JSM JStgStat
singleton_closure_con String
name = Ident -> (Solo JStgExpr -> JSM JStgStat) -> JSM JStgStat
forall args.
JSArgument args =>
Ident -> (args -> JSM JStgStat) -> JSM JStgStat
jFunction (FastString -> Ident
global (FastString -> Ident) -> FastString -> Ident
forall a b. (a -> b) -> a -> b
$ String -> FastString
mkFastString String
name) ((Solo JStgExpr -> JSM JStgStat) -> JSM JStgStat)
-> (Solo JStgExpr -> JSM JStgStat) -> JSM JStgStat
forall a b. (a -> b) -> a -> b
$
      \(MkSolo JStgExpr
f) -> do
        chk_c <- JSM JStgStat
checkC
        jVar $ \JStgExpr
x ->
          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
$
          [ JStgStat
chk_c
          , JStgExpr
x JStgExpr -> JStgExpr -> JStgStat
|= Closure -> JStgExpr
newClosure (JStgExpr -> [JStgExpr] -> JStgExpr -> Maybe JStgExpr -> Closure
mkClosure JStgExpr
f [JStgExpr]
forall a. Monoid a => a
mempty JStgExpr
0 Maybe JStgExpr
ccVal)
          , JStgExpr -> JStgStat
notifyAlloc JStgExpr
x
          , JStgExpr -> JStgStat
traceAlloc JStgExpr
x
          , JStgExpr -> JStgStat
returnS JStgExpr
x
          ]

    mkClosureCon :: Maybe Int -> JSM JStgStat
    -- the h$c special case
    mkClosureCon :: Maybe Int -> JSM JStgStat
mkClosureCon Maybe Int
Nothing  = String -> JSM JStgStat
singleton_closure_con String
"h$c"
    -- the h$c0 special case
    mkClosureCon (Just Int
0) = String -> JSM JStgStat
singleton_closure_con String
"h$c0"
    -- the rest h$c1 .. h$c24. Note that h$c1 takes 2 arguments, one for the
    -- entry function 'f' and another for the data field 'd1'. Thus the 1 in
    -- h$c1 means 1 data field argument, not just one argument
    mkClosureCon (Just Int
n) = Ident -> Int -> ([JStgExpr] -> JSM JStgStat) -> JSM JStgStat
jFunctionSized Ident
funName (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [JStgExpr] -> JSM JStgStat
funBod
      where
        funName :: Ident
funName = FastString -> Ident
global (FastString -> Ident) -> FastString -> Ident
forall a b. (a -> b) -> a -> b
$ Int -> FastString
clsName Int
n

        funBod :: [JStgExpr] -> JSM JStgStat
funBod [] = JStgStat -> JSM JStgStat
forall a. a -> StateT JEnv Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure JStgStat
forall a. Monoid a => a
mempty -- impossible
        funBod (JStgExpr
f:[JStgExpr]
vars') = do
          let vars :: [JStgExpr]
vars = [JStgExpr] -> [JStgExpr]
addCCArg' [JStgExpr]
vars'
          chk_c <- JSM JStgStat
checkC
          jVar $ \JStgExpr
x ->
            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
$
            [ JStgStat
chk_c
            , JStgExpr
x JStgExpr -> JStgExpr -> JStgStat
|= Closure -> JStgExpr
newClosure (JStgExpr -> [JStgExpr] -> JStgExpr -> Maybe JStgExpr -> Closure
mkClosure JStgExpr
f [JStgExpr]
vars JStgExpr
0 Maybe JStgExpr
ccVal)
            , JStgExpr -> JStgStat
notifyAlloc JStgExpr
x
            , JStgExpr -> JStgStat
traceAlloc JStgExpr
x
            , JStgExpr -> JStgStat
returnS JStgExpr
x
            ]

    mkDataFill :: Int -> JSM JStgStat
    mkDataFill :: Int -> JSM JStgStat
mkDataFill Int
n = Ident -> Int -> ([JStgExpr] -> JSM JStgStat) -> JSM JStgStat
jFunctionSized Ident
funName Int
n [JStgExpr] -> JSM JStgStat
body
      where
        funName :: Ident
funName    = FastString -> Ident
global (FastString -> Ident) -> FastString -> Ident
forall a b. (a -> b) -> a -> b
$ Int -> FastString
dataName Int
n
        ds :: [FastString]
ds         = (Int -> FastString) -> [Int] -> [FastString]
forall a b. (a -> b) -> [a] -> [b]
map Int -> FastString
dataFieldName [Int
1..Int
n]
        extra_args :: [JStgExpr] -> JStgExpr
extra_args [JStgExpr]
as = JVal -> JStgExpr
ValExpr (JVal -> JStgExpr)
-> ([(FastString, JStgExpr)] -> JVal)
-> [(FastString, JStgExpr)]
-> JStgExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UniqMap FastString JStgExpr -> JVal
JHash
                        (UniqMap FastString JStgExpr -> JVal)
-> ([(FastString, JStgExpr)] -> UniqMap FastString JStgExpr)
-> [(FastString, JStgExpr)]
-> JVal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(FastString, JStgExpr)] -> UniqMap FastString JStgExpr
forall k a. Uniquable k => [(k, a)] -> UniqMap k a
listToUniqMap
                        ([(FastString, JStgExpr)] -> JStgExpr)
-> [(FastString, JStgExpr)] -> JStgExpr
forall a b. (a -> b) -> a -> b
$ [FastString] -> [JStgExpr] -> [(FastString, JStgExpr)]
forall a b. [a] -> [b] -> [(a, b)]
zip [FastString]
ds [JStgExpr]
as
        body :: [JStgExpr] -> JSM JStgStat
        body :: [JStgExpr] -> JSM JStgStat
body [JStgExpr]
ids = do
          c <- JSM JStgStat
checkD
          return (c <> returnS (extra_args ids))

-- | JS Payload to perform stack manipulation in the RTS
stackManip :: JSM JStgStat
stackManip :: JSM JStgStat
stackManip = do
  pushes  <- (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 Int -> JSM JStgStat
mkPush [Int
1..Int
32]
  ppushes <- mapM mkPpush [1..255]
  return $ mconcat $ pushes ++ ppushes
  where
    mkPush :: Int -> JSM JStgStat
    mkPush :: Int -> JSM JStgStat
mkPush Int
n = let funName :: Ident
funName = FastString -> Ident
global (FastString -> Ident) -> FastString -> Ident
forall a b. (a -> b) -> a -> b
$ String -> FastString
mkFastString (String
"h$p" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n)
                   body :: [JStgExpr] -> JSM JStgStat
body [JStgExpr]
as = 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
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
n)
                       JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat ((Int -> JStgExpr -> JStgStat) -> [Int] -> [JStgExpr] -> [JStgStat]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Int
i JStgExpr
a -> 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
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
i)) JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
a)
                                            [Int
1..] [JStgExpr]
as))
               in Ident -> Int -> ([JStgExpr] -> JSM JStgStat) -> JSM JStgStat
jFunctionSized Ident
funName Int
n [JStgExpr] -> JSM JStgStat
body

    -- partial pushes, based on bitmap, increases Sp by highest bit
    mkPpush :: Integer -> JSM JStgStat
    mkPpush :: Integer -> JSM JStgStat
mkPpush Integer
sig | Integer
sig Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
Bits..&. (Integer
sigInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
1) Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0 = JStgStat -> JSM JStgStat
forall a. a -> StateT JEnv Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure JStgStat
forall a. Monoid a => a
mempty -- already handled by h$p
    mkPpush Integer
sig = let funName :: Ident
funName = FastString -> Ident
global (FastString -> Ident) -> FastString -> Ident
forall a b. (a -> b) -> a -> b
$ String -> FastString
mkFastString (String
"h$pp" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
sig)
                      bits :: [Int]
bits    = Integer -> [Int]
bitsIdx Integer
sig
                      h :: Int
h       = [Int] -> Int
forall a. HasCallStack => [a] -> a
last [Int]
bits
                      body :: [JStgExpr] -> JSM JStgStat
body [JStgExpr]
args = 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
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
hInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
                                , [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat ((Int -> JStgExpr -> JStgStat) -> [Int] -> [JStgExpr] -> [JStgStat]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Int
b JStgExpr
a -> 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
hInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
b)) JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
a) [Int]
bits [JStgExpr]
args)
                                ]
                   in Ident -> Int -> ([JStgExpr] -> JSM JStgStat) -> JSM JStgStat
jFunctionSized Ident
funName ([Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
bits) [JStgExpr] -> JSM JStgStat
body

bitsIdx :: Integer -> [Int]
bitsIdx :: Integer -> [Int]
bitsIdx Integer
n | Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0 = String -> [Int]
forall a. HasCallStack => String -> a
error String
"bitsIdx: negative"
          | Bool
otherwise = Integer -> Int -> [Int]
forall {t}. (Num t, Bits t) => t -> Int -> [Int]
go Integer
n Int
0
  where
    go :: t -> Int -> [Int]
go t
0 Int
_ = []
    go t
m Int
b | t -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
Bits.testBit t
m Int
b = Int
b Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: t -> Int -> [Int]
go (t -> Int -> t
forall a. Bits a => a -> Int -> a
Bits.clearBit t
m Int
b) (Int
bInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
           | Bool
otherwise   = t -> Int -> [Int]
go (t -> Int -> t
forall a. Bits a => a -> Int -> a
Bits.clearBit t
m Int
b) (Int
bInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)

bhLneStats :: StgToJSConfig -> JStgExpr -> JStgExpr -> JSM JStgStat
bhLneStats :: StgToJSConfig -> JStgExpr -> JStgExpr -> JSM JStgStat
bhLneStats StgToJSConfig
_s JStgExpr
p JStgExpr
frameSize = (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
v ->
  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
v JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
stack JStgExpr -> JStgExpr -> JStgExpr
.! JStgExpr
p
  , JStgExpr -> JStgStat -> JStgStat -> JStgStat
ifS JStgExpr
v
    ((JStgExpr
sp JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
sp JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
- JStgExpr
frameSize)
      JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> JStgExpr -> JStgStat -> JStgStat -> JStgStat
ifS (JStgExpr
v JStgExpr -> JStgExpr -> JStgExpr
.===. FastString -> JStgExpr
var FastString
"h$blackhole")
      (JStgExpr -> JStgStat
returnS (JStgExpr -> JStgStat) -> JStgExpr -> JStgStat
forall a b. (a -> b) -> a -> b
$ FastString -> [JStgExpr] -> JStgExpr
app FastString
"h$throw" [FastString -> JStgExpr
var FastString
"h$ghczminternalZCGHCziInternalziControlziExceptionziBasezinonTermination", JStgExpr
false_])
      ([JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat [JStgExpr
r1 JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
v
               , JStgExpr
sp JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
sp JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
- JStgExpr
frameSize
               , JStgStat
returnStack
               ]))
    ((JStgExpr
stack JStgExpr -> JStgExpr -> JStgExpr
.! JStgExpr
p JStgExpr -> JStgExpr -> JStgStat
|= FastString -> JStgExpr
var FastString
"h$blackhole") JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> JStgExpr -> JStgStat
returnS JStgExpr
null_)
  ]


-- | JS payload to declare the registers
declRegs :: JSM JStgStat
declRegs :: JSM JStgStat
declRegs = do
    getters_setters <- JSM JStgStat
regGettersSetters
    loaders         <- loadRegs
    return $
      mconcat [ global "h$regs" ||= toJExpr (JList [])
              , mconcat (map declReg (enumFromTo R1 R32))
              , getters_setters
              , loaders
              ]
    where
      declReg :: a -> JStgStat
declReg a
r = (Ident -> JStgStat
decl (Ident -> JStgStat) -> (a -> Ident) -> a -> JStgStat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FastString -> Ident
global (FastString -> Ident) -> (a -> FastString) -> a -> Ident
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> FastString
mkFastString (String -> FastString) -> (a -> String) -> a -> FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"h$"String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String) -> (a -> String) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (String -> String) -> (a -> String) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show) a
r
                  JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> [JStgStat] -> JStgStat
BlockStat [a -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr a
r JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
zero_]

-- | JS payload to define getters and setters on the registers.
regGettersSetters :: JSM JStgStat
regGettersSetters :: JSM JStgStat
regGettersSetters =
  do setters <- Ident -> (Solo JStgExpr -> JSM JStgStat) -> JSM JStgStat
forall args.
JSArgument args =>
Ident -> (args -> JSM JStgStat) -> JSM JStgStat
jFunction (FastString -> Ident
global FastString
"h$getReg") (\(MkSolo JStgExpr
n) -> 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 -> [(JStgExpr, JStgStat)] -> JStgStat -> JStgStat
SwitchStat JStgExpr
n [(JStgExpr, JStgStat)]
getRegCases JStgStat
forall a. Monoid a => a
mempty)
     getters <- jFunction (global "h$setReg") (\(JStgExpr
n,JStgExpr
v)    -> 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 -> [(JStgExpr, JStgStat)] -> JStgStat -> JStgStat
SwitchStat JStgExpr
n (JStgExpr -> [(JStgExpr, JStgStat)]
setRegCases JStgExpr
v) JStgStat
forall a. Monoid a => a
mempty)
     return $ setters <> getters
  where
    getRegCases :: [(JStgExpr, JStgStat)]
getRegCases =
      (StgReg -> (JStgExpr, JStgStat))
-> [StgReg] -> [(JStgExpr, JStgStat)]
forall a b. (a -> b) -> [a] -> [b]
map (\StgReg
r -> (Int -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr (StgReg -> Int
jsRegToInt StgReg
r) , JStgExpr -> JStgStat
returnS (StgReg -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr StgReg
r))) [StgReg]
regsFromR1
    setRegCases :: JStgExpr -> [(JStgExpr,JStgStat)]
    setRegCases :: JStgExpr -> [(JStgExpr, JStgStat)]
setRegCases JStgExpr
v =
      (StgReg -> (JStgExpr, JStgStat))
-> [StgReg] -> [(JStgExpr, JStgStat)]
forall a b. (a -> b) -> [a] -> [b]
map (\StgReg
r -> (Int -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr (StgReg -> Int
jsRegToInt StgReg
r), (StgReg -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr StgReg
r JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr JStgExpr
v) JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> JStgExpr -> JStgStat
returnS JStgExpr
undefined_)) [StgReg]
regsFromR1

-- | JS payload that defines the functions to load each register
loadRegs :: JSM JStgStat
loadRegs :: JSM JStgStat
loadRegs = [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 Int -> JSM JStgStat
mkLoad [Int
1..Int
32]
  where
    mkLoad :: Int -> JSM JStgStat
    mkLoad :: Int -> JSM JStgStat
mkLoad Int
n = let body :: [JStgExpr] -> JSM JStgStat
body  = \[JStgExpr]
args -> 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 -> StgReg -> JStgStat)
-> [JStgExpr] -> [StgReg] -> [JStgStat]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\JStgExpr
a StgReg
r -> StgReg -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr StgReg
r JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
a)
                           [JStgExpr]
args ([StgReg] -> [StgReg]
forall a. [a] -> [a]
reverse ([StgReg] -> [StgReg]) -> [StgReg] -> [StgReg]
forall a b. (a -> b) -> a -> b
$ Int -> [StgReg] -> [StgReg]
forall a. Int -> [a] -> [a]
take Int
n [StgReg]
regsFromR1)
                   fname :: Ident
fname = FastString -> Ident
global (FastString -> Ident) -> FastString -> Ident
forall a b. (a -> b) -> a -> b
$ String -> FastString
mkFastString (String
"h$l" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n)
               in Ident -> Int -> ([JStgExpr] -> JSM JStgStat) -> JSM JStgStat
jFunctionSized Ident
fname Int
n [JStgExpr] -> JSM JStgStat
body

-- | Assign registers R1 ... Rn in descending order, that is assign Rn first.
-- This function uses the 'assignRegs'' array to construct functions which set
-- the registers.
assignRegs :: StgToJSConfig -> [JStgExpr] -> JStgStat
assignRegs :: StgToJSConfig -> [JStgExpr] -> JStgStat
assignRegs StgToJSConfig
_ [] = JStgStat
forall a. Monoid a => a
mempty
assignRegs StgToJSConfig
s [JStgExpr]
xs
  | Int
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
32 Bool -> Bool -> Bool
&& Bool -> Bool
not (StgToJSConfig -> Bool
csInlineLoadRegs StgToJSConfig
s)
      = JStgExpr -> [JStgExpr] -> JStgStat
ApplStat (JVal -> JStgExpr
ValExpr (Ident -> JVal
JVar (Ident -> JVal) -> Ident -> JVal
forall a b. (a -> b) -> a -> b
$ Array Int Ident
assignRegs' Array Int Ident -> Int -> Ident
forall i e. Ix i => Array i e -> i -> e
! Int
l)) ([JStgExpr] -> [JStgExpr]
forall a. [a] -> [a]
reverse [JStgExpr]
xs)
  | Bool
otherwise = [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
ex -> StgReg -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr StgReg
r JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
ex) (Int -> [StgReg] -> [StgReg]
forall a. Int -> [a] -> [a]
take Int
l [StgReg]
regsFromR1) [JStgExpr]
xs
  where
    l :: Int
l = [JStgExpr] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [JStgExpr]
xs

-- | JS payload which defines an array of function symbols that set N registers
-- from M parameters. For example, h$l2 compiles to:
-- @
--    function h$l4(x1, x2, x3, x4) {
--      h$r4 = x1;
--      h$r3 = x2;
--      h$r2 = x3;
--      h$r1 = x4;
--    };
-- @
assignRegs' :: Array Int Ident
assignRegs' :: Array Int Ident
assignRegs' = (Int, Int) -> [Ident] -> Array Int Ident
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
1,Int
32) ((Int -> Ident) -> [Int] -> [Ident]
forall a b. (a -> b) -> [a] -> [b]
map (FastString -> Ident
global (FastString -> Ident) -> (Int -> FastString) -> Int -> Ident
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> FastString
mkFastString (String -> FastString) -> (Int -> String) -> Int -> FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"h$l"String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String) -> (Int -> String) -> Int -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show) [(Int
1::Int)..Int
32])

-- | JS payload to declare return variables.
declRets :: JStgStat
declRets :: JStgStat
declRets = [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat ([JStgStat] -> JStgStat) -> [JStgStat] -> JStgStat
forall a b. (a -> b) -> a -> b
$ (StgRet -> JStgStat) -> [StgRet] -> [JStgStat]
forall a b. (a -> b) -> [a] -> [b]
map (Ident -> JStgStat
decl (Ident -> JStgStat) -> (StgRet -> Ident) -> StgRet -> JStgStat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FastString -> Ident
global (FastString -> Ident) -> (StgRet -> FastString) -> StgRet -> Ident
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> FastString
mkFastString (String -> FastString)
-> (StgRet -> String) -> StgRet -> FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"h$"String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String) -> (StgRet -> String) -> StgRet -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (String -> String) -> (StgRet -> String) -> StgRet -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StgRet -> String
forall a. Show a => a -> String
show) (StgRet -> [StgRet]
forall a. Enum a => a -> [a]
enumFrom StgRet
Ret1)

-- | JS payload defining the types closures.
closureTypes :: JSM JStgStat
closureTypes :: JSM JStgStat
closureTypes = do
  cls_typ_nm <- JSM JStgStat
closureTypeName
  return $
    mconcat (map mkClosureType (enumFromTo minBound maxBound))
    <> cls_typ_nm
  where
    mkClosureType :: ClosureType -> JStgStat
    mkClosureType :: ClosureType -> JStgStat
mkClosureType ClosureType
c = let s :: Ident
s = FastString -> Ident
global (FastString -> Ident) -> (String -> FastString) -> String -> Ident
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> FastString
mkFastString (String -> Ident) -> String -> Ident
forall a b. (a -> b) -> a -> b
$ String
"h$" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper (ClosureType -> String
forall a. Show a => a -> String
show ClosureType
c) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_CLOSURE"
                      in  Ident
s Ident -> JStgExpr -> JStgStat
||= ClosureType -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr ClosureType
c
    closureTypeName :: JSM JStgStat
    closureTypeName :: JSM JStgStat
closureTypeName = Ident -> (Solo JStgExpr -> JSM JStgStat) -> JSM JStgStat
forall args.
JSArgument args =>
Ident -> (args -> JSM JStgStat) -> JSM JStgStat
jFunction (FastString -> Ident
global FastString
"h$closureTypeName")
                      \(MkSolo 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 ((ClosureType -> JStgStat) -> [ClosureType] -> [JStgStat]
forall a b. (a -> b) -> [a] -> [b]
map (JStgExpr -> ClosureType -> JStgStat
ifCT JStgExpr
c) [ClosureType
forall a. Bounded a => a
minBound..ClosureType
forall a. Bounded a => a
maxBound])
                              JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> JStgExpr -> JStgStat
returnS (FastString -> JStgExpr
jString FastString
"InvalidClosureType")

    ifCT :: JStgExpr -> ClosureType -> JStgStat
    ifCT :: JStgExpr -> ClosureType -> JStgStat
ifCT JStgExpr
arg ClosureType
ct = JStgExpr -> JStgStat -> JStgStat
jwhenS (JStgExpr
arg JStgExpr -> JStgExpr -> JStgExpr
.===. ClosureType -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr ClosureType
ct) (JStgExpr -> JStgStat
returnS (String -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr (ClosureType -> String
forall a. Show a => a -> String
show ClosureType
ct)))

-- | JS payload declaring the RTS functions.
rtsDecls :: JSM JStgStat
rtsDecls :: JSM JStgStat
rtsDecls = do
  decl_stg_regs <- JSM JStgStat
declRegs
  return $
    mconcat [ global "h$currentThread"   ||= null_                   -- thread state object for current thread
            , global "h$stack"           ||= null_                   -- stack for the current thread
            , global "h$sp"              ||= 0                       -- stack pointer for the current thread
            , global "h$initStatic"      ||= toJExpr (JList [])      -- we need delayed initialization for static objects, push functions here to be initialized just before haskell runs
            , global "h$staticThunks"    ||= toJExpr (jhFromList []) --  funcName -> heapidx map for srefs
            , global "h$staticThunksArr" ||= toJExpr (JList [])      -- indices of updatable thunks in static heap
            , global "h$CAFs"            ||= toJExpr (JList [])
            , global "h$CAFsReset"       ||= toJExpr (JList [])
            -- stg registers
            , decl_stg_regs
            , declRets]

-- | Generated RTS code
rts :: StgToJSConfig -> JSM JStgStat
rts :: StgToJSConfig -> JSM JStgStat
rts StgToJSConfig
cfg = FastString -> JSM JStgStat -> JSM JStgStat
forall a. FastString -> JSM a -> JSM a
withTag FastString
"h$RTS" (JSM JStgStat -> JSM JStgStat) -> JSM JStgStat -> JSM JStgStat
forall a b. (a -> b) -> a -> b
$
  do
  rts_      <- StgToJSConfig -> JSM JStgStat
rts_gen StgToJSConfig
cfg
  rts_decls <- rtsDecls
  return $  rts_decls <> rts_

-- | JS Payload which defines the embedded RTS.
rts_gen :: StgToJSConfig -> JSM JStgStat
rts_gen :: StgToJSConfig -> JSM JStgStat
rts_gen StgToJSConfig
s = do
  let decls :: [JStgStat]
decls = [ FastString -> Ident
global FastString
"h$rts_traceForeign" Ident -> JStgExpr -> JStgStat
||= Bool -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr (StgToJSConfig -> Bool
csTraceForeign StgToJSConfig
s)
              , FastString -> Ident
global FastString
"h$rts_profiling"    Ident -> JStgExpr -> JStgStat
||= Bool -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr (StgToJSConfig -> Bool
csProf StgToJSConfig
s)
              , FastString -> Ident
global FastString
"h$ct_fun"        Ident -> JStgExpr -> JStgStat
||= ClosureType -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr ClosureType
Fun
              , FastString -> Ident
global FastString
"h$ct_con"        Ident -> JStgExpr -> JStgStat
||= ClosureType -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr ClosureType
Con
              , FastString -> Ident
global FastString
"h$ct_thunk"      Ident -> JStgExpr -> JStgStat
||= ClosureType -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr ClosureType
Thunk
              , FastString -> Ident
global FastString
"h$ct_pap"        Ident -> JStgExpr -> JStgStat
||= ClosureType -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr ClosureType
Pap
              , FastString -> Ident
global FastString
"h$ct_blackhole"  Ident -> JStgExpr -> JStgStat
||= ClosureType -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr ClosureType
Blackhole
              , FastString -> Ident
global FastString
"h$ct_stackframe" Ident -> JStgExpr -> JStgStat
||= ClosureType -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr ClosureType
StackFrame
              , FastString -> Ident
global FastString
"h$vt_ptr"    Ident -> JStgExpr -> JStgStat
||= JSRep -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr JSRep
PtrV
              , FastString -> Ident
global FastString
"h$vt_void"   Ident -> JStgExpr -> JStgStat
||= JSRep -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr JSRep
VoidV
              , FastString -> Ident
global FastString
"h$vt_double" Ident -> JStgExpr -> JStgStat
||= JSRep -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr JSRep
IntV
              , FastString -> Ident
global FastString
"h$vt_long"   Ident -> JStgExpr -> JStgStat
||= JSRep -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr JSRep
LongV
              , FastString -> Ident
global FastString
"h$vt_addr"   Ident -> JStgExpr -> JStgStat
||= JSRep -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr JSRep
AddrV
              , FastString -> Ident
global FastString
"h$vt_obj"    Ident -> JStgExpr -> JStgStat
||= JSRep -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr JSRep
ObjV
              , FastString -> Ident
global FastString
"h$vt_arr"    Ident -> JStgExpr -> JStgStat
||= JSRep -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr JSRep
ArrV
              ]
  gc           <- JSM JStgStat
garbageCollector
  closure_cons <- closureConstructors s
  stk_manip    <- stackManip
  rest         <- impure
  return $ mconcat $ pure gc <> decls <> [closure_cons, stk_manip] <> rest
  where
    impure :: StateT JEnv Identity [JStgStat]
impure = [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 -> JSM JStgStat -> JSM JStgStat
jFunction' (FastString -> Ident
global FastString
"h$bh")     (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 -> Bool -> JStgStat
bhStats StgToJSConfig
s Bool
True)
             , Ident -> ((JStgExpr, JStgExpr) -> JSM JStgStat) -> JSM JStgStat
forall args.
JSArgument args =>
Ident -> (args -> JSM JStgStat) -> JSM JStgStat
jFunction (FastString -> Ident
global FastString
"h$bh_lne") (\(JStgExpr
x, JStgExpr
frameSize) -> StgToJSConfig -> JStgExpr -> JStgExpr -> JSM JStgStat
bhLneStats StgToJSConfig
s JStgExpr
x JStgExpr
frameSize)
             , ClosureInfo -> JSM JStgStat -> JSM JStgStat
closure (Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo (FastString -> Ident
global FastString
"h$blackhole") (Int -> [JSRep] -> CIRegs
CIRegs Int
0 []) FastString
"blackhole" (Int -> CILayout
CILayoutUnknown Int
2) CIType
CIBlackhole CIStatic
forall a. Monoid a => a
mempty)
               (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
"throw" [FastString -> JStgExpr
jString FastString
"oops: entered black hole"])
             , ClosureInfo -> JSM JStgStat -> JSM JStgStat
closure (Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo (FastString -> Ident
global FastString
"h$blackholeTrap") (Int -> [JSRep] -> CIRegs
CIRegs Int
0 []) FastString
"blackhole" (Int -> CILayout
CILayoutUnknown Int
2) CIType
CIThunk CIStatic
forall a. Monoid a => a
mempty)
               (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
"throw" [FastString -> JStgExpr
jString FastString
"oops: entered multiple times"])
             , ClosureInfo -> JSM JStgStat -> JSM JStgStat
closure (Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo (FastString -> Ident
global FastString
"h$done") (Int -> [JSRep] -> CIRegs
CIRegs Int
0 [JSRep
PtrV]) FastString
"done" (Int -> CILayout
CILayoutUnknown Int
0) CIType
CIStackFrame CIStatic
forall a. Monoid a => a
mempty)
               (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
"h$finishThread" [FastString -> JStgExpr
var FastString
"h$currentThread"] JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> JStgExpr -> JStgStat
returnS (FastString -> JStgExpr
var FastString
"h$reschedule"))
             , ClosureInfo -> JSM JStgStat -> JSM JStgStat
closure (Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo (FastString -> Ident
global FastString
"h$doneMain_e") (Int -> [JSRep] -> CIRegs
CIRegs Int
0 [JSRep
PtrV]) FastString
"doneMain" (Int -> CILayout
CILayoutUnknown Int
0) CIType
CIStackFrame CIStatic
forall a. Monoid a => a
mempty)
               (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 -> JStgStat
returnS (FastString -> JStgExpr
var FastString
"h$doneMain"))
             , Ident -> FastString -> CILayout -> Int -> JSM JStgStat
conClosure (FastString -> Ident
global FastString
"h$false_e") FastString
"GHC.Types.False" (Int -> [JSRep] -> CILayout
CILayoutFixed Int
0 []) Int
1
             , Ident -> FastString -> CILayout -> Int -> JSM JStgStat
conClosure (FastString -> Ident
global FastString
"h$true_e" ) FastString
"GHC.Types.True"  (Int -> [JSRep] -> CILayout
CILayoutFixed Int
0 []) Int
2
             -- generic data constructor with 1 non-heapobj field
             , Ident -> FastString -> CILayout -> Int -> JSM JStgStat
conClosure (FastString -> Ident
global FastString
"h$data1_e") FastString
"data1" (Int -> [JSRep] -> CILayout
CILayoutFixed Int
1 [JSRep
ObjV]) Int
1
             -- generic data constructor with 2 non-heapobj fields
             , Ident -> FastString -> CILayout -> Int -> JSM JStgStat
conClosure (FastString -> Ident
global FastString
"h$data2_e") FastString
"data2" (Int -> [JSRep] -> CILayout
CILayoutFixed Int
2 [JSRep
ObjV,JSRep
ObjV]) Int
1
             , ClosureInfo -> JSM JStgStat -> JSM JStgStat
closure (Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo (FastString -> Ident
global FastString
"h$noop_e") (Int -> [JSRep] -> CIRegs
CIRegs Int
1 [JSRep
PtrV]) FastString
"no-op IO ()" (Int -> [JSRep] -> CILayout
CILayoutFixed Int
0 []) (Int -> Int -> CIType
CIFun Int
1 Int
0) 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 (JStgExpr -> JStgStat
returnS (JStgExpr
stack JStgExpr -> JStgExpr -> JStgExpr
.! JStgExpr
sp))
             , JStgStat -> JSM JStgStat
forall a. a -> StateT JEnv Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FastString -> Ident
global FastString
"h$noop" Ident -> JStgExpr -> JStgStat
||= JStgExpr -> [JStgExpr] -> JStgExpr
ApplExpr (FastString -> JStgExpr
var FastString
"h$c0") (FastString -> JStgExpr
var FastString
"h$noop_e" JStgExpr -> [JStgExpr] -> [JStgExpr]
forall a. a -> [a] -> [a]
: [JStgExpr
jSystemCCS | StgToJSConfig -> Bool
csProf StgToJSConfig
s]))
             , ClosureInfo -> JSM JStgStat -> JSM JStgStat
closure (Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo (FastString -> Ident
global FastString
"h$catch_e") (Int -> [JSRep] -> CIRegs
CIRegs Int
0 [JSRep
PtrV]) FastString
"exception handler" (Int -> [JSRep] -> CILayout
CILayoutFixed Int
2 [JSRep
PtrV,JSRep
IntV]) CIType
CIStackFrame CIStatic
forall a. Monoid a => a
mempty)
                  (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
$ Int -> JStgStat
adjSpN' Int
3 JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> JStgExpr -> JStgStat
returnS (JStgExpr
stack JStgExpr -> JStgExpr -> JStgExpr
.! JStgExpr
sp))
             , ClosureInfo -> JSM JStgStat -> JSM JStgStat
closure (Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo (FastString -> Ident
global FastString
"h$dataToTag_e") (Int -> [JSRep] -> CIRegs
CIRegs Int
0 [JSRep
PtrV]) FastString
"data to tag" (Int -> [JSRep] -> CILayout
CILayoutFixed Int
0 []) CIType
CIStackFrame 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 [ JStgExpr
r1 JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr -> JStgExpr -> JStgExpr -> JStgExpr
if_ (JStgExpr
r1 JStgExpr -> JStgExpr -> JStgExpr
.===. JStgExpr
true_) JStgExpr
1 (JStgExpr -> JStgExpr -> JStgExpr -> JStgExpr
if_ (JStgExpr -> JStgExpr
typeof JStgExpr
r1 JStgExpr -> JStgExpr -> JStgExpr
.===. JStgExpr
jTyObject) (JStgExpr
r1 JStgExpr -> FastString -> JStgExpr
.^ FastString
"f" JStgExpr -> FastString -> JStgExpr
.^ FastString
"a" JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
- JStgExpr
1) JStgExpr
0)
                                      , Int -> JStgStat
adjSpN' Int
1
                                      , JStgExpr -> JStgStat
returnS (JStgExpr
stack JStgExpr -> JStgExpr -> JStgExpr
.! JStgExpr
sp)
                                      ]
             -- function application to one argument
             , ClosureInfo -> JSM JStgStat -> JSM JStgStat
closure (Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo (FastString -> Ident
global FastString
"h$ap1_e") (Int -> [JSRep] -> CIRegs
CIRegs Int
0 [JSRep
PtrV]) FastString
"apply1" (Int -> [JSRep] -> CILayout
CILayoutFixed Int
2 [JSRep
PtrV, JSRep
PtrV]) CIType
CIThunk CIStatic
forall a. Monoid a => a
mempty)
                  (((JStgExpr, JStgExpr) -> JSM JStgStat) -> JSM JStgStat
forall args.
JSArgument args =>
(args -> JSM JStgStat) -> JSM JStgStat
jVars \(JStgExpr
d1, JStgExpr
d2) -> 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
d1 JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr -> JStgExpr
closureField1 JStgExpr
r1
                                        , JStgExpr
d2 JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr -> JStgExpr
closureField2 JStgExpr
r1
                                        , FastString -> [JStgExpr] -> JStgStat
appS FastString
"h$bh" []
                                        , StgToJSConfig -> JStgStat -> JStgStat
profStat StgToJSConfig
s JStgStat
enterCostCentreThunk
                                        , JStgExpr
r1 JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
d1
                                        , JStgExpr
r2 JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
d2
                                        , JStgExpr -> JStgStat
returnS (FastString -> [JStgExpr] -> JStgExpr
app FastString
"h$ap_1_1_fast" [])
                                        ])
             -- function application to two arguments
             , ClosureInfo -> JSM JStgStat -> JSM JStgStat
closure (Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo (FastString -> Ident
global FastString
"h$ap2_e") (Int -> [JSRep] -> CIRegs
CIRegs Int
0 [JSRep
PtrV]) FastString
"apply2" (Int -> [JSRep] -> CILayout
CILayoutFixed Int
3 [JSRep
PtrV, JSRep
PtrV, JSRep
PtrV]) CIType
CIThunk CIStatic
forall a. Monoid a => a
mempty)
                  (((JStgExpr, JStgExpr, JStgExpr) -> JSM JStgStat) -> JSM JStgStat
forall args.
JSArgument args =>
(args -> JSM JStgStat) -> JSM JStgStat
jVars \(JStgExpr
d1, JStgExpr
d2, JStgExpr
d3) -> 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
d1 JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr -> JStgExpr
closureField1 JStgExpr
r1
                                            , JStgExpr
d2 JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr -> JStgExpr
closureField2 JStgExpr
r1 JStgExpr -> FastString -> JStgExpr
.^ FastString
"d1"
                                            , JStgExpr
d3 JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr -> JStgExpr
closureField2 JStgExpr
r1 JStgExpr -> FastString -> JStgExpr
.^ FastString
"d2"
                                            , FastString -> [JStgExpr] -> JStgStat
appS FastString
"h$bh" []
                                            , StgToJSConfig -> JStgStat -> JStgStat
profStat StgToJSConfig
s JStgStat
enterCostCentreThunk
                                            , JStgExpr
r1 JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
d1
                                            , JStgExpr
r2 JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
d2
                                            , JStgExpr
r3 JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
d3
                                            , JStgExpr -> JStgStat
returnS (FastString -> [JStgExpr] -> JStgExpr
app FastString
"h$ap_2_2_fast" [])
                                            ])
             -- function application to three arguments
             , ClosureInfo -> JSM JStgStat -> JSM JStgStat
closure (Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo (FastString -> Ident
global FastString
"h$ap3_e") (Int -> [JSRep] -> CIRegs
CIRegs Int
0 [JSRep
PtrV]) FastString
"apply3" (Int -> [JSRep] -> CILayout
CILayoutFixed Int
4 [JSRep
PtrV, JSRep
PtrV, JSRep
PtrV, JSRep
PtrV]) CIType
CIThunk CIStatic
forall a. Monoid a => a
mempty)
                  (((JStgExpr, JStgExpr, JStgExpr, JStgExpr) -> JSM JStgStat)
-> JSM JStgStat
forall args.
JSArgument args =>
(args -> JSM JStgStat) -> JSM JStgStat
jVars \(JStgExpr
d1, JStgExpr
d2, JStgExpr
d3, JStgExpr
d4) -> 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
d1 JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr -> JStgExpr
closureField1 JStgExpr
r1
                                                , JStgExpr
d2 JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr -> JStgExpr
closureField2 JStgExpr
r1 JStgExpr -> FastString -> JStgExpr
.^ FastString
"d1"
                                                , JStgExpr
d3 JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr -> JStgExpr
closureField2 JStgExpr
r1 JStgExpr -> FastString -> JStgExpr
.^ FastString
"d2"
                                                , JStgExpr
d4 JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr -> JStgExpr
closureField2 JStgExpr
r1 JStgExpr -> FastString -> JStgExpr
.^ FastString
"d3"
                                                , FastString -> [JStgExpr] -> JStgStat
appS FastString
"h$bh" []
                                                , JStgExpr
r1 JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
d1
                                                , JStgExpr
r2 JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
d2
                                                , JStgExpr
r3 JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
d3
                                                , JStgExpr
r4 JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
d4
                                                , JStgExpr -> JStgStat
returnS (FastString -> [JStgExpr] -> JStgExpr
app FastString
"h$ap_3_3_fast" [])
                                                ])
             , ClosureInfo -> JSM JStgStat -> JSM JStgStat
closure (Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo (FastString -> Ident
TxtI FastString
"h$upd_thunk_e") (Int -> [JSRep] -> CIRegs
CIRegs Int
0 [JSRep
PtrV]) FastString
"updatable thunk" (Int -> [JSRep] -> CILayout
CILayoutFixed Int
1 [JSRep
PtrV]) CIType
CIThunk 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
t -> 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
t JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr -> JStgExpr
closureField1 JStgExpr
r1
                           , Int -> JStgStat
adjSp' Int
2
                           , JStgExpr
stack JStgExpr -> JStgExpr -> JStgExpr
.! (JStgExpr
sp JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
- JStgExpr
1) JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
r1
                           , JStgExpr
stack JStgExpr -> JStgExpr -> JStgExpr
.! JStgExpr
sp       JStgExpr -> JStgExpr -> JStgStat
|= FastString -> JStgExpr
var FastString
"h$upd_frame"
                           , JStgExpr -> JStgExpr
closureEntry  JStgExpr
r1 JStgExpr -> JStgExpr -> JStgStat
|= FastString -> JStgExpr
var FastString
"h$blackhole"
                           , JStgExpr -> JStgExpr
closureField1 JStgExpr
r1 JStgExpr -> JStgExpr -> JStgStat
|= FastString -> JStgExpr
var FastString
"h$currentThread"
                           , JStgExpr -> JStgExpr
closureField2 JStgExpr
r1 JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
null_
                           , JStgExpr
r1 JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
t
                           , JStgExpr -> JStgStat
returnS (FastString -> [JStgExpr] -> JStgExpr
app FastString
"h$ap_0_0_fast" [])
                           ]
                  )
             -- select first field
             , ClosureInfo -> JSM JStgStat -> JSM JStgStat
closure (Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo (FastString -> Ident
global FastString
"h$select1_e") (Int -> [JSRep] -> CIRegs
CIRegs Int
0 [JSRep
PtrV]) FastString
"select1" (Int -> [JSRep] -> CILayout
CILayoutFixed Int
1 [JSRep
PtrV]) CIType
CIThunk 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
t -> 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
t JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr -> JStgExpr
closureField1 JStgExpr
r1
                                   , Int -> JStgStat
adjSp' Int
3
                                   , JStgExpr
stack JStgExpr -> JStgExpr -> JStgExpr
.! (JStgExpr
sp JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
- JStgExpr
2) JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
r1
                                   , JStgExpr
stack JStgExpr -> JStgExpr -> JStgExpr
.! (JStgExpr
sp JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
- JStgExpr
1) JStgExpr -> JStgExpr -> JStgStat
|= FastString -> JStgExpr
var FastString
"h$upd_frame"
                                   , JStgExpr
stack JStgExpr -> JStgExpr -> JStgExpr
.! JStgExpr
sp JStgExpr -> JStgExpr -> JStgStat
|= FastString -> JStgExpr
var FastString
"h$select1_ret"
                                   , JStgExpr -> JStgExpr
closureEntry  JStgExpr
r1 JStgExpr -> JStgExpr -> JStgStat
|= FastString -> JStgExpr
var FastString
"h$blackhole"
                                   , JStgExpr -> JStgExpr
closureField1 JStgExpr
r1 JStgExpr -> JStgExpr -> JStgStat
|= FastString -> JStgExpr
var FastString
"h$currentThread"
                                   , JStgExpr -> JStgExpr
closureField2 JStgExpr
r1 JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
null_
                                   , JStgExpr
r1 JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
t
                                   , JStgExpr -> JStgStat
returnS (FastString -> [JStgExpr] -> JStgExpr
app FastString
"h$ap_0_0_fast" [])
                                   ])
             , ClosureInfo -> JSM JStgStat -> JSM JStgStat
closure (Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo (FastString -> Ident
global FastString
"h$select1_ret") (Int -> [JSRep] -> CIRegs
CIRegs Int
0 [JSRep
PtrV]) FastString
"select1ret" (Int -> [JSRep] -> CILayout
CILayoutFixed Int
0 []) CIType
CIStackFrame CIStatic
forall a. Monoid a => a
mempty)
                  (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
r1 JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr -> JStgExpr
closureField1 JStgExpr
r1)
                    JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> Int -> JStgStat
adjSpN' Int
1
                    JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> JStgExpr -> JStgStat
returnS (FastString -> [JStgExpr] -> JStgExpr
app FastString
"h$ap_0_0_fast" [])
                  )
             -- select second field of a two-field constructor
             , ClosureInfo -> JSM JStgStat -> JSM JStgStat
closure (Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo (FastString -> Ident
global FastString
"h$select2_e") (Int -> [JSRep] -> CIRegs
CIRegs Int
0 [JSRep
PtrV]) FastString
"select2" (Int -> [JSRep] -> CILayout
CILayoutFixed Int
1 [JSRep
PtrV]) CIType
CIThunk 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
t -> 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
t JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr -> JStgExpr
closureField1 JStgExpr
r1
                                   , Int -> JStgStat
adjSp' Int
3
                                   , JStgExpr
stack JStgExpr -> JStgExpr -> JStgExpr
.! (JStgExpr
sp JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
- JStgExpr
2) JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
r1
                                   , JStgExpr
stack JStgExpr -> JStgExpr -> JStgExpr
.! (JStgExpr
sp JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
- JStgExpr
1) JStgExpr -> JStgExpr -> JStgStat
|= FastString -> JStgExpr
var FastString
"h$upd_frame"
                                   , JStgExpr
stack JStgExpr -> JStgExpr -> JStgExpr
.! JStgExpr
sp JStgExpr -> JStgExpr -> JStgStat
|= FastString -> JStgExpr
var FastString
"h$select2_ret"
                                   , JStgExpr -> JStgExpr
closureEntry  JStgExpr
r1 JStgExpr -> JStgExpr -> JStgStat
|= FastString -> JStgExpr
var FastString
"h$blackhole"
                                   , JStgExpr -> JStgExpr
closureField1 JStgExpr
r1 JStgExpr -> JStgExpr -> JStgStat
|= FastString -> JStgExpr
var FastString
"h$currentThread"
                                   , JStgExpr -> JStgExpr
closureField2 JStgExpr
r1 JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
null_
                                   , JStgExpr
r1 JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
t
                                   , JStgExpr -> JStgStat
returnS (FastString -> [JStgExpr] -> JStgExpr
app FastString
"h$ap_0_0_fast" [])
                                   ]
                  )
             , ClosureInfo -> JSM JStgStat -> JSM JStgStat
closure (Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo (FastString -> Ident
global FastString
"h$select2_ret") (Int -> [JSRep] -> CIRegs
CIRegs Int
0 [JSRep
PtrV]) FastString
"select2ret" (Int -> [JSRep] -> CILayout
CILayoutFixed Int
0 []) CIType
CIStackFrame 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 [ JStgExpr
r1 JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr -> JStgExpr
closureField2 JStgExpr
r1
                                              , Int -> JStgStat
adjSpN' Int
1
                                              , JStgExpr -> JStgStat
returnS (FastString -> [JStgExpr] -> JStgExpr
app FastString
"h$ap_0_0_fast" [])
                                              ]
             , ClosureInfo -> JSM JStgStat -> JSM JStgStat
closure (Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo (FastString -> Ident
global FastString
"h$keepAlive_e") (Int -> [JSRep] -> CIRegs
CIRegs Int
0 [JSRep
PtrV]) FastString
"keepAlive" (Int -> [JSRep] -> CILayout
CILayoutFixed Int
1 [JSRep
PtrV]) CIType
CIStackFrame CIStatic
forall a. Monoid a => a
mempty)
                       (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 [ Int -> JStgStat
adjSpN' Int
2
                                         , JStgExpr -> JStgStat
returnS (JStgExpr
stack JStgExpr -> JStgExpr -> JStgExpr
.! JStgExpr
sp)
                                         ]
                       )
             -- a thunk that just raises a synchronous exception
             , ClosureInfo -> JSM JStgStat -> JSM JStgStat
closure (Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo (FastString -> Ident
global FastString
"h$raise_e") (Int -> [JSRep] -> CIRegs
CIRegs Int
0 [JSRep
PtrV]) FastString
"h$raise_e" (Int -> [JSRep] -> CILayout
CILayoutFixed Int
0 []) CIType
CIThunk CIStatic
forall a. Monoid a => a
mempty)
                  (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 -> JStgStat
returnS (FastString -> [JStgExpr] -> JStgExpr
app FastString
"h$throw" [JStgExpr -> JStgExpr
closureField1 JStgExpr
r1, JStgExpr
false_]))
             , ClosureInfo -> JSM JStgStat -> JSM JStgStat
closure (Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo (FastString -> Ident
global FastString
"h$raiseAsync_e") (Int -> [JSRep] -> CIRegs
CIRegs Int
0 [JSRep
PtrV]) FastString
"h$raiseAsync_e" (Int -> [JSRep] -> CILayout
CILayoutFixed Int
0 []) CIType
CIThunk CIStatic
forall a. Monoid a => a
mempty)
                  (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 -> JStgStat
returnS  (FastString -> [JStgExpr] -> JStgExpr
app FastString
"h$throw" [JStgExpr -> JStgExpr
closureField1 JStgExpr
r1, JStgExpr
true_]))
             , ClosureInfo -> JSM JStgStat -> JSM JStgStat
closure (Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo (FastString -> Ident
global FastString
"h$raiseAsync_frame") (Int -> [JSRep] -> CIRegs
CIRegs Int
0 []) FastString
"h$raiseAsync_frame" (Int -> [JSRep] -> CILayout
CILayoutFixed Int
1 []) CIType
CIStackFrame 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
ex -> 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
ex JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
stack JStgExpr -> JStgExpr -> JStgExpr
.! (JStgExpr
sp JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
- JStgExpr
1)
                                                , Int -> JStgStat
adjSpN' Int
2
                                                , JStgExpr -> JStgStat
returnS (FastString -> [JStgExpr] -> JStgExpr
app FastString
"h$throw" [JStgExpr
ex, JStgExpr
true_])
                                                ])
             {- reduce result if it's a thunk, follow if it's an ind
                add this to the stack if you want the outermost result
                to always be reduced to whnf, and not an ind
             -}
             , ClosureInfo -> JSM JStgStat -> JSM JStgStat
closure (Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo (FastString -> Ident
global FastString
"h$reduce") (Int -> [JSRep] -> CIRegs
CIRegs Int
0 [JSRep
PtrV]) FastString
"h$reduce" (Int -> [JSRep] -> CILayout
CILayoutFixed Int
0 []) CIType
CIStackFrame CIStatic
forall a. Monoid a => a
mempty)
                  (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 -> JStgStat -> JStgStat -> JStgStat
ifS (JStgExpr -> JStgExpr
isThunk JStgExpr
r1)
                       (JStgExpr -> JStgStat
returnS (JStgExpr
r1 JStgExpr -> FastString -> JStgExpr
.^ FastString
"f"))
                       (Int -> JStgStat
adjSpN' Int
1 JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> JStgExpr -> JStgStat
returnS (JStgExpr
stack JStgExpr -> JStgExpr -> JStgExpr
.! JStgExpr
sp))
                  )
             , StgToJSConfig -> JSM JStgStat
rtsApply StgToJSConfig
s
             , JSM JStgStat
closureTypes
             , ClosureInfo -> JSM JStgStat -> JSM JStgStat
closure (Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo (FastString -> Ident
global FastString
"h$runio_e") (Int -> [JSRep] -> CIRegs
CIRegs Int
0 [JSRep
PtrV]) FastString
"runio" (Int -> [JSRep] -> CILayout
CILayoutFixed Int
1 [JSRep
PtrV]) CIType
CIThunk 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 [ JStgExpr
r1 JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr -> JStgExpr
closureField1 JStgExpr
r1
                                              , JStgExpr
stack JStgExpr -> JStgExpr -> JStgExpr
.! JStgExpr -> JStgExpr
PreInc JStgExpr
sp JStgExpr -> JStgExpr -> JStgStat
|= FastString -> JStgExpr
var FastString
"h$ap_1_0"
                                              , JStgExpr -> JStgStat
returnS (FastString -> JStgExpr
var FastString
"h$ap_1_0")
                                              ]
             , ClosureInfo -> JSM JStgStat -> JSM JStgStat
closure (Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo (FastString -> Ident
global FastString
"h$flushStdout_e") (Int -> [JSRep] -> CIRegs
CIRegs Int
0 []) FastString
"flushStdout" (Int -> [JSRep] -> CILayout
CILayoutFixed Int
0 []) CIType
CIThunk 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 [ JStgExpr
r1 JStgExpr -> JStgExpr -> JStgStat
|= FastString -> JStgExpr
var FastString
"h$ghczminternalZCGHCziInternalziIOziHandlezihFlush"
                                  , JStgExpr
r2 JStgExpr -> JStgExpr -> JStgStat
|= FastString -> JStgExpr
var FastString
"h$ghczminternalZCGHCziInternalziIOziHandleziFDzistdout"
                                  , JStgExpr -> JStgStat
returnS (FastString -> [JStgExpr] -> JStgExpr
app FastString
"h$ap_1_1_fast" [])
                                  ]
             , JStgStat -> JSM JStgStat
forall a. a -> StateT JEnv Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JStgStat -> JSM JStgStat) -> JStgStat -> JSM JStgStat
forall a b. (a -> b) -> a -> b
$ FastString -> Ident
global FastString
"h$flushStdout" Ident -> JStgExpr -> JStgStat
||= FastString -> [JStgExpr] -> JStgExpr
app FastString
"h$static_thunk" [FastString -> JStgExpr
var FastString
"h$flushStdout_e"]
             -- the scheduler pushes this frame when suspending a thread that
             -- has not called h$reschedule explicitly
             , ClosureInfo -> JSM JStgStat -> JSM JStgStat
closure (Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo (FastString -> Ident
global FastString
"h$restoreThread") (Int -> [JSRep] -> CIRegs
CIRegs Int
0 []) FastString
"restoreThread" CILayout
CILayoutVariable CIType
CIStackFrame CIStatic
forall a. Monoid a => a
mempty)
               (((JStgExpr, JStgExpr, JStgExpr) -> JSM JStgStat) -> JSM JStgStat
forall args.
JSArgument args =>
(args -> JSM JStgStat) -> JSM JStgStat
jVars \(JStgExpr
f,JStgExpr
frameSize,JStgExpr
nregs) ->
                      do set_regs <- JStgExpr
-> (JStgExpr -> JStgExpr)
-> (JStgExpr -> JSM JStgStat)
-> JSM JStgStat
loop JStgExpr
1 (JStgExpr -> JStgExpr -> JStgExpr
.<=. JStgExpr
nregs)
                                     (\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
"h$setReg" [JStgExpr
i, JStgExpr
stack JStgExpr -> JStgExpr -> JStgExpr
.! (JStgExpr
sp JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
- JStgExpr
2 JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
- JStgExpr
i)] JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> JStgExpr -> JStgStat
postIncrS JStgExpr
i)
                         return $ mconcat [f |= stack .! (sp - 2)
                                          , frameSize |= stack .! (sp - 1)
                                          , nregs |= frameSize - 3
                                          , set_regs
                                          , sp |= sp - frameSize
                                          , returnS f
                                          ])
             -- return a closure in the stack frame to the next thing on the stack
             , ClosureInfo -> JSM JStgStat -> JSM JStgStat
closure (Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo (FastString -> Ident
global FastString
"h$return") (Int -> [JSRep] -> CIRegs
CIRegs Int
0 []) FastString
"return" (Int -> [JSRep] -> CILayout
CILayoutFixed Int
1 [JSRep
PtrV]) CIType
CIStackFrame CIStatic
forall a. Monoid a => a
mempty)
                   (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
r1 JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
stack JStgExpr -> JStgExpr -> JStgExpr
.! (JStgExpr
sp JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
- JStgExpr
1))
                     JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> Int -> JStgStat
adjSpN' Int
2
                     JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> JStgExpr -> JStgStat
returnS (JStgExpr
stack JStgExpr -> JStgExpr -> JStgExpr
.! JStgExpr
sp))
             --  return a function in the stack frame for the next call
             , ClosureInfo -> JSM JStgStat -> JSM JStgStat
closure (Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo (FastString -> Ident
global FastString
"h$returnf") (Int -> [JSRep] -> CIRegs
CIRegs Int
0 [JSRep
PtrV]) FastString
"returnf" (Int -> [JSRep] -> CILayout
CILayoutFixed Int
1 [JSRep
ObjV]) CIType
CIStackFrame 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
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
r JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
stack JStgExpr -> JStgExpr -> JStgExpr
.! (JStgExpr
sp JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
- JStgExpr
1)
                                       , Int -> JStgStat
adjSpN' Int
2
                                       , JStgExpr -> JStgStat
returnS JStgExpr
r
                                       ])
             -- return this function when the scheduler needs to come into action
             -- (yield, delay etc), returning thread needs to push all relevant
             -- registers to stack frame, thread will be resumed by calling the stack top
             , ClosureInfo -> JSM JStgStat -> JSM JStgStat
closure (Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo (FastString -> Ident
global FastString
"h$reschedule") (Int -> [JSRep] -> CIRegs
CIRegs Int
0 []) FastString
"reschedule" (Int -> [JSRep] -> CILayout
CILayoutFixed Int
0 []) CIType
CIThunk CIStatic
forall a. Monoid a => a
mempty)
                   (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 -> JStgStat
returnS (JStgExpr -> JStgStat) -> JStgExpr -> JStgStat
forall a b. (a -> b) -> a -> b
$ FastString -> JStgExpr
var FastString
"h$reschedule")
             -- debug thing, insert on stack to dump current result, should be boxed
             , ClosureInfo -> JSM JStgStat -> JSM JStgStat
closure (Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo (FastString -> Ident
global FastString
"h$dumpRes") (Int -> [JSRep] -> CIRegs
CIRegs Int
0 [JSRep
PtrV]) FastString
"dumpRes" (Int -> [JSRep] -> CILayout
CILayoutFixed Int
1 [JSRep
ObjV]) CIType
CIThunk 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
re -> 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
"h$log" [FastString -> JStgExpr
jString FastString
"h$dumpRes result: " JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
+ JStgExpr
stack JStgExpr -> JStgExpr -> JStgExpr
.! (JStgExpr
spJStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
-JStgExpr
1)]
                             , FastString -> [JStgExpr] -> JStgStat
appS FastString
"h$log" [JStgExpr
r1]
                             , FastString -> [JStgExpr] -> JStgStat
appS FastString
"h$log" [FastString -> [JStgExpr] -> JStgExpr
app FastString
"h$collectProps" [JStgExpr
r1]]
                             , JStgExpr -> JStgStat -> JStgStat
jwhenS ((JStgExpr
r1 JStgExpr -> FastString -> JStgExpr
.^ FastString
"f") JStgExpr -> JStgExpr -> JStgExpr
.&&. (JStgExpr
r1 JStgExpr -> FastString -> JStgExpr
.^ FastString
"f" JStgExpr -> FastString -> JStgExpr
.^ FastString
"n"))
                               (FastString -> [JStgExpr] -> JStgStat
appS FastString
"h$log" [FastString -> JStgExpr
jString FastString
"name: " JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
+ JStgExpr
r1 JStgExpr -> FastString -> JStgExpr
.^ FastString
"f" JStgExpr -> FastString -> JStgExpr
.^ FastString
"n"])
                             , JStgExpr -> JStgStat -> JStgStat
jwhenS (JStgExpr -> [JStgExpr] -> JStgExpr
ApplExpr (JStgExpr
r1 JStgExpr -> FastString -> JStgExpr
.^ FastString
"hasOwnProperty") [FastString -> JStgExpr
jString FastString
closureField1_])
                               (FastString -> [JStgExpr] -> JStgStat
appS FastString
"h$log" [FastString -> JStgExpr
jString FastString
"d1: " JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
+ JStgExpr -> JStgExpr
closureField1 JStgExpr
r1])
                             , JStgExpr -> JStgStat -> JStgStat
jwhenS (JStgExpr -> [JStgExpr] -> JStgExpr
ApplExpr (JStgExpr
r1 JStgExpr -> FastString -> JStgExpr
.^ FastString
"hasOwnProperty") [FastString -> JStgExpr
jString FastString
closureField2_])
                               (FastString -> [JStgExpr] -> JStgStat
appS FastString
"h$log" [FastString -> JStgExpr
jString FastString
"d2: " JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
+ JStgExpr -> JStgExpr
closureField2 JStgExpr
r1])
                             , JStgExpr -> JStgStat -> JStgStat
jwhenS (JStgExpr
r1 JStgExpr -> FastString -> JStgExpr
.^ FastString
"f") (JStgStat -> JStgStat) -> JStgStat -> JStgStat
forall a b. (a -> b) -> a -> b
$ [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat
                               [ JStgExpr
re JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr -> JStgExpr
New (FastString -> [JStgExpr] -> JStgExpr
app FastString
"RegExp" [FastString -> JStgExpr
jString FastString
"([^\\n]+)\\n(.|\\n)*"])
                               , FastString -> [JStgExpr] -> JStgStat
appS FastString
"h$log" [FastString -> JStgExpr
jString FastString
"function"
                                                JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
+ JStgExpr -> [JStgExpr] -> JStgExpr
ApplExpr (JStgExpr -> [JStgExpr] -> JStgExpr
ApplExpr ((FastString -> JStgExpr
jString FastString
"" JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
+ JStgExpr
r1 JStgExpr -> FastString -> JStgExpr
.^ FastString
"f") JStgExpr -> FastString -> JStgExpr
.^ FastString
"substring") [JStgExpr
0, JStgExpr
50] JStgExpr -> FastString -> JStgExpr
.^ FastString
"replace") [JStgExpr
r1, FastString -> JStgExpr
jString FastString
"$1"]]
                               ]
                             , Int -> JStgStat
adjSpN' Int
2
                             , JStgExpr
r1 JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
null_
                             , JStgExpr -> JStgStat
returnS (JStgExpr
stack JStgExpr -> JStgExpr -> JStgExpr
.! JStgExpr
sp)
                             ])
             , ClosureInfo -> JSM JStgStat -> JSM JStgStat
closure (Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo (FastString -> Ident
global FastString
"h$resume_e") (Int -> [JSRep] -> CIRegs
CIRegs Int
0 [JSRep
PtrV]) FastString
"resume" (Int -> [JSRep] -> CILayout
CILayoutFixed Int
0 []) CIType
CIThunk 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
ss ->
                        do update_stk <- JStgExpr
-> (JStgExpr -> JStgExpr)
-> (JStgExpr -> JSM JStgStat)
-> JSM JStgStat
loop JStgExpr
0 (JStgExpr -> JStgExpr -> JStgExpr
.<. JStgExpr
ss JStgExpr -> FastString -> JStgExpr
.^ FastString
"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
$ (JStgExpr
stack JStgExpr -> JStgExpr -> JStgExpr
.! (JStgExpr
spJStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
+JStgExpr
1JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
+JStgExpr
i) JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
ss JStgExpr -> JStgExpr -> JStgExpr
.! JStgExpr
i) JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> JStgExpr -> JStgStat
postIncrS JStgExpr
i)
                           return $ mconcat [ss |= closureField1 r1
                                            , updateThunk' s
                                            , update_stk
                                            , sp |= sp + ss .^ "length"
                                            , r1 |= null_
                                            , returnS (stack .! sp)
                                            ])
             , ClosureInfo -> JSM JStgStat -> JSM JStgStat
closure (Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo (FastString -> Ident
global FastString
"h$unmaskFrame") (Int -> [JSRep] -> CIRegs
CIRegs Int
0 [JSRep
PtrV]) FastString
"unmask" (Int -> [JSRep] -> CILayout
CILayoutFixed Int
0 []) CIType
CIStackFrame CIStatic
forall a. Monoid a => a
mempty)
                  (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
var FastString
"h$currentThread" JStgExpr -> FastString -> JStgExpr
.^ FastString
"mask" JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
0)
                    JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> Int -> JStgStat
adjSpN' Int
1
                    -- back to scheduler to give us async exception if pending
                    JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> JStgExpr -> JStgStat -> JStgStat -> JStgStat
ifS (FastString -> JStgExpr
var FastString
"h$currentThread" JStgExpr -> FastString -> JStgExpr
.^ FastString
"excep" JStgExpr -> FastString -> JStgExpr
.^ FastString
"length" JStgExpr -> JStgExpr -> JStgExpr
.>. JStgExpr
0)
                    (StgToJSConfig -> [JStgExpr] -> JStgStat
push' StgToJSConfig
s [JStgExpr
r1, FastString -> JStgExpr
var FastString
"h$return"] JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> JStgExpr -> JStgStat
returnS (FastString -> JStgExpr
var FastString
"h$reschedule"))
                    (JStgExpr -> JStgStat
returnS (JStgExpr
stack JStgExpr -> JStgExpr -> JStgExpr
.! JStgExpr
sp)))
             , ClosureInfo -> JSM JStgStat -> JSM JStgStat
closure (Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo (FastString -> Ident
global FastString
"h$maskFrame") (Int -> [JSRep] -> CIRegs
CIRegs Int
0 [JSRep
PtrV]) FastString
"mask" (Int -> [JSRep] -> CILayout
CILayoutFixed Int
0 []) CIType
CIStackFrame CIStatic
forall a. Monoid a => a
mempty)
               (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
var FastString
"h$currentThread" JStgExpr -> FastString -> JStgExpr
.^ FastString
"mask" JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
2)
                 JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> Int -> JStgStat
adjSpN' Int
1
                 JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> JStgExpr -> JStgStat
returnS (JStgExpr
stack JStgExpr -> JStgExpr -> JStgExpr
.! JStgExpr
sp))
             , ClosureInfo -> JSM JStgStat -> JSM JStgStat
closure (Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo (FastString -> Ident
global FastString
"h$maskUnintFrame") (Int -> [JSRep] -> CIRegs
CIRegs Int
0 [JSRep
PtrV]) FastString
"maskUnint" (Int -> [JSRep] -> CILayout
CILayoutFixed Int
0 []) CIType
CIStackFrame CIStatic
forall a. Monoid a => a
mempty)
               (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
var FastString
"h$currentThread" JStgExpr -> FastString -> JStgExpr
.^ FastString
"mask" JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
1)
                 JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> Int -> JStgStat
adjSpN' Int
1
                 JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> JStgExpr -> JStgStat
returnS (JStgExpr
stack JStgExpr -> JStgExpr -> JStgExpr
.! JStgExpr
sp))
             , ClosureInfo -> JSM JStgStat -> JSM JStgStat
closure (Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo (FastString -> Ident
global FastString
"h$unboxFFIResult") (Int -> [JSRep] -> CIRegs
CIRegs Int
0 [JSRep
PtrV]) FastString
"unboxFFI" (Int -> [JSRep] -> CILayout
CILayoutFixed Int
0 []) CIType
CIStackFrame 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
d -> do set_regs <- JStgExpr
-> (JStgExpr -> JStgExpr)
-> (JStgExpr -> JSM JStgStat)
-> JSM JStgStat
loop JStgExpr
0 (JStgExpr -> JStgExpr -> JStgExpr
.<. JStgExpr
d JStgExpr -> FastString -> JStgExpr
.^ FastString
"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
"h$setReg" [JStgExpr
i JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
+ JStgExpr
1, JStgExpr
d JStgExpr -> JStgExpr -> JStgExpr
.! JStgExpr
i] JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> JStgExpr -> JStgStat
postIncrS JStgExpr
i)
                                 return $ mconcat [ d |= closureField1 r1
                                                  , set_regs
                                                  , adjSpN' 1
                                                  , returnS (stack .! sp)
                                                  ])
             , ClosureInfo -> JSM JStgStat -> JSM JStgStat
closure (Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo (FastString -> Ident
global FastString
"h$unbox_e") (Int -> [JSRep] -> CIRegs
CIRegs Int
0 [JSRep
PtrV]) FastString
"unboxed value" (Int -> [JSRep] -> CILayout
CILayoutFixed Int
1 [JSRep
DoubleV]) CIType
CIThunk CIStatic
forall a. Monoid a => a
mempty)
                  (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
r1 JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr -> JStgExpr
closureField1 JStgExpr
r1) JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> JStgExpr -> JStgStat
returnS (JStgExpr
stack JStgExpr -> JStgExpr -> JStgExpr
.! JStgExpr
sp))
             , ClosureInfo -> JSM JStgStat -> JSM JStgStat
closure (Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo (FastString -> Ident
global FastString
"h$retryInterrupted") (Int -> [JSRep] -> CIRegs
CIRegs Int
0 [JSRep
ObjV]) FastString
"retry interrupted operation" (Int -> [JSRep] -> CILayout
CILayoutFixed Int
1 [JSRep
ObjV]) CIType
CIStackFrame 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
a -> 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
a JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
stack JStgExpr -> JStgExpr -> JStgExpr
.! (JStgExpr
sp JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
- JStgExpr
1)
                                               , Int -> JStgStat
adjSpN' Int
2
                                               , JStgExpr -> JStgStat
returnS (JStgExpr -> [JStgExpr] -> JStgExpr
ApplExpr (JStgExpr
a JStgExpr -> JStgExpr -> JStgExpr
.! JStgExpr
0 JStgExpr -> FastString -> JStgExpr
.^ FastString
"apply") [FastString -> JStgExpr
var FastString
"this", JStgExpr -> [JStgExpr] -> JStgExpr
ApplExpr (JStgExpr
a JStgExpr -> FastString -> JStgExpr
.^ FastString
"slice") [JStgExpr
1]])
                                               ])
             , ClosureInfo -> JSM JStgStat -> JSM JStgStat
closure (Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo (FastString -> Ident
global FastString
"h$atomically_e") (Int -> [JSRep] -> CIRegs
CIRegs Int
0 [JSRep
PtrV]) FastString
"atomic operation" (Int -> [JSRep] -> CILayout
CILayoutFixed Int
1 [JSRep
PtrV]) CIType
CIStackFrame CIStatic
forall a. Monoid a => a
mempty)
                  (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 -> JStgStat -> JStgStat -> JStgStat
ifS (FastString -> [JStgExpr] -> JStgExpr
app FastString
"h$stmValidateTransaction" [])
               (FastString -> [JStgExpr] -> JStgStat
appS FastString
"h$stmCommitTransaction" []
                        JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> Int -> JStgStat
adjSpN' Int
2
                        JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> JStgExpr -> JStgStat
returnS (JStgExpr
stack JStgExpr -> JStgExpr -> JStgExpr
.! JStgExpr
sp))
                       (JStgExpr -> JStgStat
returnS (FastString -> [JStgExpr] -> JStgExpr
app FastString
"h$stmStartTransaction" [JStgExpr
stack JStgExpr -> JStgExpr -> JStgExpr
.! (JStgExpr
sp JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
- JStgExpr
1)])))

             , ClosureInfo -> JSM JStgStat -> JSM JStgStat
closure (Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo (FastString -> Ident
global FastString
"h$stmCatchRetry_e") (Int -> [JSRep] -> CIRegs
CIRegs Int
0 [JSRep
PtrV]) FastString
"catch retry" (Int -> [JSRep] -> CILayout
CILayoutFixed Int
1 [JSRep
PtrV]) CIType
CIStackFrame CIStatic
forall a. Monoid a => a
mempty)
                           (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
$
                             Int -> JStgStat
adjSpN' Int
2
                             JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> FastString -> [JStgExpr] -> JStgStat
appS FastString
"h$stmCommitTransaction" []
                             JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> JStgExpr -> JStgStat
returnS (JStgExpr
stack JStgExpr -> JStgExpr -> JStgExpr
.! JStgExpr
sp))
             , ClosureInfo -> JSM JStgStat -> JSM JStgStat
closure (Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo (FastString -> Ident
global FastString
"h$catchStm_e") (Int -> [JSRep] -> CIRegs
CIRegs Int
0 [JSRep
PtrV]) FastString
"STM catch" (Int -> [JSRep] -> CILayout
CILayoutFixed Int
3 [JSRep
ObjV,JSRep
PtrV,JSRep
ObjV]) CIType
CIStackFrame CIStatic
forall a. Monoid a => a
mempty)
               (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
$
                 Int -> JStgStat
adjSpN' Int
4
                 JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> FastString -> [JStgExpr] -> JStgStat
appS FastString
"h$stmCommitTransaction" []
                 JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> JStgExpr -> JStgStat
returnS (JStgExpr
stack JStgExpr -> JStgExpr -> JStgExpr
.! JStgExpr
sp))
             , ClosureInfo -> JSM JStgStat -> JSM JStgStat
closure (Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo (FastString -> Ident
global FastString
"h$stmResumeRetry_e") (Int -> [JSRep] -> CIRegs
CIRegs Int
0 [JSRep
PtrV]) FastString
"resume retry" (Int -> [JSRep] -> CILayout
CILayoutFixed Int
0 []) CIType
CIStackFrame 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
blocked ->
                              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 -> JStgStat -> JStgStat
jwhenS (JStgExpr
stack JStgExpr -> JStgExpr -> JStgExpr
.! (JStgExpr
sp JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
- JStgExpr
2) JStgExpr -> JStgExpr -> JStgExpr
.!==. FastString -> JStgExpr
var FastString
"h$atomically_e")
                                                    (FastString -> [JStgExpr] -> JStgStat
appS FastString
"throw" [FastString -> JStgExpr
jString FastString
"h$stmResumeRetry_e: unexpected value on stack"])
                                       , JStgExpr
blocked JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
stack JStgExpr -> JStgExpr -> JStgExpr
.! (JStgExpr
sp JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
- JStgExpr
1)
                                       , Int -> JStgStat
adjSpN' Int
2
                                       , FastString -> [JStgExpr] -> JStgStat
appS FastString
"h$stmRemoveBlockedThread" [JStgExpr
blocked, FastString -> JStgExpr
var FastString
"h$currentThread"]
                                       , JStgExpr -> JStgStat
returnS (FastString -> [JStgExpr] -> JStgExpr
app FastString
"h$stmStartTransaction" [JStgExpr
stack JStgExpr -> JStgExpr -> JStgExpr
.! (JStgExpr
sp JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
- JStgExpr
1)])
                                       ])
             , ClosureInfo -> JSM JStgStat -> JSM JStgStat
closure (Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo (FastString -> Ident
global FastString
"h$lazy_e") (Int -> [JSRep] -> CIRegs
CIRegs Int
0 [JSRep
PtrV]) FastString
"generic lazy value" (Int -> [JSRep] -> CILayout
CILayoutFixed Int
0 []) CIType
CIThunk 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
x ->
                              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
x JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr -> [JStgExpr] -> JStgExpr
ApplExpr (JStgExpr -> JStgExpr
closureField1 JStgExpr
r1) []
                                       , FastString -> [JStgExpr] -> JStgStat
appS FastString
"h$bh" []
                                       , StgToJSConfig -> JStgStat -> JStgStat
profStat StgToJSConfig
s JStgStat
enterCostCentreThunk
                                       , JStgExpr
r1 JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
x
                                       , JStgExpr -> JStgStat
returnS (JStgExpr
stack JStgExpr -> JStgExpr -> JStgExpr
.! JStgExpr
sp)
                                       ])
             -- Top-level statements to generate only in profiling mode
             , (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 (StgToJSConfig -> JStgStat -> JStgStat
profStat StgToJSConfig
s) (JSM JStgStat -> JSM JStgStat) -> JSM JStgStat -> JSM JStgStat
forall a b. (a -> b) -> a -> b
$ (ClosureInfo -> JSM JStgStat -> JSM JStgStat
closure (Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo (FastString -> Ident
global FastString
"h$setCcs_e") (Int -> [JSRep] -> CIRegs
CIRegs Int
0 [JSRep
PtrV]) FastString
"set cost centre stack" (Int -> [JSRep] -> CILayout
CILayoutFixed Int
1 [JSRep
ObjV]) CIType
CIStackFrame CIStatic
forall a. Monoid a => a
mempty)
                           (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
"h$restoreCCS" [ JStgExpr
stack JStgExpr -> JStgExpr -> JStgExpr
.! (JStgExpr
sp JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
- JStgExpr
1)]
                             JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> Int -> JStgStat
adjSpN' Int
2
                             JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> JStgExpr -> JStgStat
returnS (JStgExpr
stack JStgExpr -> JStgExpr -> JStgExpr
.! JStgExpr
sp)))
             ]