JS.Rts; refactoring and move to StgToJS

* add closure manipulation helpers and use them in Apply
* add cache (Array) for pre-generated PAP names
* reduce line length:
  * use BlockArguments instead of parens
  * remove implicit mconcat in jVar's body

Rts: more refactorings

Rts: move into StgToJS hierarchy

5 files changed, 1654 insertions, 14 deletions

diff --git a/compiler/GHC/StgToJS/DataCon.hs b/compiler/GHC/StgToJS/DataCon.hs
index e68b22605b..662515456b 100644
--- a/compiler/GHC/StgToJS/DataCon.hs
+++ b/compiler/GHC/StgToJS/DataCon.hs
@@ -72,13 +72,13 @@ allocUnboxedCon con = \case
 
 allocDynamicE :: StgToJSConfig -> JExpr -> [JExpr] -> Maybe JExpr -> JExpr
 allocDynamicE s entry free cc
-  | csInlineAlloc s || length free > 24 =
-      ValExpr . jhFromList $ [ (closureEntry_ , entry)
-                             , (closureExtra1_, fillObj1)
-                             , (closureExtra2_, fillObj2)
-                             , (closureMeta_  , ValExpr (JInt 0))
-                             ] ++
-                             maybe [] (\cid -> [("cc", cid)]) cc
+  | csInlineAlloc s || length free > 24 = newClosure $ Closure
+      { clEntry  = entry
+      , clExtra1 = fillObj1
+      , clExtra2 = fillObj2
+      , clMeta   = ValExpr (JInt 0)
+      , clCC     = cc
+      }
   | otherwise = ApplExpr allocFun (toJExpr entry : free ++ maybeToList cc)
   where
     allocFun = allocClsA (length free)
