{-# LANGUAGE OverloadedStrings #-}

{-# OPTIONS_GHC -O0 #-}

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

import GHC.Prelude

import GHC.JS.Syntax
import GHC.JS.Make
import GHC.JS.Transform

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

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

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

-- | The garbageCollector resets registers and result variables.
garbageCollector :: JStat
garbageCollector :: JStat
garbageCollector =
  [JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat [ FastString -> Ident
TxtI FastString
"h$resetRegisters"  Ident -> JExpr -> JStat
||= JStat -> JExpr
forall a. ToSat a => a -> JExpr
jLam ([JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat ([JStat] -> JStat) -> [JStat] -> JStat
forall a b. (a -> b) -> a -> b
$ (StgReg -> JStat) -> [StgReg] -> [JStat]
forall a b. (a -> b) -> [a] -> [b]
map StgReg -> JStat
resetRegister [StgReg
forall a. Bounded a => a
minBound..StgReg
forall a. Bounded a => a
maxBound])
          , FastString -> Ident
TxtI FastString
"h$resetResultVars" Ident -> JExpr -> JStat
||= JStat -> JExpr
forall a. ToSat a => a -> JExpr
jLam ([JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat ([JStat] -> JStat) -> [JStat] -> JStat
forall a b. (a -> b) -> a -> b
$ (StgRet -> JStat) -> [StgRet] -> [JStat]
forall a b. (a -> b) -> [a] -> [b]
map StgRet -> JStat
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 -> JStat
resetRegister :: StgReg -> JStat
resetRegister StgReg
r = StgReg -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr StgReg
r JExpr -> JExpr -> JStat
|= JExpr
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 -> JStat
resetResultVar :: StgRet -> JStat
resetResultVar StgRet
r = StgRet -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr StgRet
r JExpr -> JExpr -> JStat
|= JExpr
null_

-- | Define closures based on size, these functions are syntactic sugar, e.g., a
-- Haskell function which generates some useful JS. Each Closure constructor
-- follows the naming convention h$cN, where N is a natural number. For example,
-- h$c (with the nat omitted) is a JS Land Constructor for a closure in JS land
-- which has a single entry function 'f', and no fields; identical to h$c0. h$c1
-- is a JS Land Constructor for a closure with an entry function 'f', and a
-- /single/ field 'x1', 'Just foo' is an example of this kind of closure. h$c2
-- is a JS Land Constructor for a closure with an entry function and two data
-- fields: 'x1' and 'x2'. And so on. Note that this has JIT performance
-- implications; you should use h$c1, h$c2, h$c3, ... h$c24 instead of making
-- objects manually so layouts and fields can be changed more easily and so the
-- JIT can optimize better.
closureConstructors :: StgToJSConfig -> JStat
closureConstructors :: StgToJSConfig -> JStat
closureConstructors StgToJSConfig
s = [JStat] -> JStat
BlockStat
  [ FastString -> [FastString] -> Closure -> JStat
declClsConstr FastString
"h$c" [FastString
"f"] (Closure -> JStat) -> Closure -> JStat
forall a b. (a -> b) -> a -> b
$ Closure
      { clEntry :: JExpr
clEntry  = FastString -> JExpr
var FastString
"f"
      , clField1 :: JExpr
clField1 = JExpr
null_
      , clField2 :: JExpr
clField2 = JExpr
null_
      , clMeta :: JExpr
clMeta   = JExpr
0
      , clCC :: Maybe JExpr
clCC     = Maybe JExpr
ccVal
      }
  , FastString -> [FastString] -> Closure -> JStat
declClsConstr FastString
"h$c0" [FastString
"f"] (Closure -> JStat) -> Closure -> JStat
forall a b. (a -> b) -> a -> b
$ Closure
      { clEntry :: JExpr
clEntry  = FastString -> JExpr
var FastString
"f"
      , clField1 :: JExpr
clField1 = JExpr
null_
      , clField2 :: JExpr
clField2 = JExpr
null_
      , clMeta :: JExpr
clMeta   = JExpr
0
      , clCC :: Maybe JExpr
clCC     = Maybe JExpr
ccVal
      }
  , FastString -> [FastString] -> Closure -> JStat
declClsConstr FastString
"h$c1" [FastString
"f", FastString
"x1"] (Closure -> JStat) -> Closure -> JStat
forall a b. (a -> b) -> a -> b
$ Closure
      { clEntry :: JExpr
clEntry  = FastString -> JExpr
var FastString
"f"
      , clField1 :: JExpr
clField1 = FastString -> JExpr
var FastString
"x1"
      , clField2 :: JExpr
clField2 = JExpr
null_
      , clMeta :: JExpr
clMeta   = JExpr
0
      , clCC :: Maybe JExpr
clCC     = Maybe JExpr
ccVal
      }
  , FastString -> [FastString] -> Closure -> JStat
declClsConstr FastString
"h$c2" [FastString
"f", FastString
"x1", FastString
"x2"] (Closure -> JStat) -> Closure -> JStat
forall a b. (a -> b) -> a -> b
$ Closure
      { clEntry :: JExpr
clEntry  = FastString -> JExpr
var FastString
"f"
      , clField1 :: JExpr
clField1 = FastString -> JExpr
var FastString
"x1"
      , clField2 :: JExpr
clField2 = FastString -> JExpr
var FastString
"x2"
      , clMeta :: JExpr
clMeta   = JExpr
0
      , clCC :: Maybe JExpr
clCC     = Maybe JExpr
ccVal
      }
  , [JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat ((Int -> JStat) -> [Int] -> [JStat]
forall a b. (a -> b) -> [a] -> [b]
map Int -> JStat
mkClosureCon [Int
3..Int
24])
  , [JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat ((Int -> JStat) -> [Int] -> [JStat]
forall a b. (a -> b) -> [a] -> [b]
map Int -> JStat
mkDataFill [Int
1..Int
24])
  ]
  where
    prof :: Bool
prof = StgToJSConfig -> Bool
csProf StgToJSConfig
s
    ([Ident]
ccArg,Maybe JExpr
ccVal)
      -- the cc argument happens to be named just like the cc field...
      | Bool
prof      = ([FastString -> Ident
TxtI FastString
closureCC_], JExpr -> Maybe JExpr
forall a. a -> Maybe a
Just (FastString -> JExpr
var FastString
closureCC_))
      | Bool
otherwise = ([], Maybe JExpr
forall a. Maybe a
Nothing)
    addCCArg :: [FastString] -> [Ident]
addCCArg [FastString]
as = (FastString -> Ident) -> [FastString] -> [Ident]
forall a b. (a -> b) -> [a] -> [b]
map FastString -> Ident
TxtI [FastString]
as [Ident] -> [Ident] -> [Ident]
forall a. [a] -> [a] -> [a]
++ [Ident]
ccArg
    addCCArg' :: [Ident] -> [Ident]
addCCArg' [Ident]
as = [Ident]
as [Ident] -> [Ident] -> [Ident]
forall a. [a] -> [a] -> [a]
++ [Ident]
ccArg

    declClsConstr :: FastString -> [FastString] -> Closure -> JStat
declClsConstr FastString
i [FastString]
as Closure
cl = FastString -> Ident
TxtI FastString
i Ident -> JExpr -> JStat
||= JVal -> JExpr
ValExpr ([Ident] -> JStat -> JVal
JFunc ([FastString] -> [Ident]
addCCArg [FastString]
as)
      ( (JExpr -> [JStat]) -> JStat
forall a. ToSat a => a -> JStat
jVar ((JExpr -> [JStat]) -> JStat) -> (JExpr -> [JStat]) -> JStat
forall a b. (a -> b) -> a -> b
$ \JExpr
x ->
          [ JStat
checkC
          , JExpr
x JExpr -> JExpr -> JStat
|= Closure -> JExpr
newClosure Closure
cl
          , JExpr -> JStat
notifyAlloc JExpr
x
          , JExpr -> JStat
traceAlloc JExpr
x
          , JExpr -> JStat
returnS JExpr
x
          ]
         ))

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

    notifyAlloc :: JExpr -> JStat
notifyAlloc JExpr
x | StgToJSConfig -> Bool
csDebugAlloc StgToJSConfig
s = FastString -> [JExpr] -> JStat
appS FastString
"h$debugAlloc_notifyAlloc" [JExpr
x]
                  | Bool
otherwise      = JStat
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 :: JStat
    checkC :: JStat
checkC | StgToJSConfig -> Bool
csAssertRts StgToJSConfig
s =
      (JExpr -> JStat) -> JStat
forall a. ToSat a => a -> JStat
jVar ((JExpr -> JStat) -> JStat) -> (JExpr -> JStat) -> JStat
forall a b. (a -> b) -> a -> b
$ \JExpr
msg ->
      JExpr -> JStat -> JStat
jwhenS (FastString -> JExpr
var FastString
"arguments" JExpr -> JExpr -> JExpr
.! JExpr
0 JExpr -> JExpr -> JExpr
.!==. FastString -> JExpr
jString FastString
"h$baseZCGHCziJSziPrimziJSVal_con_e")
                                  (JExpr -> (JExpr -> JExpr) -> (JExpr -> JStat) -> JStat
loop JExpr
1 (JExpr -> JExpr -> JExpr
.<. FastString -> JExpr
var FastString
"arguments" JExpr -> FastString -> JExpr
.^ FastString
"length")
                                          (\JExpr
i ->
                                             [JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat [JExpr
msg JExpr -> JExpr -> JStat
|= FastString -> JExpr
jString FastString
"warning: undefined or null in argument: "
                                                       JExpr -> JExpr -> JExpr
forall a. Num a => a -> a -> a
+ JExpr
i
                                                       JExpr -> JExpr -> JExpr
forall a. Num a => a -> a -> a
+ FastString -> JExpr
jString FastString
" allocating closure: " JExpr -> JExpr -> JExpr
forall a. Num a => a -> a -> a
+ (FastString -> JExpr
var FastString
"arguments" JExpr -> JExpr -> JExpr
.! JExpr
0 JExpr -> FastString -> JExpr
.^ FastString
"n")
                                                     , FastString -> [JExpr] -> JStat
appS FastString
"h$log" [JExpr
msg]
                                                     , JExpr -> JStat -> JStat
jwhenS (FastString -> JExpr
var FastString
"console" JExpr -> JExpr -> JExpr
.&&. (FastString -> JExpr
var FastString
"console" JExpr -> FastString -> JExpr
.^ FastString
"trace")) ((FastString -> JExpr
var FastString
"console" JExpr -> FastString -> JExpr
.^ FastString
"trace") JExpr -> [JExpr] -> JStat
`ApplStat` [JExpr
msg])
                                                     , JExpr -> JStat
postIncrS JExpr
i
                                                     ])

                                  )
           | Bool
otherwise = JStat
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 :: JStat
checkD | StgToJSConfig -> Bool
csAssertRts StgToJSConfig
s =
                     JExpr -> (JExpr -> JExpr) -> (JExpr -> JStat) -> JStat
loop JExpr
0 (JExpr -> JExpr -> JExpr
.<. FastString -> JExpr
var FastString
"arguments" JExpr -> FastString -> JExpr
.^ FastString
"length")
                     (\JExpr
i -> JExpr -> JStat -> JStat
jwhenS ((FastString -> JExpr
var FastString
"arguments" JExpr -> JExpr -> JExpr
.! JExpr
i JExpr -> JExpr -> JExpr
.===. JExpr
null_)
                                    JExpr -> JExpr -> JExpr
.||. (FastString -> JExpr
var FastString
"arguments" JExpr -> JExpr -> JExpr
.! JExpr
i JExpr -> JExpr -> JExpr
.===. JExpr
undefined_))
                            ((JExpr -> JStat) -> JStat
forall a. ToSat a => a -> JStat
jVar ((JExpr -> JStat) -> JStat) -> (JExpr -> JStat) -> JStat
forall a b. (a -> b) -> a -> b
$ \JExpr
msg ->
                                [JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat [ JExpr
msg JExpr -> JExpr -> JStat
|= FastString -> JExpr
jString FastString
"warning: undefined or null in argument: " JExpr -> JExpr -> JExpr
forall a. Num a => a -> a -> a
+ JExpr
i JExpr -> JExpr -> JExpr
forall a. Num a => a -> a -> a
+ FastString -> JExpr
jString FastString
" allocating fields"
                                        , JExpr -> JStat -> JStat
jwhenS (FastString -> JExpr
var FastString
"console" JExpr -> JExpr -> JExpr
.&&. (FastString -> JExpr
var FastString
"console" JExpr -> FastString -> JExpr
.^ FastString
"trace"))
                                                ((FastString -> JExpr
var FastString
"console" JExpr -> FastString -> JExpr
.^ FastString
"trace") JExpr -> [JExpr] -> JStat
`ApplStat` [JExpr
msg])
                                        ]))

           | Bool
otherwise = JStat
forall a. Monoid a => a
mempty

    mkClosureCon :: Int -> JStat
    mkClosureCon :: Int -> JStat
mkClosureCon Int
n = Ident
funName Ident -> JExpr -> JStat
||= JVal -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr JVal
fun
      where
        funName :: Ident
funName = FastString -> Ident
TxtI (FastString -> Ident) -> FastString -> Ident
forall a b. (a -> b) -> a -> b
$ String -> FastString
mkFastString (String
"h$c" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n)
        -- args are: f x1 x2 .. xn [cc]
        args :: [Ident]
args   = FastString -> Ident
TxtI FastString
"f" Ident -> [Ident] -> [Ident]
forall a. a -> [a] -> [a]
: [Ident] -> [Ident]
addCCArg' ((Int -> Ident) -> [Int] -> [Ident]
forall a b. (a -> b) -> [a] -> [b]
map (FastString -> Ident
TxtI (FastString -> Ident) -> (Int -> FastString) -> Int -> Ident
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> FastString
mkFastString (String -> FastString) -> (Int -> String) -> Int -> FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
'x'Char -> String -> String
forall a. a -> [a] -> [a]
:) (String -> String) -> (Int -> String) -> Int -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show) [(Int
1::Int)..Int
n])
        fun :: JVal
fun    = [Ident] -> JStat -> JVal
JFunc [Ident]
args JStat
funBod
        -- x1 goes into closureField1. All the other args are bundled into an
        -- object in closureField2: { d1 = x2, d2 = x3, ... }
        --
        extra_args :: JExpr
extra_args = JVal -> JExpr
ValExpr (JVal -> JExpr)
-> ([(FastString, JExpr)] -> JVal)
-> [(FastString, JExpr)]
-> JExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UniqMap FastString JExpr -> JVal
JHash (UniqMap FastString JExpr -> JVal)
-> ([(FastString, JExpr)] -> UniqMap FastString JExpr)
-> [(FastString, JExpr)]
-> JVal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(FastString, JExpr)] -> UniqMap FastString JExpr
forall k a. Uniquable k => [(k, a)] -> UniqMap k a
listToUniqMap ([(FastString, JExpr)] -> JExpr) -> [(FastString, JExpr)] -> JExpr
forall a b. (a -> b) -> a -> b
$ [FastString] -> [JExpr] -> [(FastString, JExpr)]
forall a b. [a] -> [b] -> [(a, b)]
zip
                   ((Int -> FastString) -> [Int] -> [FastString]
forall a b. (a -> b) -> [a] -> [b]
map (String -> FastString
mkFastString (String -> FastString) -> (Int -> String) -> Int -> FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
'd'Char -> String -> String
forall a. a -> [a] -> [a]
:) (String -> String) -> (Int -> String) -> Int -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show) [(Int
1::Int)..])
                   ((Int -> JExpr) -> [Int] -> [JExpr]
forall a b. (a -> b) -> [a] -> [b]
map (Ident -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr (Ident -> JExpr) -> (Int -> Ident) -> Int -> JExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FastString -> Ident
TxtI (FastString -> Ident) -> (Int -> FastString) -> Int -> Ident
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> FastString
mkFastString (String -> FastString) -> (Int -> String) -> Int -> FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
'x'Char -> String -> String
forall a. a -> [a] -> [a]
:) (String -> String) -> (Int -> String) -> Int -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show) [Int
2..Int
n])

        funBod :: JStat
funBod = (JExpr -> [JStat]) -> JStat
forall a. ToSat a => a -> JStat
jVar ((JExpr -> [JStat]) -> JStat) -> (JExpr -> [JStat]) -> JStat
forall a b. (a -> b) -> a -> b
$ \JExpr
x ->
            [ JStat
checkC
            , JExpr
x JExpr -> JExpr -> JStat
|= Closure -> JExpr
newClosure Closure
               { clEntry :: JExpr
clEntry  = FastString -> JExpr
var FastString
"f"
               , clField1 :: JExpr
clField1 = FastString -> JExpr
var FastString
"x1"
               , clField2 :: JExpr
clField2 = JExpr
extra_args
               , clMeta :: JExpr
clMeta   = JExpr
0
               , clCC :: Maybe JExpr
clCC     = Maybe JExpr
ccVal
               }
            , JExpr -> JStat
notifyAlloc JExpr
x
            , JExpr -> JStat
traceAlloc JExpr
x
            , JExpr -> JStat
returnS JExpr
x
            ]

    mkDataFill :: Int -> JStat
    mkDataFill :: Int -> JStat
mkDataFill Int
n = Ident
funName Ident -> JExpr -> JStat
||= JVal -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr JVal
fun
      where
        funName :: Ident
funName    = FastString -> Ident
TxtI (FastString -> Ident) -> FastString -> Ident
forall a b. (a -> b) -> a -> b
$ String -> FastString
mkFastString (String
"h$d" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n)
        ds :: [FastString]
ds         = (Int -> FastString) -> [Int] -> [FastString]
forall a b. (a -> b) -> [a] -> [b]
map (String -> FastString
mkFastString (String -> FastString) -> (Int -> String) -> Int -> FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
'd'Char -> String -> String
forall a. a -> [a] -> [a]
:) (String -> String) -> (Int -> String) -> Int -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show) [(Int
1::Int)..Int
n]
        extra_args :: JExpr
extra_args = JVal -> JExpr
ValExpr (JVal -> JExpr) -> ([JExpr] -> JVal) -> [JExpr] -> JExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UniqMap FastString JExpr -> JVal
JHash (UniqMap FastString JExpr -> JVal)
-> ([JExpr] -> UniqMap FastString JExpr) -> [JExpr] -> JVal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(FastString, JExpr)] -> UniqMap FastString JExpr
forall k a. Uniquable k => [(k, a)] -> UniqMap k a
listToUniqMap ([(FastString, JExpr)] -> UniqMap FastString JExpr)
-> ([JExpr] -> [(FastString, JExpr)])
-> [JExpr]
-> UniqMap FastString JExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FastString] -> [JExpr] -> [(FastString, JExpr)]
forall a b. [a] -> [b] -> [(a, b)]
zip [FastString]
ds ([JExpr] -> JExpr) -> [JExpr] -> JExpr
forall a b. (a -> b) -> a -> b
$ (FastString -> JExpr) -> [FastString] -> [JExpr]
forall a b. (a -> b) -> [a] -> [b]
map (Ident -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr (Ident -> JExpr) -> (FastString -> Ident) -> FastString -> JExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FastString -> Ident
TxtI) [FastString]
ds
        fun :: JVal
fun        = [Ident] -> JStat -> JVal
JFunc ((FastString -> Ident) -> [FastString] -> [Ident]
forall a b. (a -> b) -> [a] -> [b]
map FastString -> Ident
TxtI [FastString]
ds) (JStat
checkD JStat -> JStat -> JStat
forall a. Semigroup a => a -> a -> a
<> JExpr -> JStat
returnS JExpr
extra_args)

-- | JS Payload to perform stack manipulation in the RTS
stackManip :: JStat
stackManip :: JStat
stackManip = [JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat ((Int -> JStat) -> [Int] -> [JStat]
forall a b. (a -> b) -> [a] -> [b]
map Int -> JStat
mkPush [Int
1..Int
32]) JStat -> JStat -> JStat
forall a. Semigroup a => a -> a -> a
<>
             [JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat ((Integer -> JStat) -> [Integer] -> [JStat]
forall a b. (a -> b) -> [a] -> [b]
map Integer -> JStat
mkPpush [Integer
1..Integer
255])
  where
    mkPush :: Int -> JStat
    mkPush :: Int -> JStat
mkPush Int
n = let funName :: Ident
funName = FastString -> Ident
TxtI (FastString -> Ident) -> FastString -> Ident
forall a b. (a -> b) -> a -> b
$ String -> FastString
mkFastString (String
"h$p" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n)
                   as :: [Ident]
as      = (Int -> Ident) -> [Int] -> [Ident]
forall a b. (a -> b) -> [a] -> [b]
map (FastString -> Ident
TxtI (FastString -> Ident) -> (Int -> FastString) -> Int -> Ident
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> FastString
mkFastString (String -> FastString) -> (Int -> String) -> Int -> FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
'x'Char -> String -> String
forall a. a -> [a] -> [a]
:) (String -> String) -> (Int -> String) -> Int -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show) [Int
1..Int
n]
                   fun :: JVal
fun     = [Ident] -> JStat -> JVal
JFunc [Ident]
as ((JExpr
sp JExpr -> JExpr -> JStat
|= JExpr
sp JExpr -> JExpr -> JExpr
forall a. Num a => a -> a -> a
+ Int -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr Int
n)
                                       JStat -> JStat -> JStat
forall a. Semigroup a => a -> a -> a
<> [JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat ((Int -> Ident -> JStat) -> [Int] -> [Ident] -> [JStat]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Int
i Ident
a -> JExpr
stack JExpr -> JExpr -> JExpr
.! (JExpr
sp JExpr -> JExpr -> JExpr
forall a. Num a => a -> a -> a
- Int -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
i)) JExpr -> JExpr -> JStat
|= Ident -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr Ident
a)
                                                   [Int
1..] [Ident]
as))
               in Ident
funName Ident -> JExpr -> JStat
||= JVal -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr JVal
fun

    -- partial pushes, based on bitmap, increases Sp by highest bit
    mkPpush :: Integer -> JStat
    mkPpush :: Integer -> JStat
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 = JStat
forall a. Monoid a => a
mempty -- already handled by h$p
    mkPpush Integer
sig = let funName :: Ident
funName = FastString -> Ident
TxtI (FastString -> Ident) -> FastString -> Ident
forall a b. (a -> b) -> a -> b
$ String -> FastString
mkFastString (String
"h$pp" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
sig)
                      bits :: [Int]
bits    = Integer -> [Int]
bitsIdx Integer
sig
                      n :: Int
n       = [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
bits
                      h :: Int
h       = [Int] -> Int
forall a. HasCallStack => [a] -> a
last [Int]
bits
                      args :: [Ident]
args    = (Int -> Ident) -> [Int] -> [Ident]
forall a b. (a -> b) -> [a] -> [b]
map (FastString -> Ident
TxtI (FastString -> Ident) -> (Int -> FastString) -> Int -> Ident
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> FastString
mkFastString (String -> FastString) -> (Int -> String) -> Int -> FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
'x'Char -> String -> String
forall a. a -> [a] -> [a]
:) (String -> String) -> (Int -> String) -> Int -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show) [Int
1..Int
n]
                      fun :: JVal
fun     = [Ident] -> JStat -> JVal
JFunc [Ident]
args (JStat -> JVal) -> JStat -> JVal
forall a b. (a -> b) -> a -> b
$
                        [JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat [ JExpr
sp JExpr -> JExpr -> JStat
|= JExpr
sp JExpr -> JExpr -> JExpr
forall a. Num a => a -> a -> a
+ Int -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr (Int
hInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
                                , [JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat ((Int -> Ident -> JStat) -> [Int] -> [Ident] -> [JStat]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Int
b Ident
a -> JExpr
stack JExpr -> JExpr -> JExpr
.! (JExpr
sp JExpr -> JExpr -> JExpr
forall a. Num a => a -> a -> a
- Int -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr (Int
hInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
b)) JExpr -> JExpr -> JStat
|= Ident -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr Ident
a) [Int]
bits [Ident]
args)
                                ]
                   in Ident
funName Ident -> JExpr -> JStat
||= JVal -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr JVal
fun

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


-- | JS payload to declare the registers
declRegs :: JStat
declRegs :: JStat
declRegs =
  [JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat [ FastString -> Ident
TxtI FastString
"h$regs" Ident -> JExpr -> JStat
||= JVal -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr ([JExpr] -> JVal
JList [])
          , [JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat ((StgReg -> JStat) -> [StgReg] -> [JStat]
forall a b. (a -> b) -> [a] -> [b]
map StgReg -> JStat
forall {a}. (Show a, ToJExpr a) => a -> JStat
declReg (StgReg -> StgReg -> [StgReg]
forall a. Enum a => a -> a -> [a]
enumFromTo StgReg
R1 StgReg
R32))
          , JStat
regGettersSetters
          , JStat
loadRegs
          ]
    where
      declReg :: a -> JStat
declReg a
r = (Ident -> JStat
decl (Ident -> JStat) -> (a -> Ident) -> a -> JStat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FastString -> Ident
TxtI (FastString -> Ident) -> (a -> FastString) -> a -> Ident
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> FastString
mkFastString (String -> FastString) -> (a -> String) -> a -> FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"h$"String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String) -> (a -> String) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (String -> String) -> (a -> String) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show) a
r
                  JStat -> JStat -> JStat
forall a. Semigroup a => a -> a -> a
<> [JStat] -> JStat
BlockStat [JExpr -> JExpr -> JStat
AssignStat (a -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr a
r) (JVal -> JExpr
ValExpr (Integer -> JVal
JInt Integer
0))] -- [j| `r` = 0; |]

-- | JS payload to define getters and setters on the registers.
regGettersSetters :: JStat
regGettersSetters :: JStat
regGettersSetters =
  [JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat [ FastString -> Ident
TxtI FastString
"h$getReg" Ident -> JExpr -> JStat
||= (JExpr -> JStat) -> JExpr
forall a. ToSat a => a -> JExpr
jLam (\JExpr
n   -> JExpr -> [(JExpr, JStat)] -> JStat -> JStat
SwitchStat JExpr
n [(JExpr, JStat)]
getRegCases JStat
forall a. Monoid a => a
mempty)
          , FastString -> Ident
TxtI FastString
"h$setReg" Ident -> JExpr -> JStat
||= (JExpr -> JExpr -> JStat) -> JExpr
forall a. ToSat a => a -> JExpr
jLam (\JExpr
n JExpr
v -> JExpr -> [(JExpr, JStat)] -> JStat -> JStat
SwitchStat JExpr
n (JExpr -> [(JExpr, JStat)]
forall {a}. ToJExpr a => a -> [(JExpr, JStat)]
setRegCases JExpr
v) JStat
forall a. Monoid a => a
mempty)
          ]
  where
    getRegCases :: [(JExpr, JStat)]
getRegCases =
      (StgReg -> (JExpr, JStat)) -> [StgReg] -> [(JExpr, JStat)]
forall a b. (a -> b) -> [a] -> [b]
map (\StgReg
r -> (Int -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr (StgReg -> Int
jsRegToInt StgReg
r) , JExpr -> JStat
returnS (StgReg -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr StgReg
r))) [StgReg]
regsFromR1
    setRegCases :: a -> [(JExpr, JStat)]
setRegCases a
v =
      (StgReg -> (JExpr, JStat)) -> [StgReg] -> [(JExpr, JStat)]
forall a b. (a -> b) -> [a] -> [b]
map (\StgReg
r -> (Int -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr (StgReg -> Int
jsRegToInt StgReg
r), (StgReg -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr StgReg
r JExpr -> JExpr -> JStat
|= a -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr a
v) JStat -> JStat -> JStat
forall a. Semigroup a => a -> a -> a
<> JExpr -> JStat
returnS JExpr
undefined_)) [StgReg]
regsFromR1

-- | JS payload that defines the functions to load each register
loadRegs :: JStat
loadRegs :: JStat
loadRegs = [JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat ([JStat] -> JStat) -> [JStat] -> JStat
forall a b. (a -> b) -> a -> b
$ (Int -> JStat) -> [Int] -> [JStat]
forall a b. (a -> b) -> [a] -> [b]
map Int -> JStat
mkLoad [Int
1..Int
32]
  where
    mkLoad :: Int -> JStat
    mkLoad :: Int -> JStat
mkLoad Int
n = let args :: [Ident]
args   = (Int -> Ident) -> [Int] -> [Ident]
forall a b. (a -> b) -> [a] -> [b]
map (FastString -> Ident
TxtI (FastString -> Ident) -> (Int -> FastString) -> Int -> Ident
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> FastString
mkFastString (String -> FastString) -> (Int -> String) -> Int -> FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"x"String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String) -> (Int -> String) -> Int -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show) [Int
1..Int
n]
                   assign :: [JStat]
assign = (Ident -> StgReg -> JStat) -> [Ident] -> [StgReg] -> [JStat]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Ident
a StgReg
r -> StgReg -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr StgReg
r JExpr -> JExpr -> JStat
|= Ident -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr Ident
a)
                              [Ident]
args ([StgReg] -> [StgReg]
forall a. [a] -> [a]
reverse ([StgReg] -> [StgReg]) -> [StgReg] -> [StgReg]
forall a b. (a -> b) -> a -> b
$ Int -> [StgReg] -> [StgReg]
forall a. Int -> [a] -> [a]
take Int
n [StgReg]
regsFromR1)
                   fname :: Ident
fname  = FastString -> Ident
TxtI (FastString -> Ident) -> FastString -> Ident
forall a b. (a -> b) -> a -> b
$ String -> FastString
mkFastString (String
"h$l" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n)
                   fun :: JVal
fun    = [Ident] -> JStat -> JVal
JFunc [Ident]
args ([JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat [JStat]
assign)
               in Ident
fname Ident -> JExpr -> JStat
||= JVal -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr JVal
fun

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

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

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

-- | JS payload defining the types closures.
closureTypes :: JStat
closureTypes :: JStat
closureTypes = [JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat ((ClosureType -> JStat) -> [ClosureType] -> [JStat]
forall a b. (a -> b) -> [a] -> [b]
map ClosureType -> JStat
mkClosureType (ClosureType -> ClosureType -> [ClosureType]
forall a. Enum a => a -> a -> [a]
enumFromTo ClosureType
forall a. Bounded a => a
minBound ClosureType
forall a. Bounded a => a
maxBound)) JStat -> JStat -> JStat
forall a. Semigroup a => a -> a -> a
<> JStat
closureTypeName
  where
    mkClosureType :: ClosureType -> JStat
    mkClosureType :: ClosureType -> JStat
mkClosureType ClosureType
c = let s :: Ident
s = FastString -> Ident
TxtI (FastString -> Ident) -> (String -> FastString) -> String -> Ident
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> FastString
mkFastString (String -> Ident) -> String -> Ident
forall a b. (a -> b) -> a -> b
$ String
"h$" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper (ClosureType -> String
forall a. Show a => a -> String
show ClosureType
c) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_CLOSURE"
                      in  Ident
s Ident -> JExpr -> JStat
||= ClosureType -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr ClosureType
c
    closureTypeName :: JStat
    closureTypeName :: JStat
closureTypeName =
      FastString -> Ident
TxtI FastString
"h$closureTypeName" Ident -> JExpr -> JStat
||= (JExpr -> JStat) -> JExpr
forall a. ToSat a => a -> JExpr
jLam (\JExpr
c ->
                                           [JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat ((ClosureType -> JStat) -> [ClosureType] -> [JStat]
forall a b. (a -> b) -> [a] -> [b]
map (JExpr -> ClosureType -> JStat
ifCT JExpr
c) [ClosureType
forall a. Bounded a => a
minBound..ClosureType
forall a. Bounded a => a
maxBound])
                                          JStat -> JStat -> JStat
forall a. Semigroup a => a -> a -> a
<> JExpr -> JStat
returnS (FastString -> JExpr
jString FastString
"InvalidClosureType"))

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

-- | JS payload declaring the RTS functions.
rtsDecls :: JStat
rtsDecls :: JStat
rtsDecls = Maybe FastString -> JStat -> JStat
forall a. JMacro a => Maybe FastString -> a -> a
jsSaturate (FastString -> Maybe FastString
forall a. a -> Maybe a
Just FastString
"h$RTSD") (JStat -> JStat) -> JStat -> JStat
forall a b. (a -> b) -> a -> b
$
  [JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat [ FastString -> Ident
TxtI FastString
"h$currentThread"   Ident -> JExpr -> JStat
||= JExpr
null_                   -- thread state object for current thread
          , FastString -> Ident
TxtI FastString
"h$stack"           Ident -> JExpr -> JStat
||= JExpr
null_                   -- stack for the current thread
          , FastString -> Ident
TxtI FastString
"h$sp"              Ident -> JExpr -> JStat
||= JExpr
0                       -- stack pointer for the current thread
          , FastString -> Ident
TxtI FastString
"h$initStatic"      Ident -> JExpr -> JStat
||= JVal -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr ([JExpr] -> JVal
JList [])      -- we need delayed initialization for static objects, push functions here to be initialized just before haskell runs
          , FastString -> Ident
TxtI FastString
"h$staticThunks"    Ident -> JExpr -> JStat
||= JVal -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr ([(FastString, JExpr)] -> JVal
jhFromList []) --  funcName -> heapidx map for srefs
          , FastString -> Ident
TxtI FastString
"h$staticThunksArr" Ident -> JExpr -> JStat
||= JVal -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr ([JExpr] -> JVal
JList [])      -- indices of updatable thunks in static heap
          , FastString -> Ident
TxtI FastString
"h$CAFs"            Ident -> JExpr -> JStat
||= JVal -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr ([JExpr] -> JVal
JList [])
          , FastString -> Ident
TxtI FastString
"h$CAFsReset"       Ident -> JExpr -> JStat
||= JVal -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr ([JExpr] -> JVal
JList [])
          -- stg registers
          , JStat
declRegs
          , JStat
declRets]

-- | print the embedded RTS to a String
rtsText :: StgToJSConfig -> String
rtsText :: StgToJSConfig -> String
rtsText = Doc -> String
forall a. Show a => a -> String
show (Doc -> String)
-> (StgToJSConfig -> Doc) -> StgToJSConfig -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JStat -> Doc
pretty (JStat -> Doc) -> (StgToJSConfig -> JStat) -> StgToJSConfig -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StgToJSConfig -> JStat
rts

-- | print the RTS declarations to a String.
rtsDeclsText :: String
rtsDeclsText :: String
rtsDeclsText = Doc -> String
forall a. Show a => a -> String
show (Doc -> String) -> (JStat -> Doc) -> JStat -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JStat -> Doc
pretty (JStat -> String) -> JStat -> String
forall a b. (a -> b) -> a -> b
$ JStat
rtsDecls

-- | Wrapper over the RTS to guarentee saturation, see 'GHC.JS.Transform'
rts :: StgToJSConfig -> JStat
rts :: StgToJSConfig -> JStat
rts = Maybe FastString -> JStat -> JStat
forall a. JMacro a => Maybe FastString -> a -> a
jsSaturate (FastString -> Maybe FastString
forall a. a -> Maybe a
Just FastString
"h$RTS") (JStat -> JStat)
-> (StgToJSConfig -> JStat) -> StgToJSConfig -> JStat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StgToJSConfig -> JStat
rts'

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

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