{-# 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
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.Stack
import GHC.StgToJS.Symbols
import GHC.StgToJS.Types

import GHC.Types.Unique.Map

import Data.Array
import Data.Monoid
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' Ident
hdResetRegisters  (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' Ident
hdResetResultVars (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. 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 which has a single entry function 'f', and no fields; identical to
-- h$c0. h$c1 is a 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
-- 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
name FastString
closureCC_], JStgExpr -> Maybe JStgExpr
forall a. a -> Maybe a
Just (FastString -> JStgExpr
global 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
hdTraceAlloc [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
hdDebugAllocNotifyAlloc [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 (JStgExpr
arguments JStgExpr -> JStgExpr -> JStgExpr
.! JStgExpr
0 JStgExpr -> JStgExpr -> JStgExpr
.!==. FastString -> JStgExpr
jString FastString
hdGhcInternalJSPrimValConEntryStr)
        (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
.<. JStgExpr
arguments JStgExpr -> FastString -> JStgExpr
.^ FastString
lngth)
          (\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
+ (JStgExpr
arguments JStgExpr -> JStgExpr -> JStgExpr
.! JStgExpr
0 JStgExpr -> FastString -> JStgExpr
.^ FastString
n)
                      , FastString -> [JStgExpr] -> JStgStat
appS FastString
hdLogStr [JStgExpr
msg]
                      , JStgExpr -> JStgStat -> JStgStat
jwhenS (JStgExpr
console JStgExpr -> JStgExpr -> JStgExpr
.&&. (JStgExpr
console JStgExpr -> FastString -> JStgExpr
.^ FastString
trace)) ((JStgExpr
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
.<. JStgExpr
arguments JStgExpr -> FastString -> JStgExpr
.^ FastString
lngth)
                     (\JStgExpr
i -> JStgExpr -> JStgStat -> JStgStat
jwhenS ((JStgExpr
arguments JStgExpr -> JStgExpr -> JStgExpr
.! JStgExpr
i JStgExpr -> JStgExpr -> JStgExpr
.===. JStgExpr
null_)
                                    JStgExpr -> JStgExpr -> JStgExpr
.||. (JStgExpr
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 (JStgExpr
console JStgExpr -> JStgExpr -> JStgExpr
.&&. (JStgExpr
console JStgExpr -> FastString -> JStgExpr
.^ FastString
trace))
                                                ((JStgExpr
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 :: Ident -> JSM JStgStat
singleton_closure_con Ident
nm = Ident -> (Solo JStgExpr -> JSM JStgStat) -> JSM JStgStat
forall args.
JSArgument args =>
Ident -> (args -> JSM JStgStat) -> JSM JStgStat
jFunction Ident
nm ((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  = Ident -> JSM JStgStat
singleton_closure_con Ident
hdCStr
    -- the h$c0 special case
    mkClosureCon (Just Int
0) = Ident -> JSM JStgStat
singleton_closure_con Ident
hdC0Str
    -- 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
name (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
name (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 = Array Int Ident
pushN Array Int Ident -> Int -> Ident
forall i e. Ix i => Array i e -> i -> e
! 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 = Array Integer Ident
pushNN Array Integer Ident -> Integer -> Ident
forall i e. Ix i => Array i e -> i -> e
! 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
.===. JStgExpr
hdBlackHole)
      (JStgExpr -> JStgStat
returnS (JStgExpr -> JStgStat) -> JStgExpr -> JStgStat
forall a b. (a -> b) -> a -> b
$ FastString -> [JStgExpr] -> JStgExpr
app FastString
hdThrowStr [JStgExpr
hdInternalExceptionControlExceptionBaseNonTermination, 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
|= JStgExpr
hdBlackHole) 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 [ hdRegsStr ||= toJExpr (JList [])
              , mconcat (map declReg lowRegs)
              , getters_setters
              , loaders
              ]
    where
      declReg :: Ident -> JStgStat
declReg Ident
r = Ident -> JStgStat
decl Ident
r JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> [JStgStat] -> JStgStat
BlockStat [Ident -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr Ident
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
name FastString
hdGetRegStr) (\(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 (name hdSetRegStr) (\(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 = Array Int Ident
hdLoads Array Int Ident -> Int -> Ident
forall i e. Ix i => Array i e -> i -> e
! 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 'hdLoads' array to construct functions which set
-- the registers.

-- | JS payload which defines an array of function symbols that set N registers
-- from M parameters. For example, h$l4 compiles to:
-- @
--    function h$l4(x1, x2, x3, x4) {
--      h$r4 = x1;
--      h$r3 = x2;
--      h$r2 = x3;
--      h$r1 = x4;
--    };
-- @
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
hdLoads 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 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
$ (Ident -> JStgStat) -> [Ident] -> [JStgStat]
forall a b. (a -> b) -> [a] -> [b]
map Ident -> JStgStat
decl [Ident]
retRegs

-- | 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 = Array ClosureType Ident
closureNames Array ClosureType Ident -> ClosureType -> Ident
forall i e. Ix i => Array i e -> i -> e
! ClosureType
c
                      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 Ident
hdClosureTypeNameStr
                      \(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 [ hdCurrentThreadStr    ||= null_                   -- thread state object for current thread
            , hdStackStr            ||= null_                   -- stack for the current thread
            , hdStackPtrStr         ||= 0                       -- stack pointer for the current thread
            , hdInitStaticStr       ||= toJExpr (JList [])      -- we need delayed initialization for static objects, push functions here to be initialized just before haskell runs
            ,  hdStaticThunksStr    ||= toJExpr (jhFromList []) --  funcName -> heapidx map for srefs
            ,  hdStaticThunksArrStr ||= toJExpr (JList [])      -- indices of updatable thunks in static heap
            ,  hdCAFsStr            ||= toJExpr (JList [])
            ,  hdCAFsResetStr       ||= 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 = [  Ident
hdRtsTraceForeign Ident -> JStgExpr -> JStgStat
||= Bool -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr (StgToJSConfig -> Bool
csTraceForeign StgToJSConfig
s)
              ,  Ident
hdRtsProfiling    Ident -> JStgExpr -> JStgStat
||= Bool -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr (StgToJSConfig -> Bool
csProf StgToJSConfig
s)
              ,  Ident
hdCtFun           Ident -> JStgExpr -> JStgStat
||= ClosureType -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr ClosureType
Fun
              ,  Ident
hdCtCon           Ident -> JStgExpr -> JStgStat
||= ClosureType -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr ClosureType
Con
              ,  Ident
hdCtThunk         Ident -> JStgExpr -> JStgStat
||= ClosureType -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr ClosureType
Thunk
              ,  Ident
hdCtPap           Ident -> JStgExpr -> JStgStat
||= ClosureType -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr ClosureType
Pap
              ,  Ident
hdCtBlackhole     Ident -> JStgExpr -> JStgStat
||= ClosureType -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr ClosureType
Blackhole
              ,  Ident
hdCtStackFrame    Ident -> JStgExpr -> JStgStat
||= ClosureType -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr ClosureType
StackFrame
              ,  Ident
hdCtVtPtr         Ident -> JStgExpr -> JStgStat
||= JSRep -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr JSRep
PtrV
              ,  Ident
hdVtVoid          Ident -> JStgExpr -> JStgStat
||= JSRep -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr JSRep
VoidV
              ,  Ident
hdVtInt           Ident -> JStgExpr -> JStgStat
||= JSRep -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr JSRep
IntV
              ,  Ident
hdVtDouble        Ident -> JStgExpr -> JStgStat
||= JSRep -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr JSRep
DoubleV
              ,  Ident
hdVtLong          Ident -> JStgExpr -> JStgStat
||= JSRep -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr JSRep
LongV
              ,  Ident
hdVtAddr          Ident -> JStgExpr -> JStgStat
||= JSRep -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr JSRep
AddrV
              ,  Ident
hdVtObj           Ident -> JStgExpr -> JStgStat
||= JSRep -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr JSRep
ObjV
              ,  Ident
hdVtArr           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
name FastString
hdBhStr) (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 Ident
hdBlackHoleLNEStr (\(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 Ident
hdBlackHoleStr (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
throwStr [FastString -> JStgExpr
jString FastString
"oops: entered black hole"])
             , ClosureInfo -> JSM JStgStat -> JSM JStgStat
closure (Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo Ident
hdBlackHoleTrapStr (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
throwStr [FastString -> JStgExpr
jString FastString
"oops: entered multiple times"])
             , ClosureInfo -> JSM JStgStat -> JSM JStgStat
closure (Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo Ident
hdDone (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
hdFinishedThread [JStgExpr
hdCurrentThread] JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> JStgExpr -> JStgStat
returnS JStgExpr
hdReschedule)
             , ClosureInfo -> JSM JStgStat -> JSM JStgStat
closure (Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo Ident
hdDoneMainEntryStr (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 JStgExpr
hdDoneMain)
             , Ident -> FastString -> CILayout -> Int -> JSM JStgStat
conClosure Ident
hdFalseEntry FastString
"GHC.Types.False" (Int -> [JSRep] -> CILayout
CILayoutFixed Int
0 []) Int
1
             , Ident -> FastString -> CILayout -> Int -> JSM JStgStat
conClosure Ident
hdTrueEntry 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 Ident
hdData1Entry 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 Ident
hdData2Entry 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 Ident
hdNoopEntryStr (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 (Ident
hdNoopStr Ident -> JStgExpr -> JStgStat
||= JStgExpr -> [JStgExpr] -> JStgExpr
ApplExpr JStgExpr
hdC0 (JStgExpr
hdNoopEntry 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 Ident
hdCatchEntryStr (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 Ident
hdDataToTagEntryStr (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 Ident
hdAp1EntryStr (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
hdBhStr []
                                        , 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
hdAp11Fast [])
                                        ])
             -- function application to two arguments
             , ClosureInfo -> JSM JStgStat -> JSM JStgStat
closure (Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo Ident
hdAp2EntryStr (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
d1Str
                                            , JStgExpr
d3 JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr -> JStgExpr
closureField2 JStgExpr
r1 JStgExpr -> FastString -> JStgExpr
.^ FastString
d2Str
                                            , FastString -> [JStgExpr] -> JStgStat
appS FastString
hdBhStr []
                                            , 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
hdAp22FastStr [])
                                            ])
             -- function application to three arguments
             , ClosureInfo -> JSM JStgStat -> JSM JStgStat
closure (Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo Ident
hdAp3EntryStr (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
d1Str
                                                , JStgExpr
d3 JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr -> JStgExpr
closureField2 JStgExpr
r1 JStgExpr -> FastString -> JStgExpr
.^ FastString
d2Str
                                                , JStgExpr
d4 JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr -> JStgExpr
closureField2 JStgExpr
r1 JStgExpr -> FastString -> JStgExpr
.^ FastString
d3Str
                                                , FastString -> [JStgExpr] -> JStgStat
appS FastString
hdBhStr []
                                                , 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
hdAp33FastStr [])
                                                ])
             , ClosureInfo -> JSM JStgStat -> JSM JStgStat
closure (Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo Ident
hdUpdThunkEntryStr (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
|= JStgExpr
hdUpdFrame
                           , JStgExpr -> JStgExpr
closureInfo   JStgExpr
r1  JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
hdBlackHole
                           , JStgExpr -> JStgExpr
closureField1 JStgExpr
r1  JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
hdCurrentThread
                           , 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
hdAp00FastStr [])
                           ]
                  )
             -- select first field
             , ClosureInfo -> JSM JStgStat -> JSM JStgStat
closure (Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo Ident
hdSelect1EntryStr (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
|= JStgExpr
hdUpdFrame
                                   , JStgExpr
stack JStgExpr -> JStgExpr -> JStgExpr
.! JStgExpr
sp       JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
hdSelect1Ret
                                   , JStgExpr -> JStgExpr
closureInfo   JStgExpr
r1  JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
hdBlackHole
                                   , JStgExpr -> JStgExpr
closureField1 JStgExpr
r1  JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
hdCurrentThread
                                   , 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
hdAp00FastStr [])
                                   ])
             , ClosureInfo -> JSM JStgStat -> JSM JStgStat
closure (Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo Ident
hdSelect1RetStr (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
hdAp00FastStr [])
                  )
             -- select second field of a two-field constructor
             , ClosureInfo -> JSM JStgStat -> JSM JStgStat
closure (Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo Ident
hdSelect2EntryStr (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
|= JStgExpr
hdUpdFrame
                                   , JStgExpr
stack JStgExpr -> JStgExpr -> JStgExpr
.! JStgExpr
sp       JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
hdSelect2Return
                                   , JStgExpr -> JStgExpr
closureInfo   JStgExpr
r1  JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
hdBlackHole
                                   , JStgExpr -> JStgExpr
closureField1 JStgExpr
r1  JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
hdCurrentThread
                                   , 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
hdAp00FastStr [])
                                   ]
                  )
             , ClosureInfo -> JSM JStgStat -> JSM JStgStat
closure (Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo Ident
hdSelect2ReturnStr (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
hdAp00FastStr [])
                                              ]
             , ClosureInfo -> JSM JStgStat -> JSM JStgStat
closure (Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo Ident
hdKeepAliveEntryStr (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 Ident
hdRaiseEntryStr (Int -> [JSRep] -> CIRegs
CIRegs Int
0 [JSRep
PtrV]) (Ident -> FastString
identFS Ident
hdRaiseEntryStr) (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
hdThrowStr [JStgExpr -> JStgExpr
closureField1 JStgExpr
r1, JStgExpr
false_]))
             , ClosureInfo -> JSM JStgStat -> JSM JStgStat
closure (Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo Ident
hdRaiseAsyncEntryStr (Int -> [JSRep] -> CIRegs
CIRegs Int
0 [JSRep
PtrV]) (Ident -> FastString
identFS Ident
hdRaiseAsyncEntryStr) (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
hdThrowStr [JStgExpr -> JStgExpr
closureField1 JStgExpr
r1, JStgExpr
true_]))
             , ClosureInfo -> JSM JStgStat -> JSM JStgStat
closure (Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo Ident
hdRaiseAsyncFrameStr (Int -> [JSRep] -> CIRegs
CIRegs Int
0 []) (Ident -> FastString
identFS Ident
hdRaiseAsyncFrameStr) (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
hdThrowStr [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 Ident
hdReduceStr (Int -> [JSRep] -> CIRegs
CIRegs Int
0 [JSRep
PtrV]) (Ident -> FastString
identFS Ident
hdReduceStr) (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 Ident
hdRunIOEntryStr (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
|= JStgExpr
hdAp10
                                              , JStgExpr -> JStgStat
returnS JStgExpr
hdAp10
                                              ]
             , ClosureInfo -> JSM JStgStat -> JSM JStgStat
closure (Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo Ident
hdFlushStdoutEntryStr (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
|= JStgExpr
hdGhcInternalIOHandleFlush
                                  , JStgExpr
r2 JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
hdGhcInternalIOHandleFDStdout
                                  , JStgExpr -> JStgStat
returnS (FastString -> [JStgExpr] -> JStgExpr
app FastString
hdAp11Fast [])
                                  ]
             , 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
$ Ident
hdFlushStdoutStr Ident -> JStgExpr -> JStgStat
||= FastString -> [JStgExpr] -> JStgExpr
app FastString
hdStaticThunkStr [JStgExpr
hdFlushStdoutEntry]
             -- 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 Ident
hdRestoreThreadStr (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
hdSetRegStr [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 Ident
hdReturnStr (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 Ident
hdReturnFStr (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 Ident
hdRescheduleStr (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
$ JStgExpr
hdReschedule)
             -- 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 Ident
hdDumpResStr (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
hdLogStr [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
hdLogStr [JStgExpr
r1]
                             , FastString -> [JStgExpr] -> JStgStat
appS FastString
hdLogStr [FastString -> [JStgExpr] -> JStgExpr
app FastString
hdCollectProps [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
hdLogStr [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
hdLogStr [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
hdLogStr [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
hdLogStr [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 Ident
hdResumeEntryStr (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
lngth) (\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 .^ lngth
                                            , r1 |= null_
                                            , returnS (stack .! sp)
                                            ])
             , ClosureInfo -> JSM JStgStat -> JSM JStgStat
closure (Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo Ident
hdUnMaskFrameStr (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
$
                    (JStgExpr
hdCurrentThread 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 (JStgExpr
hdCurrentThread JStgExpr -> FastString -> JStgExpr
.^ FastString
excepStr JStgExpr -> FastString -> JStgExpr
.^ FastString
lngth JStgExpr -> JStgExpr -> JStgExpr
.>. JStgExpr
0)
                    (StgToJSConfig -> [JStgExpr] -> JStgStat
push' StgToJSConfig
s [JStgExpr
r1, JStgExpr
hdReturn] JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> JStgExpr -> JStgStat
returnS JStgExpr
hdReschedule)
                    (JStgExpr -> JStgStat
returnS (JStgExpr
stack JStgExpr -> JStgExpr -> JStgExpr
.! JStgExpr
sp)))
             , ClosureInfo -> JSM JStgStat -> JSM JStgStat
closure (Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo Ident
hdMaskFrameStr (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
$
                 (JStgExpr
hdCurrentThread 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 Ident
hdMaskUnintFrameStr (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
$
                 (JStgExpr
hdCurrentThread 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 Ident
hdUnboxFFIResultStr (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
lngth) (\JStgExpr
i -> JStgStat -> JSM JStgStat
forall a. a -> StateT JEnv Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStgStat -> JSM JStgStat) -> JStgStat -> JSM JStgStat
forall a b. (a -> b) -> a -> b
$ FastString -> [JStgExpr] -> JStgStat
appS FastString
hdSetRegStr [JStgExpr
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 Ident
hdUnboxEntryStr (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 Ident
hdRetryInterruptedStr (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) [JStgExpr
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 Ident
hdAtomicallyEntryStr (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
hdStmValidateTransactionStr [])
               (FastString -> [JStgExpr] -> JStgStat
appS FastString
hdStmCommitTransactionStr []
                        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
hdStmStartTransactionStr [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 Ident
hdStmCatchRetryEntryStr (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
hdStmCommitTransactionStr []
                             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 Ident
hdStmCatchEntryStr (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
hdStmCommitTransactionStr []
                 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 Ident
hdStgResumeRetryEntryStr (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
.!==. JStgExpr
hdAtomicallyEntry)
                                                    (FastString -> [JStgExpr] -> JStgStat
appS FastString
throwStr [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
hdStmRemoveBlockedThreadStr [JStgExpr
blocked, JStgExpr
hdCurrentThread]
                                       , JStgExpr -> JStgStat
returnS (FastString -> [JStgExpr] -> JStgExpr
app FastString
hdStmStartTransactionStr [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 Ident
hdLazyEntryStr (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
hdBhStr []
                                       , 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)
                                       ])
             , ClosureInfo -> JSM JStgStat -> JSM JStgStat
closure (Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo Ident
hdReportHeapOverflowStr (Int -> [JSRep] -> CIRegs
CIRegs Int
0 [JSRep
PtrV]) (Ident -> FastString
identFS Ident
hdReportHeapOverflowStr) (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] -> JStgStat
appS FastString
throwStr [FastString -> JStgExpr
jString FastString
"h$reportHeapOverflow: Heap Overflow!"]))
             , ClosureInfo -> JSM JStgStat -> JSM JStgStat
closure (Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo Ident
hdReportStackOverflowStr (Int -> [JSRep] -> CIRegs
CIRegs Int
0 [JSRep
PtrV]) FastString
"h$reportStackOverflow" (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] -> JStgStat
appS FastString
throwStr [FastString -> JStgExpr
jString FastString
"h$reportStackOverflow: Stack Overflow!"]))
             -- 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 Ident
hdSetCcsEntryStr (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
hdRestoreCCSStr [ 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)))
             ]