diff --git a/compiler/GHC/StgToJS/Heap.hs b/compiler/GHC/StgToJS/Heap.hs
index 44ed2fdc46..2fdc135491 100644
--- a/compiler/GHC/StgToJS/Heap.hs
+++ b/compiler/GHC/StgToJS/Heap.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE RecordWildCards #-}
 
 module GHC.StgToJS.Heap
   ( closureType
@@ -16,14 +17,24 @@ module GHC.StgToJS.Heap
   , isCon'
   , conTag
   , conTag'
-  , entry
+  , closureEntry
+  , closureMeta
+  , closureExtra1
+  , closureExtra2
+  , closureCC
   , funArity
   , funArity'
   , papArity
   , funOrPapArity
+  , Closure (..)
+  , newClosure
+  , assignClosure
+  , CopyCC (..)
+  , copyClosure
   -- * Field names
   , closureEntry_
   , closureMeta_
+  , closureCC_
   , closureExtra1_
   , closureExtra2_
   -- * Javascript Type literals
@@ -38,6 +49,8 @@ import GHC.JS.Make
 import GHC.StgToJS.Types
 import GHC.Data.ShortText (ShortText)
 
+import Data.Monoid
+
 -- FIXME: Jeff (2022,03): These helpers are a classic case of using a newtype
 -- over a type synonym to leverage GHC's type checker. Basically we never want
 -- to mix these up, and so we should have:
@@ -65,6 +78,9 @@ closureExtra2_ = "d2"
 closureMeta_ :: ShortText
 closureMeta_ = "m"
 
+closureCC_ :: ShortText
+closureCC_ = "cc"
+
 entryClosureType_ :: ShortText
 entryClosureType_ = "t"
 
@@ -78,7 +94,7 @@ jTyObject :: JExpr
 jTyObject = jString "object"
 
 closureType :: JExpr -> JExpr
-closureType = entryClosureType . entry
+closureType = entryClosureType . closureEntry
 
 entryClosureType :: JExpr -> JExpr
 entryClosureType f = f .^ entryClosureType_
@@ -114,17 +130,34 @@ isCon' :: JExpr -> JExpr
 isCon' f = entryClosureType f .===. toJExpr Con
 
 conTag :: JExpr -> JExpr
-conTag = conTag' . entry
+conTag = conTag' . closureEntry
 
 conTag' :: JExpr -> JExpr
 conTag' f = f .^ entryConTag_
 
-entry :: JExpr -> JExpr
-entry p = p .^ closureEntry_
+-- | Get closure entry function
+closureEntry :: JExpr -> JExpr
+closureEntry p = p .^ closureEntry_
+
+-- | Get closure metadata
+closureMeta :: JExpr -> JExpr
+closureMeta p = p .^ closureMeta_
+
+-- | Get closure cost-center
+closureCC :: JExpr -> JExpr
+closureCC p = p .^ closureCC_
+
+-- | Get closure extra field 1
+closureExtra1 :: JExpr -> JExpr
+closureExtra1 p = p .^ closureExtra1_
+
+-- | Get closure extra field 2
+closureExtra2 :: JExpr -> JExpr
+closureExtra2 p = p .^ closureExtra2_
 
 -- number of  arguments (arity & 0xff = arguments, arity >> 8 = number of registers)
 funArity :: JExpr -> JExpr
-funArity = funArity' . entry
+funArity = funArity' . closureEntry
 
 -- function arity with raw reference to the entry
 funArity' :: JExpr -> JExpr
@@ -132,7 +165,7 @@ funArity' f = f .^ entryFunArity_
 
 -- arity of a partial application
 papArity :: JExpr -> JExpr
-papArity cp = cp .^ closureExtra2_ .^ closureExtra1_
+papArity cp = closureExtra1 (closureExtra2 cp)
 
 funOrPapArity
   :: JExpr       -- ^ heap object
@@ -143,3 +176,47 @@ funOrPapArity c = \case
              (toJExpr (papArity c))
   Just f  -> ((IfExpr (toJExpr (isFun' f))) (toJExpr (funArity' f)))
              (toJExpr (papArity c))
+
+-- | Used to pass arguments to newClosure with some safety
+data Closure = Closure
+  { clEntry  :: JExpr
+  , clExtra1 :: JExpr
+  , clExtra2 :: JExpr
+  , clMeta   :: JExpr
+  , clCC     :: Maybe JExpr
+  }
+
+newClosure :: Closure -> JExpr
+newClosure Closure{..} =
+  let xs = [ (closureEntry_ , clEntry)
+           , (closureExtra1_, clExtra1)
+           , (closureExtra2_, clExtra2)
+           , (closureMeta_  , clMeta)
+           ]
+  in case clCC of
+    -- CC field is optional (probably to minimize code size as we could assign
+    -- null_, but we get the same effect implicitly)
+    Nothing -> ValExpr (jhFromList xs)
+    Just cc -> ValExpr (jhFromList $ (closureCC_,cc) : xs)
+
+assignClosure :: JExpr -> Closure -> JStat
+assignClosure t Closure{..} = BlockStat
+  [ closureEntry  t |= clEntry
+  , closureExtra1 t |= clExtra1
+  , closureExtra2 t |= clExtra2
+  , closureMeta   t |= clMeta
+  ] <> case clCC of
+      Nothing -> mempty
+      Just cc -> closureCC t |= cc
+
+data CopyCC = CopyCC | DontCopyCC
+
+copyClosure :: CopyCC -> JExpr -> JExpr -> JStat
+copyClosure copy_cc t s = BlockStat
+  [ closureEntry  t |= closureEntry  s
+  , closureExtra1 t |= closureExtra1 s
+  , closureExtra2 t |= closureExtra2 s
+  , closureMeta   t |= closureMeta   s
+  ] <> case copy_cc of
+      DontCopyCC -> mempty
+      CopyCC     -> closureCC t |= closureCC s
diff --git a/compiler/GHC/StgToJS/Rts/Apply.hs b/compiler/GHC/StgToJS/Rts/Apply.hs
new file mode 100644
index 0000000000..6c5cb15d54
--- /dev/null
+++ b/compiler/GHC/StgToJS/Rts/Apply.hs
@@ -0,0 +1,746 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE BlockArguments #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  GHC.StgToJS.Rts.Apply
+-- Copyright   :  (c) The University of Glasgow 2001
+-- License     :  BSD-style (see the file LICENSE)
+--
+-- Maintainer  :  Jeffrey Young  <jeffrey.young@iohk.io>
+--                Luite Stegeman <luite.stegeman@iohk.io>
+--                Sylvain Henry  <sylvain.henry@iohk.io>
+-- Stability   :  experimental
+--
+--  Generate various apply functions for the RTS, for speeding up
+--  function application in the most common cases. The code is generated
+--  because it contains lots of repeating patterns, and to make it more
+--  flexible when changing the RTS (for example how arguments are passed)
+--
+--  The code in here can be a bit hard to read due to all the generated
+--  low-level access things. Reading rts.js for a compiled program can be
+--  easier (the file is always the same unless you change low-level RTS
+--  options)
+--
+--  FIXME: add selector thunks and let the gc follow them
+-----------------------------------------------------------------------------
+
+module GHC.StgToJS.Rts.Apply where
+
+import GHC.Prelude hiding ((.|.))
+
+import GHC.JS.Syntax
+import GHC.JS.Make
+
+import GHC.StgToJS.Rts.Types
+import GHC.StgToJS.DataCon
+import GHC.StgToJS.Heap
+import GHC.StgToJS.Monad
+import GHC.StgToJS.Profiling
+import GHC.StgToJS.Regs
+import GHC.StgToJS.Types
+
+import GHC.Types.CostCentre
+import GHC.Data.ShortText
+
+import qualified Data.Bits as Bits
+import Data.Semigroup ((<>))
+import Data.Array
+
+rtsApply :: StgToJSConfig -> JStat
+rtsApply cfg = BlockStat $
+  map (uncurry (stackApply cfg)) applySpec
+  ++ map (uncurry (fastApply cfg)) applySpec
+  ++ map (pap cfg) specPap
+  ++ [ mkApplyArr
+     , genericStackApply cfg
+     , genericFastApply  cfg
+     , zeroApply cfg
+     , updates   cfg
+     , papGen    cfg
+     , moveRegs2
+     , selectors cfg
+     ]
+
+-- specialized apply for these
+-- make sure that once you are in spec, you stay there
+applySpec :: [(Int,Int)] -- regs,arity
+applySpec = [ (regs,arity)  | arity <- [1..4], regs <- [max 0 (arity-1)..(arity*2)]]
+
+specApply :: Bool -> Int -> Int -> Maybe JExpr
+specApply fast n r
+  | (r,n) == (0,0)         = Just (toJExpr . TxtI . pack $ "h$ap_0_0" ++ fastSuff)
+  | (r,n) == (0,1)         = Just (toJExpr . TxtI . pack $ "h$ap_1_0" ++ fastSuff)
+  | (r,n) `elem` applySpec =
+        Just (toJExpr . TxtI . pack $ "h$ap_" ++ show n ++ "_" ++ show r ++ fastSuff)
+  | otherwise = Nothing
+   where
+      fastSuff | fast      = "_fast"
+               | otherwise = ""
+{-
+  Build arrays to quickly lookup apply functions, getting the fast variant when possible
+   - h$apply[r << 8 | n] = function application for r regs, n args
+   - h$paps[r]           = partial application for r registers (number of args is in the object)
+ -}
+  -- FIXME (Jeff, 2022/03): Perf: This code would benefit a great deal by using
+  -- a datastucture that supports fast merging.
+mkApplyArr :: JStat
+mkApplyArr = BlockStat
+  [ TxtI "h$apply" ||= toJExpr (JList mempty)
+  , TxtI "h$paps"  ||= toJExpr (JList mempty)
+  , (var "h$initStatic" .^ "push") `ApplStat`
+    [ValExpr $ JFunc [] $ jVar \i ->
+      [ i |= 0
+      , WhileStat False (i .<. 65536)
+        ((var "h$apply" .! i |= var "h$ap_gen")
+         <> UOpStat PreIncOp i)
+      , i |= 0
+      , WhileStat False (i .<. 128)
+        ((var "h$paps" .! i |= var "h$pap_gen")
+         <> UOpStat PreIncOp i)
+      , var "h$apply" .! 0 |= var "h$ap_0_0"
+      , mconcat (map assignSpec applySpec)
+      , mconcat (map assignPap specPap)
+      ]
+    ]]
+  where
+    assignSpec :: (Int, Int) -> JStat
+    assignSpec (r,n) =
+      var "h$apply" .! toJExpr (Bits.shiftL r 8 Bits..|. n) |=
+           toJExpr (TxtI . pack $ "h$ap_" ++ show n ++ "_" ++ show r)
+
+    assignPap :: Int -> JStat
+    assignPap p = var "h$paps" .! toJExpr p |=
+                      toJExpr (TxtI . pack $ "h$pap_" ++ show p)
+
+-- generic stack apply that can do everything, but less efficiently
+-- on stack: tag: (regs << 8 | arity)
+-- fixme: set closure info of stack frame
+genericStackApply :: StgToJSConfig -> JStat
+genericStackApply s =
+   closure (ClosureInfo "h$ap_gen" (CIRegs 0 [PtrV]) "h$ap_gen" CILayoutVariable CIStackFrame mempty)
+           (jVar \cf ->
+               [ traceRts s (jString "h$ap_gen")
+               , cf |= closureEntry r1
+               , SwitchStat (entryClosureType cf)
+                 [ (toJExpr Thunk, profStat s pushRestoreCCS <> returnS cf)
+                 , (toJExpr Fun,   funCase cf (funArity' cf))
+                 , (toJExpr Pap,   funCase cf (papArity r1))
+                 , (toJExpr Blackhole, push' s [r1, var "h$return"]
+                     <> returnS (app "h$blockOnBlackhole" [r1]))
+                 ] (appS "throw" [jString "h$ap_gen: unexpected closure type " + (cf .^ "t")])
+               ]
+            )
+  where
+    funCase c arity = jVar \myArity ar myAr myRegs regs newTag newAp p dat ->
+      [ myArity |= stack .! (sp - 1)
+      , ar |= mask8 arity
+      , myAr |= mask8 myArity
+      , myRegs |= myArity .>>. 8
+      , traceRts s (jString "h$ap_gen: args: " + myAr
+                    + jString " regs: " + myRegs)
+      , ifBlockS (myAr .===. ar)
+        -- then
+        [ traceRts s (jString "h$ap_gen: exact")
+        , loop 0 (.<. myRegs)
+                         (\i -> appS "h$setReg" [i+2, stack .! (sp-2-i)]
+                           <> postIncrS i)
+        , (sp |= sp - myRegs - 2)
+        , returnS c
+        ]
+        -- else
+        [ ifBlockS (myAr .>. ar)
+            --then
+            [ regs |= arity .>>. 8
+            , traceRts s (jString "h$ap_gen: oversat: arity: " + ar
+                          + jString " regs: " + regs)
+            , loop 0 (.<. regs)
+              (\i -> traceRts s (jString "h$ap_gen: loading register: " + i)
+                <> appS "h$setReg" [i+2, stack .! (sp-2-i)]
+                <> postIncrS i)
+            , newTag |= ((myRegs-regs).<<.8).|.myAr - ar
+            , newAp |= var "h$apply" .! newTag
+            , traceRts s (jString "h$ap_gen: next: " + (newAp .^ "n"))
+            , ifS (newAp .===. var "h$ap_gen")
+                   ((sp |= sp - regs) <> (stack .! (sp - 1) |= newTag))
+                   (sp |= sp - regs - 1)
+            , stack .! sp |= newAp
+            , profStat s pushRestoreCCS
+            , returnS c
+            ]
+            -- else
+            [ traceRts s (jString "h$ap_gen: undersat")
+            , p   |= var "h$paps" .! myRegs
+            , dat |= toJExpr [r1, ((arity .>>. 8)-myRegs)*256+ar-myAr]
+            ,  loop 0 (.<. myRegs)
+               (\i -> (dat .^ "push") `ApplStat` [stack .! (sp - i - 2)]
+                      <> postIncrS i)
+            , sp  |= sp - myRegs - 2
+            , r1  |= initClosure s p dat jCurrentCCS
+            , returnStack
+            ]
+        ]
+      ]
+
+{-
+  generic fast apply: can handle anything (slowly)
+  signature tag in argument
+-}
+genericFastApply :: StgToJSConfig -> JStat
+genericFastApply s =
+   TxtI "h$ap_gen_fast" ||= jLam \tag -> jVar \c ->
+      [traceRts s (jString "h$ap_gen_fast: " + tag)
+      , c |= closureEntry r1
+      , SwitchStat (entryClosureType c)
+        [ (toJExpr Thunk, traceRts s (jString "h$ap_gen_fast: thunk")
+           <> pushStackApply c tag
+           <> returnS c)
+        , (toJExpr Fun, jVar \farity ->
+                               [ farity |= funArity' c
+                               , traceRts s (jString "h$ap_gen_fast: fun " + farity)
+                               , funCase c tag farity
+                               ])
+        , (toJExpr Pap, jVar \parity ->
+                               [ parity |= papArity r1
+                               , traceRts s (jString "h$ap_gen_fast: pap " + parity)
+                               , funCase c tag parity
+                               ])
+        , (toJExpr Con, traceRts s (jString "h$ap_gen_fast: con")
+            <> jwhenS (tag .!=. 0)
+                (appS "throw" [jString "h$ap_gen_fast: invalid apply"])
+                        <> returnS c)
+        , (toJExpr Blackhole, traceRts s (jString "h$ap_gen_fast: blackhole")
+            <> pushStackApply c tag
+            <> push' s [r1, var "h$return"]
+            <> returnS (app "h$blockOnBlackhole" [r1]))
+        ] $ appS "throw" [jString "h$ap_gen_fast: unexpected closure type: " + c .^ "t"]
+      ]
+
+  where
+     -- thunk: push everything to stack frame, enter thunk first
+    pushStackApply :: JExpr -> JExpr -> JStat
+    pushStackApply _c tag =
+      jVar \ap ->
+        [ pushAllRegs tag
+        , ap |= var "h$apply" .! tag
+        , ifS (ap .===. var "h$ap_gen")
+                ((sp |= sp + 2) <> (stack .! (sp-1) |= tag))
+                (sp |= sp + 1)
+        , stack .! sp |= ap
+        , profStat s pushRestoreCCS
+        ]
+
+    funCase :: JExpr -> JExpr -> JExpr -> JStat
+    funCase c tag arity =
+      jVar \ar myAr myRegs regsStart newTag newAp dat p ->
+        [ ar     |= mask8 arity
+        , myAr   |= mask8 tag
+        , myRegs |= tag .>>. 8
+        , traceRts s (jString "h$ap_gen_fast: args: " + myAr
+                      + jString " regs: "             + myRegs)
+        , ifS (myAr .===. ar)
+        -- call the function directly
+          (traceRts s (jString "h$ap_gen_fast: exact") <> returnS c)
+          (ifBlockS (myAr .>. ar)
+          -- push stack frame with remaining args, then call fun
+           [ traceRts s (jString "h$ap_gen_fast: oversat " + sp)
+           , regsStart |= (arity .>>. 8) + 1
+           , sp |= sp + myRegs - regsStart + 1
+           , traceRts s (jString "h$ap_gen_fast: oversat " + sp)
+           , pushArgs regsStart myRegs
+           , newTag |= ((myRegs-( arity.>>.8)).<<.8).|.myAr-ar
+           , newAp |= var "h$apply" .! newTag
+           , ifS (newAp .===. var "h$ap_gen")
+                 ((sp |= sp + 2) <> (stack .! (sp - 1) |= newTag))
+                 (sp |= sp + 1)
+           , stack .! sp |= newAp
+           , profStat s pushRestoreCCS
+           , returnS c
+           ]
+          -- else
+           [traceRts s (jString "h$ap_gen_fast: undersat: " + myRegs + jString " " + tag)
+           , jwhenS (tag .!=. 0) $ mconcat
+               [ p |= var "h$paps" .! myRegs
+               , dat |= toJExpr [r1, ((arity .>>. 8)-myRegs)*256+ar-myAr]
+               , loop 0 (.<. myRegs)
+                 (\i -> (dat .^ "push")
+                   `ApplStat` [app "h$getReg" [i+2]] <> postIncrS i)
+               , r1 |= initClosure s p dat jCurrentCCS
+               ]
+           , returnStack
+           ])
+        ]
+
+
+    pushAllRegs :: JExpr -> JStat
+    pushAllRegs tag =
+      jVar \regs ->
+        [ regs |= tag .>>. 8
+        , sp |= sp + regs
+        , SwitchStat regs (map pushReg [65,64..2]) mempty
+        ]
+      where
+        pushReg :: Int -> (JExpr, JStat)
+        pushReg r = (toJExpr (r-1),  stack .! (sp - toJExpr (r - 2)) |= toJExpr (intToJSReg r))
+
+    pushArgs :: JExpr -> JExpr -> JStat
+    pushArgs start end =
+      loop end (.>=.start) (\i -> traceRts s (jString "pushing register: " + i)
+                             <> (stack .! (sp + start - i) |= app "h$getReg" [i+1])
+                             <> postDecrS i
+                           )
+
+stackApply :: StgToJSConfig
+           -> Int         -- ^ number of registers in stack frame
+           -> Int         -- ^ number of arguments
+           -> JStat
+stackApply s r n =
+  closure (ClosureInfo funcName (CIRegs 0 [PtrV]) funcName layout CIStackFrame mempty)
+          body
+  where
+    layout    = CILayoutUnknown r
+
+    funcName = pack ("h$ap_" ++ show n ++ "_" ++ show r)
+
+    body = jVar \c ->
+             [ c |= closureEntry r1
+             , traceRts s (toJExpr funcName
+                           + jString " "
+                           + (c .^ "n")
+                           + jString " sp: " + sp
+                           + jString " a: "  + (c .^ "a"))
+             , SwitchStat (entryClosureType c)
+               [ (toJExpr Thunk, traceRts s (toJExpr $ funcName <> ": thunk") <> profStat s pushRestoreCCS <> returnS c)
+               , (toJExpr Fun, traceRts s (toJExpr $ funcName <> ": fun") <> funCase c)
+               , (toJExpr Pap, traceRts s (toJExpr $ funcName <> ": pap") <> papCase c)
+               , (toJExpr Blackhole, push' s [r1, var "h$return"] <> returnS (app "h$blockOnBlackhole" [r1]))
+               ] (appS "throw" [toJExpr ("panic: " <> funcName <> ", unexpected closure type: ") + (c .^ "t")])
+             ]
+
+    funExact c = popSkip' 1 (reverse $ take r (map toJExpr $ enumFrom R2)) <> returnS c
+    stackArgs = map (\x -> stack .! (sp - toJExpr x)) [1..r]
+
+    papCase :: JExpr -> JStat
+    papCase c = jVar \expr arity0 arity ->
+      case expr of
+        ValExpr (JVar pap) -> [ arity0 |= papArity r1
+                              , arity |= mask8 arity0
+                              , traceRts s (toJExpr (funcName <> ": found pap, arity: ") + arity)
+                              , ifS (toJExpr n .===. arity)
+                              --then
+                                (traceRts s (toJExpr (funcName <> ": exact")) <> funExact c)
+                              -- else
+                                (ifS (toJExpr n .>. arity)
+                                  (traceRts s (toJExpr (funcName <> ": oversat")) <> oversatCase c arity0 arity)
+                                  (traceRts s (toJExpr (funcName <> ": undersat"))
+                                   <> mkPap s pap r1 (toJExpr n) stackArgs -- FIXME do we want double pap?
+                                   <> (sp |= sp - toJExpr (r + 1))
+                                   <> (r1 |= toJExpr pap)
+                                   <> returnStack))
+                              ]
+        _                   -> mempty -- FIXME: Jeff (2022,03), just quieting non-exhaustive
+                                      -- patterns. That the code wants to do this
+                                      -- means we should be encoding that funCase is
+                                      -- only callable on ValExpr (JVar pap)'s in
+                                      -- the type system, perhaps with a GADT or
+                                      -- phantom
+
+
+    funCase :: JExpr -> JStat
+    funCase c = jVar \expr ar0 ar ->
+      case expr of
+        ValExpr (JVar pap) -> [ ar0 |= funArity' c
+                              , ar |= mask8 ar0
+                              , ifS (toJExpr n .===. ar)
+                                (traceRts s (toJExpr (funcName <> ": exact")) <> funExact c)
+                                (ifS (toJExpr n .>. ar)
+                                 (traceRts s (toJExpr (funcName <> ": oversat"))
+                                  <> oversatCase c ar0 ar)
+                                 (traceRts s (toJExpr (funcName <> ": undersat"))
+                                  <> mkPap s pap (toJExpr R1) (toJExpr n) stackArgs
+                                  <> (sp |= sp - toJExpr (r+1))
+                                  <> (r1 |= toJExpr pap)
+                                  <> returnStack))
+                              ]
+        _                  -> mempty  -- FIXME: Jeff (2022,03), just quieting non-exhaustive
+                                      -- patterns. That the code wants to do this
+                                      -- means we should be encoding that funCase is
+                                      -- only callable on ValExpr (JVar pap)'s in
+                                      -- the type system, perhaps with a GADT or
+                                      -- phantom
+
+
+    -- oversat: call the function but keep enough on the stack for the next
+    oversatCase :: JExpr -- function
+                -> JExpr -- the arity tag
+                -> JExpr -- real arity (arity & 0xff)
+                -> JStat
+    oversatCase c arity arity0 =
+      jVar \rs newAp ->
+        [ rs |= (arity .>>. 8)
+        , loadRegs rs
+        , sp |= sp - rs
+        , newAp |= (var "h$apply" .! (toJExpr n-arity0.|.((toJExpr r-rs).<<.8)))
+        , stack .! sp |= newAp
+        , profStat s pushRestoreCCS
+        , traceRts s (toJExpr (funcName <> ": new stack frame: ") + (newAp .^ "n"))
+        , returnS c
+        ]
+      where
+        loadRegs rs = SwitchStat rs switchAlts mempty
+          where
+            switchAlts = map (\x -> (toJExpr x, toJExpr (intToJSReg (x+1)) |= stack .! (sp - toJExpr x))) [r,r-1..1]
+
+{-
+  stg_ap_r_n_fast is entered if a function of unknown arity
+  is called, n arguments are already in r registers
+-}
+fastApply :: StgToJSConfig -> Int -> Int -> JStat
+fastApply s r n = func ||= toJExpr (JFunc myFunArgs body)
+    where
+      funName = pack ("h$ap_" ++ show n ++ "_" ++ show r ++ "_fast")
+      func    = TxtI funName
+
+      myFunArgs = []
+
+      regArgs = take r (enumFrom R2)
+
+      mkAp :: Int -> Int -> [JExpr]
+      mkAp n' r' = [ var . pack $ "h$ap_" ++ show n' ++ "_" ++ show r' ]
+
+      body =
+        jVar \c farity arity ->
+          [ c |= closureEntry r1
+          , traceRts s (toJExpr (funName <> ": sp ") + sp)
+          -- TODO: Jeff (2022,03): factor our and dry out this code
+          , SwitchStat (entryClosureType c)
+             [(toJExpr Fun, traceRts s (toJExpr (funName <> ": ")
+                                        + clName c
+                                        + jString " (arity: " + (c .^ "a") + jString ")")
+                            <> (farity |= funArity' c)
+                            <> funCase c farity)
+             ,(toJExpr Pap, traceRts s (toJExpr (funName <> ": pap")) <> (arity |= papArity r1) <> funCase c arity)
+             ,(toJExpr Thunk, traceRts s (toJExpr (funName <> ": thunk")) <> push' s (reverse (map toJExpr $ take r (enumFrom R2)) ++ mkAp n r) <> profStat s pushRestoreCCS <> returnS c)
+             ,(toJExpr Blackhole, traceRts s (toJExpr (funName <> ": blackhole")) <> push' s (reverse (map toJExpr $ take r (enumFrom R2)) ++ mkAp n r) <> push' s [r1, var "h$return"] <> returnS (app "h$blockOnBlackhole" [r1]))]
+             (appS "throw" [toJExpr (funName <> ": unexpected closure type: ") + c .^ "t"])
+          ]
+
+      funCase :: JExpr -> JExpr -> JStat
+      funCase c arity = jVar \arg ar -> case arg of
+          ValExpr (JVar pap) -> [ ar |= mask8 arity
+                                ,  ifS (toJExpr n .===. ar)
+                                  -- then
+                                  (traceRts s (toJExpr (funName <> ": exact")) <> returnS c)
+                                  -- else
+                                  (ifS (toJExpr n .>. ar)
+                                    --then
+                                    (traceRts s (toJExpr (funName <> ": oversat")) <> oversatCase c arity)
+                                    -- else
+                                    (traceRts s (toJExpr (funName <> ": undersat"))
+                                     <> mkPap s pap r1 (toJExpr n) (map toJExpr regArgs)
+                                     <> (r1 |= toJExpr pap)
+                                     <> returnStack))
+                                ]
+          _             -> mempty -- FIXME: Jeff (2022,03), just quieting non-exhaustive
+                                  -- patterns. That the code wants to do this
+                                  -- means we should be encoding that funCase is
+                                  -- only callable on ValExpr (JVar pap)'s in
+                                  -- the type system, perhaps with a GADT or
+                                  -- phantom
+
+      oversatCase :: JExpr -> JExpr -> JStat
+      oversatCase c arity =
+         jVar \rs rsRemain ->
+           [ rs |= arity .>>. 8
+           , rsRemain |= toJExpr r - rs
+           , traceRts s (toJExpr
+                         (funName <> " regs oversat ")
+                          + rs
+                          + jString " remain: "
+                          + rsRemain)
+           , saveRegs rs
+           , sp |= sp + rsRemain + 1
+           , stack .! sp |= var "h$apply" .! ((rsRemain.<<.8).|. toJExpr n - mask8 arity)
+           , profStat s pushRestoreCCS
+           , returnS c
+           ]
+          where
+            saveRegs n = SwitchStat n switchAlts mempty
+              where
+                switchAlts = map (\x -> (toJExpr x, stack .! (sp + toJExpr (r-x)) |= toJExpr (intToJSReg (x+2)))) [0..r-1]
+
+zeroApply :: StgToJSConfig -> JStat
+zeroApply s = mconcat
+  [ TxtI "h$ap_0_0_fast" ||= jLam (enter s r1)
+  , closure (ClosureInfo "h$ap_0_0" (CIRegs 0 [PtrV]) "h$ap_0_0" (CILayoutFixed 0 []) CIStackFrame mempty)
+    (adjSpN' 1 <> enter s r1)
+  , TxtI "h$e" ||= jLam (\c -> (r1 |= c) <> enter s c)
+  ]
+
+-- carefully enter a closure that might be a thunk or a function
+
+-- ex may be a local var, but must've been copied to R1 before calling this
+enter :: StgToJSConfig -> JExpr -> JStat
+enter s ex = jVar \c ->
+  [ jwhenS (app "typeof" [ex] .!==. jTyObject) returnStack
+  , c |= closureEntry ex
+  , jwhenS (c .===. var "h$unbox_e") ((r1 |= closureExtra1 ex) <> returnStack)
+  , SwitchStat (entryClosureType c)
+    [ (toJExpr Con, mempty)
+    , (toJExpr Fun, mempty)
+    , (toJExpr Pap, returnStack)
+    , (toJExpr Blackhole, push' s [var "h$ap_0_0", ex, var "h$return"]
+        <> returnS (app "h$blockOnBlackhole" [ex]))
+    ] (returnS c)
+  ]
+
+updates :: StgToJSConfig -> JStat
+updates s = BlockStat
+  [ closure
+      (ClosureInfo "h$upd_frame" (CIRegs 0 [PtrV]) "h$upd_frame" (CILayoutFixed 1 [PtrV]) CIStackFrame mempty)
+      $ jVar \updatee waiters ss si sir ->
+            let unbox_closure = Closure
+                  { clEntry  = var "h$unbox_e"
+                  , clExtra1 = sir
+                  , clExtra2 = null_
+                  , clMeta   = 0
+                  , clCC     = Nothing
+                  }
+                updateCC updatee = closureCC updatee |= jCurrentCCS
+            in [ updatee |= stack .! (sp - 1)
+               , traceRts s (jString "h$upd_frame updatee alloc: " + updatee .^ "alloc")
+               , -- wake up threads blocked on blackhole
+                 waiters |= closureExtra2 updatee
+               , jwhenS (waiters .!==. null_)
+                           (loop 0 (.<. waiters .^ "length")
+                              (\i -> appS "h$wakeupThread" [waiters .! i] <> postIncrS i))
+               , -- update selectors
+                 jwhenS ((app "typeof" [closureMeta updatee] .===. jTyObject) .&&. (closureMeta updatee .^ "sel"))
+                 ((ss |= closureMeta updatee .^ "sel")
+                   <> loop 0 (.<. ss .^ "length") \i -> mconcat
+                        [ si |= ss .! i
+                        , sir |= (closureExtra2 si) `ApplExpr` [r1]
+                        , ifS (app "typeof" [sir] .===. jTyObject)
+                            (copyClosure DontCopyCC si sir)
+                            (assignClosure si unbox_closure)
+                        , postIncrS i
+                        ])
+               , -- overwrite the object
+                 ifS (app "typeof" [r1] .===. jTyObject)
+                     (mconcat [ traceRts s (jString "$upd_frame: boxed: " + ((closureEntry r1) .^ "n"))
+                              , copyClosure DontCopyCC updatee r1
+                              ])
+                     (assignClosure updatee unbox_closure)
+               , profStat s (updateCC updatee)
+               , adjSpN' 2
+               , traceRts s (jString "h$upd_frame: updating: "
+                             + updatee
+                             + jString " -> "
+                             + r1)
+               , returnStack
+               ]
+
+   , closure
+      (ClosureInfo "h$upd_frame_lne" (CIRegs 0 [PtrV]) "h$upd_frame_lne" (CILayoutFixed 1 [PtrV]) CIStackFrame mempty)
+      $ jVar \updateePos ->
+          [ updateePos |= stack .! (sp - 1)
+          , (stack .! updateePos |= r1)
+          , adjSpN' 2
+          , traceRts s (jString "h$upd_frame_lne: updating: "
+                         + updateePos
+                         + jString " -> "
+                         + r1)
+          , returnStack
+          ]
+  ]
+
+selectors :: StgToJSConfig -> JStat
+selectors s =
+  mkSel "1"      closureExtra1
+  <> mkSel "2a"  closureExtra2
+  <> mkSel "2b"  (closureExtra1 . closureExtra2)
+  <> mconcat (map mkSelN [3..16])
+   where
+    mkSelN :: Int -> JStat
+    mkSelN x = mkSel (pack $ show x)
+                     (\e -> SelExpr (closureExtra2 (toJExpr e))
+                            (TxtI $ pack ("d" ++ show (x-1))))
+
+
+    mkSel :: ShortText -> (JExpr -> JExpr) -> JStat
+    mkSel name sel = mconcat
+      [TxtI createName ||= jLam \r -> mconcat
+          [ traceRts s (toJExpr ("selector create: " <> name <> " for ") + (r .^ "alloc"))
+          , ifS (isThunk r .||. isBlackhole r)
+              (returnS (app "h$mkSelThunk" [r, toJExpr (v entryName), toJExpr (v resName)]))
+              (returnS (sel r))
+          ]
+      , TxtI resName ||= jLam \r -> mconcat
+          [ traceRts s (toJExpr ("selector result: " <> name <> " for ") + (r .^ "alloc"))
+          , returnS (sel r)
+          ]
+      , closure
+        (ClosureInfo entryName (CIRegs 0 [PtrV]) ("select " <> name) (CILayoutFixed 1 [PtrV]) CIThunk mempty)
+        (jVar \tgt ->
+          [ tgt |= closureExtra1 r1
+          , traceRts s (toJExpr ("selector entry: " <> name <> " for ") + (tgt .^ "alloc"))
+          , ifS (isThunk tgt .||. isBlackhole tgt)
+              (preIncrS sp
+               <> (stack .! sp |= var frameName)
+               <> returnS (app "h$e" [tgt]))
+              (returnS (app "h$e" [sel tgt]))
+          ])
+      , closure
+        (ClosureInfo frameName (CIRegs 0 [PtrV]) ("select " <> name <> " frame") (CILayoutFixed 0 []) CIStackFrame mempty)
+        $ mconcat [ traceRts s (toJExpr ("selector frame: " <> name))
+                  , postDecrS sp
+                  , returnS (app "h$e" [sel r1])
+                  ]
+      ]
+
+      where
+         v x   = JVar (TxtI x)
+         n ext =  "h$c_sel_" <> name <> ext
+         createName = n ""
+         resName    = n "_res"
+         entryName  = n "_e"
+         frameName  = n "_frame_e"
+
+
+-- arity is the remaining arity after our supplied arguments are applied
+mkPap :: StgToJSConfig
+      -> Ident   -- ^ id of the pap object
+      -> JExpr   -- ^ the function that's called (can be a second pap)
+      -> JExpr   -- ^ number of arguments in pap
+      -> [JExpr] -- ^ values for the supplied arguments
+      -> JStat
+mkPap s tgt fun n values =
+      traceRts s (toJExpr $ "making pap with: " ++ show (length values) ++ " items")
+      `mappend`
+      allocDynamic s True tgt (toJExpr entry) (fun:papAr:map toJExpr values')
+        (if csProf s then Just jCurrentCCS else Nothing)
+  where
+    papAr = funOrPapArity fun Nothing - toJExpr (length values * 256) - n
+
+    values' | GHC.Prelude.null values = [null_]
+            | otherwise   = values
+    entry | length values > numSpecPap = TxtI "h$pap_gen"
+          | otherwise                  = specPapIdents ! length values
+
+-- | Number of specialized PAPs (pre-generated for a given number of args)
+numSpecPap :: Int
+numSpecPap = 6
+
+-- specialized (faster) pap generated for [0..numSpecPap]
+-- others use h$pap_gen
+specPap :: [Int]
+specPap = [0..numSpecPap]
+
+-- | Cache of specialized PAP idents
+specPapIdents :: Array Int Ident
+specPapIdents = listArray (0,numSpecPap) $ map (TxtI . pack . ("h$pap_"++) . show) specPap
+
+pap :: StgToJSConfig
+    -> Int
+    -> JStat
+pap s r = closure (ClosureInfo funcName CIRegsUnknown funcName (CILayoutUnknown (r+2)) CIPap mempty) body
+  where
+    funcName = pack ("h$pap_" ++ show r)
+
+    body = jVar \c d f extra ->
+             [ c |= closureExtra1 r1
+             , d |= closureExtra2 r1
+             , f |= closureEntry  c
+             , assertRts s (isFun' f .||. isPap' f) (funcName <> ": expected function or pap")
+             , profStat s (enterCostCentreFun currentCCS)
+             , extra |= (funOrPapArity c (Just f) .>>. 8) - toJExpr r
+             , traceRts s (toJExpr (funcName <> ": pap extra args moving: ") + extra)
+             , moveBy extra
+             , loadOwnArgs d
+             , r1 |= c
+             , returnS f
+             ]
+    moveBy extra = SwitchStat extra
+                   (reverse $ map moveCase [1..maxReg-r-1]) mempty
+    moveCase m = (toJExpr m, toJExpr (intToJSReg (m+r+1)) |= toJExpr (intToJSReg (m+1)))
+    loadOwnArgs d = mconcat $ map (\r ->
+        toJExpr (intToJSReg (r+1)) |= dField d (r+2)) [1..r]
+    dField d n = SelExpr d (TxtI . pack $ ('d':show (n-1)))
+
+-- Construct a generic PAP
+papGen :: StgToJSConfig -> JStat
+papGen cfg =
+   closure (ClosureInfo funcName CIRegsUnknown funcName CILayoutVariable CIPap mempty)
+           (jVar \c f d pr or r ->
+              [ c |= closureExtra1 r1
+              , d |= closureExtra2 r1
+              , f |= closureEntry  c
+              , pr |= funOrPapArity c (Just f) .>>. 8
+              , or |= papArity r1 .>>. 8
+              , r |= pr - or
+              , assertRts cfg
+                (isFun' f .||. isPap' f)
+                (jString "h$pap_gen: expected function or pap")
+              , profStat cfg (enterCostCentreFun currentCCS)
+              , traceRts cfg (jString "h$pap_gen: generic pap extra args moving: " + or)
+              , appS "h$moveRegs2" [or, r]
+              , loadOwnArgs d r
+              , r1 |= c
+              , returnS f
+              ])
+
+
+  where
+    funcName = "h$pap_gen"
+    loadOwnArgs d r =
+      let prop n = d .^ ("d" <> pack (show $ n+1))
+          loadOwnArg n = (toJExpr n, toJExpr (intToJSReg (n+1)) |= prop n)
+      in  SwitchStat r (map loadOwnArg [127,126..1]) mempty
+
+-- general utilities
+-- move the first n registers, starting at R2, m places up (do not use with negative m)
+-- FIXME (Jeff, 2022/03): pick a better name, e.g., `r2moveRegs`
+moveRegs2 :: JStat
+moveRegs2 = TxtI "h$moveRegs2" ||= jLam moveSwitch
+  where
+    moveSwitch n m = SwitchStat ((n .<<. 8) .|. m) switchCases (defaultCase n m)
+    -- fast cases
+    -- TODO: tune the parameteters for performance and size
+    switchCases = [switchCase n m | n <- [1..5], m <- [1..4]]
+    switchCase :: Int -> Int -> (JExpr, JStat)
+    switchCase n m = (toJExpr $
+                      (n `Bits.shiftL` 8) Bits..|. m
+                     , mconcat (map (`moveRegFast` m) [n+1,n..2])
+                       <> BreakStat Nothing {-[j| break; |]-})
+    moveRegFast n m = toJExpr (intToJSReg (n+m)) |= toJExpr (intToJSReg n)
+    -- fallback
+    defaultCase n m =
+      loop n (.>.0) (\i -> appS "h$setReg" [i+1+m, app "h$getReg" [i+1]] `mappend` postDecrS i)
+
+
+-- Initalize a variable sized object from an array of values
+initClosure :: StgToJSConfig -> JExpr -> JExpr -> JExpr -> JExpr
+initClosure cfg entry values ccs =
+  let cc | csProf cfg = Just ccs
+         | otherwise  = Nothing
+  in app "h$init_closure" [ newClosure $ Closure
+                              { clEntry  = entry
+                              , clExtra1 = null_
+                              , clExtra2 = null_
+                              , clMeta   = 0
+                              , clCC     = cc
+                              }
+                          , values
+                          ]
+
+-- FIXME: where to put this
+closure :: ClosureInfo -- ^ object being info'd see @ciVar@ in @ClosureInfo@
+        -> JStat       -- ^ rhs
+        -> JStat
+closure ci body = (TxtI (ciVar ci)||= jLam body) `mappend` toStat ci
+
+-- FIXME: where to put this
+conClosure :: ShortText -> ShortText -> CILayout -> Int -> JStat
+conClosure symbol name layout constr =
+  closure (ClosureInfo symbol (CIRegs 0 [PtrV]) name layout (CICon constr) mempty)
+          (returnS (stack .! sp))
diff --git a/compiler/GHC/StgToJS/Rts/Rts.hs b/compiler/GHC/StgToJS/Rts/Rts.hs
new file mode 100644
index 0000000000..519518832c
--- /dev/null
+++ b/compiler/GHC/StgToJS/Rts/Rts.hs
@@ -0,0 +1,712 @@
+{-# 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>
+-- 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...
+--
+-- FIXME: Jeff (2022,03): Finish module description. Specifically:
+-- 1. Since this is the top level module for the RTS, what is the architecture
+-- of the RTS? How does it all hold together? Describe the memory layout, any
+-- other tricks the RTS plays, and relevant sibling modules
+-- Sylvain (2022/03): memory layout is described in GHC.StgToJS (WIP)
+--
+-----------------------------------------------------------------------------
+
+module GHC.StgToJS.Rts.Rts where
+
+import GHC.Prelude
+
+import GHC.JS.Syntax
+import GHC.JS.Make
+import GHC.JS.Transform
+
+import GHC.StgToJS.Heap
+import GHC.StgToJS.Monad
+import GHC.StgToJS.Profiling
+import GHC.StgToJS.Regs
+import GHC.StgToJS.Types
+import GHC.StgToJS.Rts.Apply
+
+import qualified GHC.Data.ShortText as T
+
+import Data.Array
+import Data.Monoid
+import Data.Char (toLower, toUpper)
+import qualified Data.Bits          as Bits
+import qualified Data.Map           as M
+
+
+-----------------------------------------------------------------------------
+--
+-- Pre-generated RTS for the JS backend
+--
+-- TODO: Jeff (2022,03):
+
+-- 1. There are numerous string literals sprinkled throughout the RTS, these
+-- should be moved and isolated into a single module and then used throughout
+-- the RTS and StgToJS Pipeline
+--
+-- 2. The RTS makes a lot of use of the Monoid instances on lists since the
+-- Haskell portion is essentially building a JavaScript AST for the JS Rts and
+-- then pretty printing it so it can be used by the js backend. However, all
+-- this merging on lists is going to be extremely inefficient. (++) is O(n^2)
+-- and furthermore we have nested list structures. This implies a better data
+-- structure with an emphasis on fast merging is likely to reduce compile times
+-- for this RTS.
+--
+-- 3. Similar to (2), most of the RTS is a function foo :: <something> with
+-- definition foo [...<something>...] = mconcat ...<the body is JS land>... This
+-- is fine, however it implies a monadic design for this EDSL might lead to more
+-- readable code. Or in other words, `mconcat` and friends are just boiler
+-- plate, and what we really have is a monadic EDSL where the monad is a kind of
+-- Writer monad. Which we have essentially recreated here since bind in the
+-- Writer monad is mapConcat and you'll notice that most of the functions in the
+-- RTS do exactly that, i.e., apply a function which generates a list, then
+-- concats. So we are dealing with a Writer monad but aren't using Haskell's
+-- language facilities to be explicit about it. Hence all the boilerplate. Side
+-- note, we might also consider two alternative approaches if we go with a
+-- monadic design:
+-- -- a. Continuation passing style so that intermediate lists fuse
+-- -- b. A writer monad with a difference list, this would essentially be a
+-- -- zipper but whether it is worth it or not depend on how often children need
+-- -- to access their siblings, if they do that a lot then we'll have huge
+-- -- speedups, if not then we likely won't gain anything
+
+-----------------------------------------------------------------------------
+
+garbageCollector :: JStat
+garbageCollector =
+  mconcat [ TxtI "h$resetRegisters"  ||= jLam (mconcat $ map resetRegister [minBound..maxBound])
+          , TxtI "h$resetResultVars" ||= jLam (mconcat $ map resetResultVar [minBound..maxBound])
+          ]
+
+
+resetRegister :: StgReg -> JStat
+resetRegister r = toJExpr r |= null_
+
+resetResultVar :: StgRet -> JStat
+resetResultVar r = toJExpr r |= null_
+
+{-
+  use h$c1, h$c2, h$c3, ... h$c24 instead of making objects manually so layouts
+  and fields can be changed more easily
+ -}
+closureConstructors :: StgToJSConfig -> JStat
+closureConstructors s = BlockStat
+  [ declClsConstr "h$c" ["f"] $ Closure
+      { clEntry  = var "f"
+      , clExtra1 = null_
+      , clExtra2 = null_
+      , clMeta   = 0
+      , clCC     = ccVal
+      }
+    -- FIXME: same as h$c, maybe remove one of them?
+  , declClsConstr "h$c0" ["f"] $ Closure
+      { clEntry  = var "f"
+      , clExtra1 = null_
+      , clExtra2 = null_
+      , clMeta   = 0
+      , clCC     = ccVal
+      }
+  , declClsConstr "h$c1" ["f", "x1"] $ Closure
+      { clEntry  = var "f"
+      , clExtra1 = var "x1"
+      , clExtra2 = null_
+      , clMeta   = 0
+      , clCC     = ccVal
+      }
+  , declClsConstr "h$c2" ["f", "x1", "x2"] $ Closure
+      { clEntry  = var "f"
+      , clExtra1 = var "x1"
+      , clExtra2 = var "v2"
+      , clMeta   = 0
+      , clCC     = ccVal
+      }
+  , mconcat (map mkClosureCon [3..24])
+  , mconcat (map mkDataFill [1..24])
+  ]
+  where
+    prof = csProf s
+    (ccArg,ccVal)
+      -- the cc argument happens to be named just like the cc field...
+      | prof      = ([TxtI closureCC_], Just (var closureCC_))
+      | otherwise = ([], Nothing)
+    addCCArg as = map TxtI as ++ ccArg
+    addCCArg' as = as ++ ccArg
+
+    declClsConstr i as cl = TxtI i ||= ValExpr (JFunc (addCCArg as)
+      ( jVar $ \x ->
+          [ checkC
+          , x |= newClosure cl
+          , notifyAlloc x
+          , traceAlloc x
+          , returnS x
+          ]
+         ))
+
+    traceAlloc x | csTraceRts s = appS "h$traceAlloc" [x]
+                 | otherwise    = mempty
+
+    notifyAlloc x | csDebugAlloc s = appS "h$debugAlloc_notifyAlloc" [x]
+                  | otherwise      = 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 | csAssertRts s =
+      jVar $ \msg ->
+      jwhenS (var "arguments" .! 0 .!==. jString "h$ghcjszmprimZCGHCJSziPrimziJSVal_con_e")
+                                  (loop 1 (.<. var "arguments" .^ "length")
+                                          (\i ->
+                                             mconcat [msg |= jString "warning: undefined or null in argument: "
+                                                       + i
+                                                       + jString " allocating closure: " + (var "arguments" .! 0 .^ "n")
+                                                     , appS "h$log" [msg]
+                                                     , jwhenS (var "console" .&&. (var "console" .^ "trace")) ((var "console" .^ "trace") `ApplStat` [msg])
+                                                     , postIncrS i
+                                                     ])
+
+                                  )
+           | otherwise = 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 | csAssertRts s =
+                     loop 0 (.<. var "arguments" .^ "length")
+                     (\i -> jwhenS ((var "arguments" .! i .===. null_)
+                                    .||. (var "arguments" .! i .===. undefined_))
+                            (jVar $ \msg ->
+                                mconcat [ msg |= jString "warning: undefined or null in argument: " + i + jString " allocating fields"
+                                        , jwhenS (var "console" .&&. (var "console" .^ "trace"))
+                                                ((var "console" .^ "trace") `ApplStat` [msg])
+                                        ]))
+
+           | otherwise = mempty
+
+    mkClosureCon :: Int -> JStat
+    mkClosureCon n = funName ||= toJExpr fun
+      where
+        funName = TxtI $ T.pack ("h$c" ++ show n) -- FIXME (Sylvain 2022-03): cache this
+        -- args are: f x1 x2 .. xn [cc]
+        args   = TxtI "f" : addCCArg' (map (TxtI . T.pack . ('x':) . show) [(1::Int)..n])
+        fun    = JFunc args funBod
+        -- x1 goes into closureExtra1. All the other args are bundled into an
+        -- object in closureExtra2: { d1 = x2, d2 = x3, ... }
+        --
+        -- FIXME (Sylvain 2022-03): share code and comment with mkDataFill
+        extra_args = ValExpr . JHash . M.fromList $ zip
+                   -- FIXME (Sylvain 2002-03): use dataFieldCache and another
+                   -- cache for "xN" names
+                   (map (T.pack . ('d':) . show) [(1::Int)..])
+                   (map (toJExpr . TxtI . T.pack . ('x':) . show) [2..n])
+
+        funBod = jVar $ \x ->
+            [ checkC
+            , x |= newClosure Closure
+               { clEntry  = var "f"
+               , clExtra1 = var "x1"
+               , clExtra2 = extra_args
+               , clMeta   = 0
+               , clCC     = ccVal
+               }
+            , notifyAlloc x
+            , traceAlloc x
+            , returnS x
+            ]
+
+    mkDataFill :: Int -> JStat
+    mkDataFill n = funName ||= toJExpr fun
+      where
+        -- FIXME (Sylvain 2002-03): use dataFieldCache and dataCache
+        funName    = TxtI $ T.pack ("h$d" ++ show n)
+        ds         = map (T.pack . ('d':) . show) [(1::Int)..n]
+        extra_args = ValExpr . JHash . M.fromList . zip ds $ map (toJExpr . TxtI) ds
+        fun        = JFunc (map TxtI ds) (checkD <> returnS extra_args)
+
+stackManip :: JStat
+stackManip = mconcat (map mkPush [1..32]) <>
+             mconcat (map mkPpush [1..255])
+  where
+    mkPush :: Int -> JStat
+    mkPush n = let funName = TxtI $ T.pack ("h$p" ++ show n)
+                   as      = map (TxtI . T.pack . ('x':) . show) [1..n]
+                   fun     = JFunc as ((sp |= sp + toJExpr n)
+                                       <> mconcat (zipWith (\i a -> stack .! (sp - toJExpr (n-i)) |= toJExpr a)
+                                                   [1..] as))
+               in funName ||= toJExpr fun
+
+    -- | partial pushes, based on bitmap, increases Sp by highest bit
+    mkPpush :: Integer -> JStat
+    mkPpush sig | sig Bits..&. (sig+1) == 0 = mempty -- already handled by h$p
+    mkPpush sig = let funName = TxtI $ T.pack ("h$pp" ++ show sig)
+                      bits    = bitsIdx sig
+                      n       = length bits
+                      h       = last bits
+                      args    = map (TxtI . T.pack . ('x':) . show) [1..n]
+                      fun     = JFunc args $
+                        mconcat [ sp |= sp + toJExpr (h+1)
+                                , mconcat (zipWith (\b a -> stack .! (sp - toJExpr (h-b)) |= toJExpr a) bits args)
+                                ]
+                   in funName ||= toJExpr fun
+
+bitsIdx :: Integer -> [Int]
+bitsIdx n | n < 0 = error "bitsIdx: negative"
+          | otherwise = go n 0
+  where
+    go 0 _ = []
+    go m b | Bits.testBit m b = b : go (Bits.clearBit m b) (b+1)
+           | otherwise   = go (Bits.clearBit m b) (b+1)
+
+bhLneStats :: StgToJSConfig -> JExpr -> JExpr -> JStat
+bhLneStats _s p frameSize =
+   jVar $ \v ->
+            mconcat [ v |= stack .! p
+                    , ifS v
+                      ((sp |= sp - frameSize)
+                       <> ifS (v .===. var "h$blackhole")
+                                (returnS $ app "h$throw" [var "h$baseZCControlziExceptionziBasezinonTermination", false_])
+                                (mconcat [r1 |= v
+                                         , sp |= sp - frameSize
+                                         , returnStack
+                                         ]))
+                      ((stack .! p |= var "h$blackhole") <> returnS null_)
+                    ]
+
+
+-- FIXME move somewhere else
+declRegs :: JStat
+-- FIXME prevent holes
+declRegs =
+  mconcat [ TxtI "h$regs" ||= toJExpr (JList [])
+          , mconcat (map declReg (enumFromTo R1 R32))
+          , regGettersSetters
+          , loadRegs
+          ]
+    where
+      declReg r = (decl . TxtI . T.pack . ("h$"++) . map toLower . show) r
+                  <> BlockStat [AssignStat (toJExpr r) (ValExpr (JInt 0))] -- [j| `r` = 0; |]
+
+regGettersSetters :: JStat
+regGettersSetters =
+  mconcat [ TxtI "h$getReg" ||= jLam (\n   -> SwitchStat n getRegCases mempty)
+          , TxtI "h$setReg" ||= jLam (\n v -> SwitchStat n (setRegCases v) mempty)
+          ]
+  where
+    getRegCases =
+      map (\r -> (toJExpr (jsRegToInt r) , returnS (toJExpr r))) (enumFrom R1)
+    setRegCases v =
+      map (\r -> (toJExpr (jsRegToInt r), (toJExpr r |= toJExpr v) <> returnS undefined_)) (enumFrom R1)
+
+loadRegs :: JStat
+loadRegs = mconcat $ map mkLoad [1..32]
+  where
+    mkLoad :: Int -> JStat
+    mkLoad n = let args   = map (TxtI . T.pack . ("x"++) . show) [1..n]
+                   assign = zipWith (\a r -> toJExpr r |= toJExpr a)
+                                -- FIXME: Jeff (2022,03) the use of reverse,
+                                -- take, and enumFrom here heavily implies
+                                -- Data.Sequence would be a better data
+                                -- structure to hold the regs. Or perhaps we
+                                -- steal the indices from the registers array?
+                                -- Either way we can avoid allocating this
+                                -- intermediate `enumFrom R1` list
+                              args (reverse $ take n (enumFrom R1))
+                   fname  = TxtI $ T.pack ("h$l" ++ show n)
+                   fun    = JFunc args (mconcat assign)
+               in fname ||= toJExpr fun
+
+-- assign registers R1 ... Rn
+-- assigns Rn first
+assignRegs :: StgToJSConfig -> [JExpr] -> JStat
+assignRegs _ [] = mempty
+assignRegs s xs
+  | l <= 32 && not (csInlineLoadRegs s)
+      = ApplStat (ValExpr (JVar $ assignRegs'!l)) (reverse xs)
+  | otherwise = mconcat . reverse $
+      zipWith (\r ex -> toJExpr r |= ex) (take l $ enumFrom R1) xs
+  where
+    l = length xs
+
+assignRegs' :: Array Int Ident
+assignRegs' = listArray (1,32) (map (TxtI . T.pack . ("h$l"++) . show) [(1::Int)..32])
+
+declRets :: JStat
+declRets = mconcat $ map (decl . TxtI . T.pack . ("h$"++) . map toLower . show) (enumFrom Ret1)
+
+trace :: ToJExpr a => a -> JStat
+trace ex = appS "h$log" [toJExpr ex]
+
+closureTypes :: JStat
+closureTypes = mconcat (map mkClosureType (enumFromTo minBound maxBound)) <> closureTypeName
+  where
+    mkClosureType :: ClosureType -> JStat
+    mkClosureType c = let s = TxtI . T.pack $ "h$" ++ map toUpper (show c) ++ "_CLOSURE"
+                      in  s ||= toJExpr c
+    closureTypeName :: JStat
+    closureTypeName =
+      TxtI "h$closureTypeName" ||= jLam (\c ->
+                                           mconcat (map (ifCT c) [minBound..maxBound])
+                                          <> returnS (jString "InvalidClosureType"))
+
+    ifCT :: JExpr -> ClosureType -> JStat
+    ifCT arg ct = jwhenS (arg .===. toJExpr ct) (returnS (toJExpr (show ct)))
+
+rtsDecls :: JStat
+rtsDecls = jsSaturate (Just "h$RTSD") $
+  mconcat [ TxtI "h$currentThread"   ||= null_                   -- thread state object for current thread
+          , TxtI "h$stack"           ||= null_                   -- stack for the current thread
+          , TxtI "h$sp"              ||= 0                       -- stack pointer for the current thread
+          , TxtI "h$initStatic"      ||= toJExpr (JList [])      -- we need delayed initialization for static objects, push functions here to be initialized just before haskell runs
+          , TxtI "h$staticThunks"    ||= toJExpr (jhFromList []) --  funcName -> heapidx map for srefs
+          , TxtI "h$staticThunksArr" ||= toJExpr (JList [])      -- indices of updatable thunks in static heap
+          -- stg registers
+          , declRegs
+          , declRets]
+
+rts :: StgToJSConfig -> JStat
+rts = jsSaturate (Just "h$RTS") . rts'
+
+rts' :: StgToJSConfig -> JStat
+rts' s =
+  mconcat [ closureConstructors s
+          , garbageCollector
+          , stackManip
+          -- settings (FIXME should be const)
+          , TxtI "h$rts_traceForeign" ||= toJExpr (csTraceForeign s)
+          , TxtI "h$rts_profiling"    ||= toJExpr (csProf s)
+          -- closure types (FIXME should be const)
+          , TxtI "h$ct_fun"        ||= toJExpr Fun
+          , TxtI "h$ct_con"        ||= toJExpr Con
+          , TxtI "h$ct_thunk"      ||= toJExpr Thunk
+          , TxtI "h$ct_pap"        ||= toJExpr Pap
+          , TxtI "h$ct_blackhole"  ||= toJExpr Blackhole
+          , TxtI "h$ct_stackframe" ||= toJExpr StackFrame
+          -- var / closure field types (FIXME should be const)
+          , TxtI "h$vt_ptr"    ||= toJExpr PtrV
+          , TxtI "h$vt_void"   ||= toJExpr VoidV
+          , TxtI "h$vt_double" ||= toJExpr IntV
+          , TxtI "h$vt_long"   ||= toJExpr LongV
+          , TxtI "h$vt_addr"   ||= toJExpr AddrV
+          , TxtI "h$vt_rtsobj" ||= toJExpr RtsObjV
+          , TxtI "h$vt_obj"    ||= toJExpr ObjV
+          , TxtI "h$vt_arr"    ||= toJExpr ArrV
+          , TxtI "h$bh"        ||= jLam (bhStats s True)
+          , TxtI "h$bh_lne"    ||= jLam (\x frameSize -> bhLneStats s x frameSize)
+          , closure (ClosureInfo "h$blackhole" (CIRegs 0 []) "blackhole" (CILayoutUnknown 2) CIBlackhole mempty)
+               (appS "throw" [jString "oops: entered black hole"])
+          , closure (ClosureInfo "h$blackholeTrap" (CIRegs 0 []) "blackhole" (CILayoutUnknown 2) CIThunk mempty)
+               (appS "throw" [jString "oops: entered multiple times"])
+          , closure (ClosureInfo "h$done" (CIRegs 0 [PtrV]) "done" (CILayoutUnknown 0) CIStackFrame mempty)
+               (appS "h$finishThread" [var "h$currentThread"] <> returnS (var "h$reschedule"))
+          , closure (ClosureInfo "h$doneMain_e" (CIRegs 0 [PtrV]) "doneMain" (CILayoutUnknown 0) CIStackFrame mempty)
+               (returnS (var "h$doneMain"))
+          , conClosure "h$false_e" "GHC.Types.False" (CILayoutFixed 0 []) 1
+          , conClosure "h$true_e"  "GHC.Types.True"  (CILayoutFixed 0 []) 2
+          , conClosure "h$integerzmwiredzminZCGHCziIntegerziTypeziSzh_con_e" "GHC.Integer.Type.S#" (CILayoutFixed 1 [IntV]) 1
+          , conClosure "h$integerzmwiredzminZCGHCziIntegerziTypeziJpzh_con_e" "GHC.Integer.Type.Jp#" (CILayoutFixed 1 [ObjV]) 2
+          , conClosure "h$integerzmwiredzminZCGHCziIntegerziTypeziJnzh_con_e" "GHC.Integer.Type.Jn#" (CILayoutFixed 1 [ObjV]) 3
+          -- generic data constructor with 1 non-heapobj field
+          , conClosure "h$data1_e" "data1" (CILayoutFixed 1 [ObjV]) 1
+          -- generic data constructor with 2 non-heapobj fields
+          , conClosure "h$data2_e" "data2" (CILayoutFixed 2 [ObjV,ObjV]) 1
+          , closure (ClosureInfo "h$noop_e" (CIRegs 1 [PtrV]) "no-op IO ()" (CILayoutFixed 0 []) (CIFun 1 0) mempty)
+               (returnS (stack .! sp))
+            <> (TxtI "h$noop" ||= ApplExpr (var "h$c0") (var "h$noop_e" : [jSystemCCS | csProf s]))
+          , closure (ClosureInfo "h$catch_e" (CIRegs 0 [PtrV]) "exception handler" (CILayoutFixed 2 [PtrV,IntV]) CIStackFrame mempty)
+               (adjSpN' 3 <> returnS (stack .! sp))
+          , closure (ClosureInfo "h$dataToTag_e" (CIRegs 0 [PtrV]) "data to tag" (CILayoutFixed 0 []) CIStackFrame mempty)
+                $ mconcat [ r1 |= if_ (r1 .===. true_) 1 (if_ (typeof r1 .===. jTyObject) (r1 .^ "f" .^ "a" - 1) 0)
+                          , adjSpN' 1
+                          , returnS (stack .! sp)
+                          ]
+          -- function application to one argument
+          , closure (ClosureInfo "h$ap1_e" (CIRegs 0 [PtrV]) "apply1" (CILayoutFixed 2 [PtrV, PtrV]) CIThunk mempty)
+               (jVar $ \d1 d2 ->
+                   mconcat [ d1 |= closureExtra1 r1
+                           , d2 |= closureExtra2 r1
+                           , appS "h$bh" []
+                           , profStat s enterCostCentreThunk
+                           , r1 |= d1
+                           , r2 |= d2
+                           , returnS (app "h$ap_1_1_fast" [])
+                           ])
+          -- function application to two arguments
+          , closure (ClosureInfo "h$ap2_e" (CIRegs 0 [PtrV]) "apply2" (CILayoutFixed 3 [PtrV, PtrV, PtrV]) CIThunk mempty)
+               (jVar $ \d1 d2 d3 ->
+                   mconcat [ d1 |= closureExtra1 r1
+                           , d2 |= closureExtra2 r1 .^ "d1" -- FIXME (Sylvain 2022-03): extra args are named like closureExtraN... not so good! Find something else
+                           , d3 |= closureExtra2 r1 .^ "d2"
+                           , appS "h$bh" []
+                           , profStat s enterCostCentreThunk
+                           , r1 |= d1
+                           , r2 |= d2
+                           , r3 |= d3
+                           , returnS (app "h$ap_2_2_fast" [])
+                           ])
+          -- function application to three arguments
+          , closure (ClosureInfo "h$ap3_e" (CIRegs 0 [PtrV]) "apply3" (CILayoutFixed 4 [PtrV, PtrV, PtrV, PtrV]) CIThunk mempty)
+               (jVar $ \d1 d2 d3 d4 ->
+                   mconcat [ d1 |= closureExtra1 r1
+                           , d2 |= closureExtra2 r1 .^ "d1"
+                           , d3 |= closureExtra2 r1 .^ "d2"
+                           , d4 |= closureExtra2 r1 .^ "d3"
+                           , appS "h$bh" []
+                           , r1 |= d1
+                           , r2 |= d2
+                           , r3 |= d3
+                           , r4 |= d4
+                           , returnS (app "h$ap_3_3_fast" [])
+                           ])
+          -- select first field
+          , closure (ClosureInfo "h$select1_e" (CIRegs 0 [PtrV]) "select1" (CILayoutFixed 1 [PtrV]) CIThunk mempty)
+               (jVar $ \t ->
+                   mconcat [ t |= closureExtra1 r1
+                           , adjSp' 3
+                           , stack .! (sp - 2) |= r1
+                           , stack .! (sp - 1) |= var "h$upd_frame"
+                           , stack .! sp |= var "h$select1_ret"
+                           , closureEntry  r1 |= var "h$blackhole"
+                           , closureExtra1 r1 |= var "h$currentThread"
+                           , closureExtra2 r1 |= null_
+                           , r1 |= t
+                           , returnS (app "h$ap_0_0_fast" [])
+                           ])
+          , closure (ClosureInfo "h$select1_ret" (CIRegs 0 [PtrV]) "select1ret" (CILayoutFixed 0 []) CIStackFrame mempty)
+               ((r1 |= closureExtra1 r1)
+                <> adjSpN' 1
+                <> returnS (app "h$ap_0_0_fast" [])
+               )
+          -- select second field of a two-field constructor
+          , closure (ClosureInfo "h$select2_e" (CIRegs 0 [PtrV]) "select2" (CILayoutFixed 1 [PtrV]) CIThunk mempty)
+               (jVar $ \t ->
+                   mconcat [t |= closureExtra1 r1
+                           , adjSp' 3
+                           , stack .! (sp - 2) |= r1
+                           , stack .! (sp - 1) |= var "h$upd_frame"
+                           , stack .! sp |= var "h$select2_ret"
+                           , closureEntry  r1 |= var "h$blackhole"
+                           , closureExtra1 r1 |= var "h$currentThread"
+                           , closureExtra2 r1 |= null_
+                           , r1 |= t
+                           , returnS (app "h$ap_0_0_fast" [])
+                           ]
+                  )
+          , closure (ClosureInfo "h$select2_ret" (CIRegs 0 [PtrV]) "select2ret" (CILayoutFixed 0 []) CIStackFrame mempty)
+                        $ mconcat [ r1 |= closureExtra2 r1
+                                  , adjSpN' 1
+                                  , returnS (app "h$ap_0_0_fast" [])
+                                  ]
+          -- a thunk that just raises a synchronous exception
+          , closure (ClosureInfo "h$raise_e" (CIRegs 0 [PtrV]) "h$raise_e" (CILayoutFixed 0 []) CIThunk mempty)
+               (returnS (app "h$throw" [closureExtra1 r1, false_]))
+          , closure (ClosureInfo "h$raiseAsync_e" (CIRegs 0 [PtrV]) "h$raiseAsync_e" (CILayoutFixed 0 []) CIThunk mempty)
+               (returnS  (app "h$throw" [closureExtra1 r1, true_]))
+          , closure (ClosureInfo "h$raiseAsync_frame" (CIRegs 0 []) "h$raiseAsync_frame" (CILayoutFixed 1 []) CIStackFrame mempty)
+               (jVar $ \ex ->
+                   mconcat [ ex |= stack .! (sp - 1)
+                           , adjSpN' 2
+                           , returnS (app "h$throw" [ex, 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
+          -}
+          , closure (ClosureInfo "h$reduce" (CIRegs 0 [PtrV]) "h$reduce" (CILayoutFixed 0 []) CIStackFrame mempty)
+               (ifS (isThunk r1)
+                    (returnS (r1 .^ "f"))
+                    (adjSpN' 1 <> returnS (stack .! sp))
+               )
+          , rtsApply s
+          , closureTypes
+          , closure (ClosureInfo "h$runio_e" (CIRegs 0 [PtrV]) "runio" (CILayoutFixed 1 [PtrV]) CIThunk mempty)
+                        $ mconcat [ r1 |= closureExtra1 r1
+                                  , stack .! PreInc sp |= var "h$ap_1_0"
+                                  , returnS (var "h$ap_1_0")
+                                  ]
+          , closure (ClosureInfo "h$flushStdout_e" (CIRegs 0 []) "flushStdout" (CILayoutFixed 0 []) CIThunk mempty)
+                        $ mconcat [ r1 |= var "h$baseZCGHCziIOziHandlezihFlush"
+                                  , r2 |= var "h$baseZCGHCziIOziHandleziFDzistdout"
+                                  , returnS (app "h$ap_1_1_fast" [])
+                                  ]
+          , TxtI "h$flushStdout" ||= app "h$static_thunk" [var "h$flushStdout_e"]
+          -- the scheduler pushes this frame when suspending a thread that
+          -- has not called h$reschedule explicitly
+          , closure (ClosureInfo "h$restoreThread" (CIRegs 0 []) "restoreThread" CILayoutVariable CIStackFrame mempty)
+                (jVar $ \f frameSize nregs ->
+                    mconcat [f |= stack .! (sp - 2)
+                            , frameSize |= stack .! (sp - 1)
+                            , nregs |= frameSize - 3
+                            , loop 1 (.<=. nregs)
+                                     (\i -> appS "h$setReg" [i, stack .! (sp - 2 - i)] <> postIncrS i)
+                            , sp |= sp - frameSize
+                            , returnS f
+                            ])
+          -- return a closure in the stack frame to the next thing on the stack
+          , closure (ClosureInfo "h$return" (CIRegs 0 []) "return" (CILayoutFixed 1 [PtrV]) CIStackFrame mempty)
+                ((r1 |= stack .! (sp - 1))
+                 <> adjSpN' 2
+                 <> returnS (stack .! sp))
+          --  return a function in the stack frame for the next call
+          , closure (ClosureInfo "h$returnf" (CIRegs 0 [PtrV]) "returnf" (CILayoutFixed 1 [ObjV]) CIStackFrame mempty)
+                (jVar $ \r ->
+                    mconcat [ r |= stack .! (sp - 1)
+                            , adjSpN' 2
+                            , returnS 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
+          , closure (ClosureInfo "h$reschedule" (CIRegs 0 []) "reschedule" (CILayoutFixed 0 []) CIThunk mempty)
+                (returnS $ var "h$reschedule")
+          -- debug thing, insert on stack to dump current result, should be boxed
+          , closure (ClosureInfo "h$dumpRes" (CIRegs 0 [PtrV]) "dumpRes" (CILayoutFixed 1 [ObjV]) CIThunk mempty)
+                (jVar $ \re ->
+                    mconcat [ appS "h$log" [jString "h$dumpRes result: " + stack .! (sp-1)]
+                            , appS "h$log" [r1]
+                            , appS "h$log" [app "h$collectProps" [r1]]
+                            , jwhenS ((r1 .^ "f") .&&. (r1 .^ "f" .^ "n"))
+                                        (appS "h$log" [jString "name: " + r1 .^ "f" .^ "n"])
+                            , jwhenS (ApplExpr (r1 .^ "hasOwnProperty") [jString closureExtra1_])
+                                        (appS "h$log" [jString "d1: " + closureExtra1 r1])
+                            , jwhenS (ApplExpr (r1 .^ "hasOwnProperty") [jString closureExtra2_])
+                                        (appS "h$log" [jString "d2: " + closureExtra2 r1])
+                            , jwhenS (r1 .^ "f") $ mconcat
+                                [ re |= New (app "RegExp" [jString "([^\\n]+)\\n(.|\\n)*"])
+                                , appS "h$log" [jString "function"
+                                                + ApplExpr (ApplExpr ((jString "" + r1 .^ "f") .^ "substring") [0, 50] .^ "replace") [r1, jString "$1"]]
+                                ]
+                            , adjSpN' 2
+                            , r1 |= null_
+                            , returnS (stack .! sp)
+                            ])
+          , closure (ClosureInfo "h$resume_e" (CIRegs 0 [PtrV]) "resume" (CILayoutFixed 0 []) CIThunk mempty)
+                  (jVar $ \ss ->
+                      mconcat [ss |= closureExtra1 r1
+                              , updateThunk' s
+                              , loop 0 (.<. ss .^ "length") (\i -> (stack .! (sp+1+i) |= ss .! i)
+                                                                   <> postIncrS i)
+                              , sp |= sp + ss .^ "length"
+                              , r1 |= null_
+                              , returnS (stack .! sp)
+                              ])
+          , closure (ClosureInfo "h$unmaskFrame" (CIRegs 0 [PtrV]) "unmask" (CILayoutFixed 0 []) CIStackFrame mempty)
+               ((var "h$currentThread" .^ "mask" |= 0)
+                <> adjSpN' 1
+                -- back to scheduler to give us async exception if pending
+                <> ifS (var "h$currentThread" .^ "excep" .^ "length" .>. 0)
+                    (push' s [r1, var "h$return"] <> returnS (var "h$reschedule"))
+                    (returnS (stack .! sp)))
+          , closure (ClosureInfo "h$maskFrame" (CIRegs 0 [PtrV]) "mask" (CILayoutFixed 0 []) CIStackFrame mempty)
+                ((var "h$currentThread" .^ "mask" |= 2)
+                 <> adjSpN' 1
+                 <> returnS (stack .! sp))
+          , closure (ClosureInfo "h$maskUnintFrame" (CIRegs 0 [PtrV]) "maskUnint" (CILayoutFixed 0 []) CIStackFrame mempty)
+                ((var "h$currentThread" .^ "mask" |= 1)
+                 <> adjSpN' 1
+                 <> returnS (stack .! sp))
+          , closure (ClosureInfo "h$unboxFFIResult" (CIRegs 0 [PtrV]) "unboxFFI" (CILayoutFixed 0 []) CIStackFrame mempty)
+               (jVar $ \d ->
+                   mconcat [d |= closureExtra1 r1
+                           , loop 0 (.<. d .^ "length") (\i -> appS "h$setReg" [i + 1, d .! i] <> postIncrS i)
+                           , adjSpN' 1
+                           , returnS (stack .! sp)
+                           ])
+          , closure (ClosureInfo "h$unbox_e" (CIRegs 0 [PtrV]) "unboxed value" (CILayoutFixed 1 [DoubleV]) CIThunk mempty)
+               ((r1 |= closureExtra1 r1) <> returnS (stack .! sp))
+          , closure (ClosureInfo "h$retryInterrupted" (CIRegs 0 [ObjV]) "retry interrupted operation" (CILayoutFixed 1 [ObjV]) CIStackFrame mempty)
+               (jVar $ \a ->
+                   mconcat [ a |= stack .! (sp - 1)
+                           , adjSpN' 2
+                           , returnS (ApplExpr (a .! 0 .^ "apply") [var "this", ApplExpr (a .^ "slice") [1]])
+                           ])
+          , closure (ClosureInfo "h$atomically_e" (CIRegs 0 [PtrV]) "atomic operation" (CILayoutFixed 1 [PtrV]) CIStackFrame mempty)
+               (ifS (app "h$stmValidateTransaction" [])
+                    (appS "h$stmCommitTransaction" []
+                     <> adjSpN' 2
+                     <> returnS (stack .! sp))
+                    (push' s [var "h$checkInvariants_e"]
+                     <> returnS (app "h$stmStartTransaction" [stack .! (sp - 2)])))
+          , closure (ClosureInfo "h$checkInvariants_e" (CIRegs 0 [PtrV]) "check transaction invariants" (CILayoutFixed 0 []) CIStackFrame mempty)
+               (adjSpN' 1
+                <> returnS (app "h$stmCheckInvariants" []))
+          , closure (ClosureInfo "h$stmCheckInvariantStart_e" (CIRegs 0 []) "start checking invariant" (CILayoutFixed 2 [ObjV, RtsObjV]) CIStackFrame mempty)
+                        (jVar $ \t inv m t1 ->
+                            mconcat [ t   |= stack .! (sp - 2)
+                                    , inv |= stack .! (sp - 1)
+                                    , m   |= var "h$currentThread" .^ "mask"
+                                    , adjSpN' 3
+                                    , t1  |= UOpExpr NewOp (app "h$Transaction" [inv .^ "action", t])
+                                    , t1 .^ "checkRead" |= UOpExpr NewOp (app "h$Set" [])
+                                    , var "h$currentTread" .^ "transaction" |= t1
+                                    , push' s [t1, m, var "h$stmInvariantViolatedHandler", var "h$catchStm_e"]
+                                    , r1  |= inv .^ "action"
+                                    , returnS (app "h$ap_1_0_fast" [])
+                                    ])
+          , closure (ClosureInfo "h$stmCheckInvariantResult_e" (CIRegs 0 [PtrV]) "finish checking invariant" (CILayoutFixed 1 [ObjV]) CIStackFrame mempty)
+                        (jVar $ \inv ->
+                            mconcat [ inv |= stack .! (sp -1)
+                                    , adjSpN' 2
+                                    , appS "h$stmUpdateInvariantDependencies" [inv]
+                                    , appS "h$stmAbortTransaction" []
+                                    , returnS (stack .! sp)
+                                    ])
+
+          -- update invariant TVar dependencies and rethrow exception
+          -- handler must be pushed above h$stmCheckInvariantResult_e frame
+          , closure (ClosureInfo "h$stmInvariantViolatedHandler_e" (CIRegs 0 [PtrV]) "finish checking invariant" (CILayoutFixed 0 []) (CIFun 2 1) mempty)
+                        (jVar $ \inv ->
+                            mconcat [ jwhenS (stack .! sp .===. var "h$stmCheckInvariantResult_e")
+                                                (appS "throw" [jString "h$stmInvariantViolatedHandler_e: unexpected value on stack"])
+                                    , inv |= stack .! (sp - 2)
+                                    , adjSpN' 2
+                                    , appS "h$stmUpdateInvariantDependencies" []
+                                    , appS "h$stmAbortTransaction" []
+                                    , returnS (app "h$throw" [r2, false_])
+                                    ])
+          , TxtI "h$stmInvariantViolatedHandler" ||= app "h$c" (var "h$stmInvariantViolatedHandler_e" : [jSystemCCS | csProf s])
+          , closure (ClosureInfo "h$stmCatchRetry_e" (CIRegs 0 [PtrV]) "catch retry" (CILayoutFixed 1 [PtrV]) CIStackFrame mempty)
+                        (adjSpN' 2
+                         <> appS "h$stmCommitTransaction" []
+                         <> returnS (stack .! sp))
+          , closure (ClosureInfo "h$catchStm_e" (CIRegs 0 [PtrV]) "STM catch" (CILayoutFixed 3 [ObjV,PtrV,ObjV]) CIStackFrame mempty)
+                       (adjSpN' 4 <> returnS (stack .! sp))
+          , closure (ClosureInfo "h$stmResumeRetry_e" (CIRegs 0 [PtrV]) "resume retry" (CILayoutFixed 0 []) CIStackFrame mempty)
+                        (jVar $ \blocked ->
+                            mconcat [ jwhenS (stack .! (sp - 2) .!==. var "h$atomically_e")
+                                                 (appS "throw" [jString "h$stmResumeRetry_e: unexpected value on stack"])
+                                    , blocked |= stack .! (sp - 1)
+                                    , adjSpN' 2
+                                    , push' s [var "h$checkInvariants_e"]
+                                    , appS "h$stmRemoveBlockedThread" [blocked, var "h$currentThread"]
+                                    , returnS (app "h$stmStartTransaction" [stack .! (sp - 2)])
+                                    ])
+          , closure (ClosureInfo "h$lazy_e" (CIRegs 0 [PtrV]) "generic lazy value" (CILayoutFixed 0 []) CIThunk mempty)
+                        (jVar $ \x ->
+                            mconcat [x |= ApplExpr (closureExtra1 r1) []
+                                    , appS "h$bh" []
+                                    , profStat s enterCostCentreThunk
+                                    , r1 |= x
+                                    , returnS (stack .! sp)
+                                    ])
+          -- Top-level statements to generate only in profiling mode
+          , profStat s (closure (ClosureInfo "h$setCcs_e" (CIRegs 0 [PtrV]) "set cost centre stack" (CILayoutFixed 1 [ObjV]) CIStackFrame mempty)
+                        (appS "h$restoreCCS" [ stack .! (sp - 1)]
+                         <> adjSpN' 2
+                         <> returnS (stack .! sp)))
+          ]
diff --git a/compiler/GHC/StgToJS/Rts/Types.hs b/compiler/GHC/StgToJS/Rts/Types.hs
new file mode 100644
index 0000000000..db6868a5ea
--- /dev/null
+++ b/compiler/GHC/StgToJS/Rts/Types.hs
@@ -0,0 +1,105 @@
+{-# LANGUAGE CPP,
+             FlexibleInstances,
+             OverloadedStrings #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  GHC.StgToJS.Rts.Apply
+-- Copyright   :  (c) The University of Glasgow 2001
+-- License     :  BSD-style (see the file LICENSE)
+--
+-- Maintainer  :  Jeffrey Young  <jeffrey.young@iohk.io>
+--                Luite Stegeman <luite.stegeman@iohk.io>
+--                Sylvain Henry  <sylvain.henry@iohk.io>
+-- Stability   :  experimental
+--
+-- Types and utility functions used in the JS RTS.
+-- FIXME: Jeff (2022,03): Add more details
+-----------------------------------------------------------------------------
+
+module GHC.StgToJS.Rts.Types where
+
+import GHC.Prelude
+
+import GHC.JS.Make
+import GHC.JS.Syntax
+import GHC.StgToJS.Regs
+import GHC.StgToJS.Types
+
+import GHC.Utils.Monad.State.Strict
+import qualified GHC.Data.ShortText as T
+
+
+
+traceRts :: StgToJSConfig -> JExpr -> JStat
+traceRts s ex = jStatIf (csTraceRts s) (appS "h$log" [ex])
+
+assertRts :: ToJExpr a => StgToJSConfig -> JExpr -> a -> JStat
+assertRts s ex m = jStatIf (csAssertRts s)
+  (jwhenS (UOpExpr NotOp ex) (appS "throw" [toJExpr m]))
+
+jStatIf :: Bool -> JStat -> JStat
+jStatIf True s = s
+jStatIf _    _ = mempty
+
+clName :: JExpr -> JExpr
+clName c = c .^ "n"
+
+clTypeName :: JExpr -> JExpr
+clTypeName c = app "h$closureTypeName" [c .^ "t"]
+
+type C = State GenState JStat
+
+assertRtsStat :: C -> C
+assertRtsStat stat = do
+  s <- gets gsSettings
+  if csAssertRts s then stat else return mempty
+
+-- number of  arguments (arity & 0xff = arguments, arity >> 8 = number of registers)
+stackFrameSize :: JExpr -- ^ assign frame size to this
+               -> JExpr -- ^ stack frame header function
+               -> JStat -- ^ size of the frame, including header
+stackFrameSize tgt f =
+  ifS (f .===. var "h$ap_gen") -- h$ap_gen is special
+      (tgt |= (stack .! (sp - 1) .>>. 8) + 2)  -- special case, FIXME (Jeff, 2022/03): what and why is
+                                               -- it special and how does its
+                                               -- special-ness change this code
+      (jVar (\tag ->
+               mconcat
+               [tag |= f .^ "size"
+               , ifS (tag .<. 0)              -- if tag is less than 0
+                 (tgt |= stack .! (sp - 1))   -- set target to stack pointer - 1
+                 (tgt |= mask8 tag + 1)       -- else set to mask'd tag + 1
+               ]
+        ))
+
+-- some utilities do do something with a range of regs
+-- start or end possibly supplied as javascript expr
+withRegs :: StgReg -> StgReg -> (StgReg -> JStat) -> JStat
+withRegs start end f = mconcat $ map f [start..end]
+
+withRegs' :: StgReg -> StgReg -> (StgReg -> JStat) -> JStat
+withRegs' start end = withRegs start end
+
+-- start from js expr, start is guaranteed to be at least min
+-- from low to high (fallthrough!)
+withRegsS :: JExpr -> StgReg -> StgReg -> Bool -> (StgReg -> JStat) -> JStat
+withRegsS start min end fallthrough f =
+  SwitchStat start (map mkCase [min..end]) mempty
+    where
+      brk | fallthrough = mempty
+          | otherwise   = BreakStat Nothing
+      mkCase r = let stat = f r
+                  in (toJExpr r, mconcat [stat , stat , brk])
+
+-- end from js expr, from high to low
+withRegsRE :: StgReg -> JExpr -> StgReg -> Bool -> (StgReg -> JStat) -> JStat
+withRegsRE start end max fallthrough f =
+  SwitchStat end (reverse $ map mkCase [start..max]) mempty
+    where
+      brk | fallthrough = mempty
+          | otherwise   = BreakStat Nothing
+      mkCase r = (toJExpr (fromEnum r), mconcat [f r , brk])
+
+jsVar :: String -> JExpr
+jsVar = ValExpr . JVar . TxtI . T.pack