compiler/GHC/Builtin/primops.txt.pp

@@ -1852,6 +1852,70 @@ section "Byte Arrays"
 
 ------------------------------------------------------------------------
 
+-- Note [Byte arrays outside of the HEAP_ALLOCED space]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- It is useful to be able to allocate byte arrays outside of the heap,
+-- i.e. outside of the memory space covered by the HEAP_ALLOCED() test.
+--
+-- There are two major use cases (see issue #17747):
+--
+--  1. Having foreign memory appear as a normal GHC byte array. This
+--     are use cases similar to the use of a ForeignPtr, but where it
+--     is useful to have the representation be a byte array type, for
+--     easier interoperability with existing libraries.
+--
+--  2. Static byte arrays in object files for constant values.
+--
+-- The second is not yet available as it requires additional support
+-- from the code gen.
+--
+-- An example of the first category can be seen in GHC test T17747.
+-- A concrete use-case is to memory map a file
+-- but have it appear as a ByteArray# rather than a ForeignPtr. Doing
+-- so of course requires that space is reserved immediately before the
+-- file data for the byte array heap object header. See the
+-- placeByteArray# primop documentation below and the FFI section of
+-- the user guide for more details.
+--
+-- To have the first use-case work requires a few things:
+--
+-- * For the GC to not fail when it encounters byte arrays outside of
+--   the HEAP_ALLOCED space. This is straightforward because the GC
+--   has support for a number of different closure types to appear
+--   outside the heap (primarily for statically allocated values), and
+--   byte arrays are easy because they contain no heap pointers. See
+--   the reference back to this note in `evacuate(StgClosure **p)` in
+--   `rts/sm/Evac.c`
+--
+-- * For all other byte array primops (e.g. shrinkMutableByteArray#,
+--   sameMutableByteArray#, isByteArrayPinned#, etc.) to not fail when
+--   encountering byte arrays outside of the heap. Specifically
+--   isByteArrayPinned# requires special support. This is currently the
+--   only primop that needs special support.
+--   See Note [isByteArrayPinned# support for off heap byte arrays].
+--
+-- * A mechanism to set up the heap object header for a byte array at
+--   an address outside of the HEAP_ALLOCED space. This is needed to
+--   make the foreign allocated memory look like a byte array. This is
+--   provided by the placeByteArray# primop.
+--
+
+-- Note [isByteArrayPinned# support for off heap byte arrays]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- The isByteArrayPinned# primop is implemented by reading block descriptor
+-- flags. Since off heap byte arrays don't have block descriptors,
+-- isByteArrayPinned# must explicitly check if the byte array is HEAP_ALLOCED
+-- or not. If not HEAP_ALLOCED then it is certainly pinned. This requires CMM
+-- support for the HEAP_ALLOCED test, which is otherwise only called from C
+-- code in the RTS. The current design is to provide full CMM
+-- implementations of HEAP_ALLOCED enabled in `rts/storage/HeapAlloc.h` with the
+-- CMINUSMINUS cpp flag. This includes HEAP_ALLOCED_CALLISH which essentially
+-- duplicates what is already a complex C implementation. This is fast
+-- but an alternative would be to use a CMM C call to a C function that use
+-- the existing C implementation of HEAP_ALLOCED.
+
+
 primtype ByteArray#
 {
   A boxed, unlifted datatype representing a region of raw memory in the garbage-collected heap,
@@ -1902,6 +1966,20 @@ primop  NewByteArrayOp_Char "newByteArray#" GenPrimOp
    with out_of_line = True
         effect = ReadWriteEffect
 
+-- See [Byte arrays outside of the HEAP_ALLOCED space]
+primop  PlaceByteArrayOp_Char "placeByteArray#" GenPrimOp
+   Addr# -> Int# -> State# s -> (# State# s, MutableByteArray# s #)
+   {Place a new byte array header at the specified address outside of the heap,
+   for the specified payload size (in bytes), in the specified state thread. In
+   C code with `#include "Rts.h"`, use `sizeOf(StgArrBytes)` or
+   `sizeOfW(StgArrBytes)` to get the size of a byte array header in bytes or
+   words respectively. The caller must ensure `sizeof(StgArrBytes) + n` bytes of
+   space is allocated at the give address for the heap object header followed by
+   n bytes of payload. See the FFI section of the user guide for more details
+   on how to use this primop.}
+   with out_of_line = True
+        effect = ReadWriteEffect
+
 primop  NewPinnedByteArrayOp_Char "newPinnedByteArray#" GenPrimOp
    Int# -> State# s -> (# State# s, MutableByteArray# s #)
    {Like 'newByteArray#' but GC guarantees not to move it.}

compiler/GHC/JS/Ident.hs

@@ -34,25 +34,29 @@
 
 module GHC.JS.Ident
   ( Ident(..)
-  , global
+  , name
   ) where
 
-import Prelude
+import GHC.Prelude
 
 import GHC.Data.FastString
 import GHC.Types.Unique
+import GHC.Utils.Outputable
 
 --------------------------------------------------------------------------------
 --                            Identifiers
 --------------------------------------------------------------------------------
--- We use FastString for identifiers in JS backend
 
 -- | A newtype wrapper around 'FastString' for JS identifiers.
 newtype Ident = TxtI { identFS :: FastString }
  deriving stock   (Show, Eq)
- deriving newtype (Uniquable)
+ deriving newtype (Uniquable, Outputable)
 
--- | A not-so-smart constructor for @Ident@s, used to indicate that this name is
--- expected to be top-level
-global :: FastString -> Ident
-global = TxtI
+-- | To give a thing a name is to have power over it. This smart constructor
+-- serves two purposes: first, it isolates the JS backend from the rest of GHC.
+-- The backend should not explicitly use types provided by GHC but instead
+-- should wrap them such as we do here. Second it creates a symbol in the JS
+-- backend, but it does not yet give that symbols meaning. Giving the symbol
+-- meaning only occurs once it is used with a combinator from @GHC.JS.Make@.
+name :: FastString -> Ident
+name = TxtI

compiler/GHC/JS/JStg/Monad.hs

@@ -92,7 +92,7 @@ newIdent = do env <- get
               return  $ mk_ident tag id
 
 mk_ident :: FastString -> Unique -> Ident
-mk_ident t i = global (mconcat [t, "_", mkFastString (show i)])
+mk_ident t i = name (mconcat [t, "_", mkFastString (show i)])
 
 -- | Set the tag for @Ident@s for all remaining computations.
 tag_names :: FastString -> JSM ()

compiler/GHC/JS/JStg/Syntax.hs

@@ -28,6 +28,10 @@
 --     is written in. Nothing fancy, its just a straightforward deeply embedded
 --     DSL.
 --
+--     In general, one should not use these constructors explicitly in the JS
+--     backend. Instead, prefer using the combinators in GHC.JS.Make, if those
+--     are suitable then prefer using the patterns exported from this module
+
 -----------------------------------------------------------------------------
 module GHC.JS.JStg.Syntax
   ( -- * Deeply embedded JS datatypes
@@ -63,7 +67,8 @@ module GHC.JS.JStg.Syntax
   -- * Utility
   , SaneDouble(..)
   , pattern Func
-  , var
+  , global
+  , local
   ) where
 
 import GHC.Prelude
@@ -233,7 +238,6 @@ pattern LOr x y = InfixExpr LOrOp x y
 pattern LAnd :: JStgExpr -> JStgExpr -> JStgExpr
 pattern LAnd x y = InfixExpr LAndOp x y
 
-
 -- | pattern synonym to create integer values
 pattern Int :: Integer -> JStgExpr
 pattern Int x = ValExpr (JInt x)
@@ -328,6 +332,10 @@ data AOp
 
 instance NFData AOp
 
--- | construct a JS variable reference
-var :: FastString -> JStgExpr
-var = Var . global
+-- | construct a JS reference, intended to refer to a global name
+global :: FastString -> JStgExpr
+global = Var . name
+
+-- | construct a JS reference, intended to refer to a local name
+local :: FastString -> JStgExpr
+local = Var . name

compiler/GHC/JS/Make.hs

@@ -107,11 +107,10 @@ module GHC.JS.Make
   , off8, off16, off32, off64
   , mask8, mask16
   , signExtend8, signExtend16
-  , typeof
+  , typeOf
   , returnStack, assignAllEqual, assignAll, assignAllReverseOrder
   , declAssignAll
   , nullStat, (.^)
-  , trace
   -- ** Hash combinators
   , jhEmpty
   , jhSingle
@@ -182,8 +181,8 @@ instance ToJExpr () where
     toJExpr _ = ValExpr $ JList []
 
 instance ToJExpr Bool where
-    toJExpr True  = var "true"
-    toJExpr False = var "false"
+    toJExpr True  = global "true"
+    toJExpr False = global "false"
 
 instance ToJExpr JVal where
     toJExpr = ValExpr
@@ -376,7 +375,7 @@ jTryCatchFinally :: (Ident -> JStgStat) -> (Ident -> JStgStat) -> (Ident -> JStg
 jTryCatchFinally c f f2 = do i <- newIdent
                              return $ TryStat (c i) i (f i) (f2 i)
 
--- | Convert a ShortText to a Javascript String
+-- | Convert a FastString to a Javascript String
 jString :: FastString -> JStgExpr
 jString = toJExpr
 
@@ -447,8 +446,8 @@ infixl 8 .||., .&&.
 infixl 9 .<<., .>>., .>>>.
 
 -- | Given a 'JStgExpr', return the its type.
-typeof :: JStgExpr -> JStgExpr
-typeof = UOpExpr TypeofOp
+typeOf :: JStgExpr -> JStgExpr
+typeOf = UOpExpr TypeofOp
 
 -- | JS if-expression
 --
@@ -494,15 +493,15 @@ if10 e = IfExpr e one_ zero_
 if01 :: JStgExpr -> JStgExpr
 if01 e = IfExpr e zero_ one_
 
--- | an expression application, see related 'appS'
+-- | an application expression, see related 'appS'
 --
 -- > app f xs ==> f(xs)
 app :: FastString -> [JStgExpr] -> JStgExpr
-app f xs = ApplExpr (var f) xs
+app f xs = ApplExpr (global f) xs
 
 -- | A statement application, see the expression form 'app'
 appS :: FastString -> [JStgExpr] -> JStgStat
-appS f xs = ApplStat (var f) xs
+appS f xs = ApplStat (global f) xs
 
 -- | Return a 'JStgExpr'
 returnS :: JStgExpr -> JStgStat
@@ -577,7 +576,7 @@ signExtend16 x = (BAnd x (Int 0x7FFF)) `Sub` (BAnd x (Int 0x8000))
 --
 -- > obj .^ prop ==> obj.prop
 (.^) :: JStgExpr -> FastString -> JStgExpr
-obj .^ prop = SelExpr obj (global prop)
+obj .^ prop = SelExpr obj (name prop)
 infixl 8 .^
 
 -- | Assign a variable to an expression
@@ -614,9 +613,6 @@ assignAllReverseOrder xs ys = mconcat (reverse (zipWith (|=) xs ys))
 declAssignAll :: [Ident] -> [JStgExpr] -> JStgStat
 declAssignAll xs ys = mconcat (zipWith (||=) xs ys)
 
-trace :: ToJExpr a => a -> JStgStat
-trace ex = appS "h$log" [toJExpr ex]
-
 
 --------------------------------------------------------------------------------
 --                             Literals
@@ -627,7 +623,7 @@ trace ex = appS "h$log" [toJExpr ex]
 
 -- | The JS literal 'null'
 null_ :: JStgExpr
-null_ = var "null"
+null_ = global "null"
 
 -- | The JS literal 0
 zero_ :: JStgExpr
@@ -647,7 +643,7 @@ three_ = Int 3
 
 -- | The JS literal 'undefined'
 undefined_ :: JStgExpr
-undefined_ = var "undefined"
+undefined_ = global "undefined"
 
 -- | The JS literal 'true'
 true_ :: JStgExpr
@@ -658,7 +654,7 @@ false_ :: JStgExpr
 false_ = ValExpr (JBool False)
 
 returnStack :: JStgStat
-returnStack = ReturnStat (ApplExpr (var "h$rs") [])
+returnStack = ReturnStat (ApplExpr (global "h$rs") [])
 
 
 --------------------------------------------------------------------------------
@@ -669,7 +665,7 @@ returnStack = ReturnStat (ApplExpr (var "h$rs") [])
 -- is the sole math introduction function.
 
 math :: JStgExpr
-math = var "Math"
+math = global "Math"
 
 math_ :: FastString -> [JStgExpr] -> JStgExpr
 math_ op args = ApplExpr (math .^ op) args

compiler/GHC/JS/Syntax.hs

@@ -341,7 +341,7 @@ instance NFData AOp
 
 -- | construct a JS variable reference
 var :: FastString -> JExpr
-var = Var . global
+var = Var . name
 
 -- | The JS literal 'true'
 true_ :: JExpr

compiler/GHC/StgToCmm/Prim.hs

@@ -1665,6 +1665,7 @@ emitPrimOp cfg primop =
   CasArrayOp -> alwaysExternal
   UnsafeThawSmallArrayOp -> alwaysExternal
   CasSmallArrayOp -> alwaysExternal
+  PlaceByteArrayOp_Char -> alwaysExternal
   NewPinnedByteArrayOp_Char -> alwaysExternal
   NewAlignedPinnedByteArrayOp_Char -> alwaysExternal
   MutableByteArrayIsPinnedOp -> alwaysExternal

compiler/GHC/StgToJS.hs

@@ -11,6 +11,23 @@ import GHC.StgToJS.CodeGen
 --
 -- StgToJS ("JS backend") is adapted from GHCJS [GHCJS2013].
 --
+-- Implementation Big Picture
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- The big picture of the JS backend is roughly:
+--
+-- JS Backend --> JStgExpr ----> JExpr
+--                                 |
+--                                 V
+-- STG -------------------------> JExpr --> Optimizations --> Code Gen
+--
+-- Why this design? Because we generate the RTS via an eDSL, if we accidentally
+-- create a bug in the RTS we will not find out until we have completely
+-- finished compiling and are running the testsuite. Thus having a typed eDSL
+-- with which we can write the RTS is beneficial because a type error will have
+-- a much faster turn around than building and then trying to debug a bunch of
+-- generated, z-encoded code.
+--
 -- Haskell to JavaScript
 -- ~~~~~~~~~~~~~~~~~~~~~
 -- StgToJS converts STG into a JavaScript AST (in GHC.JS) that has been adapted

compiler/GHC/StgToJS/Apply.hs

@@ -37,14 +37,15 @@ import GHC.StgToJS.Closure
 import GHC.StgToJS.DataCon
 import GHC.StgToJS.ExprCtx
 import GHC.StgToJS.Heap
+import GHC.StgToJS.Ids
 import GHC.StgToJS.Monad
-import GHC.StgToJS.Types
 import GHC.StgToJS.Profiling
 import GHC.StgToJS.Regs
-import GHC.StgToJS.Utils
 import GHC.StgToJS.Rts.Types
 import GHC.StgToJS.Stack
-import GHC.StgToJS.Ids
+import GHC.StgToJS.Symbols
+import GHC.StgToJS.Types
+import GHC.StgToJS.Utils
 
 import GHC.Types.Id
 import GHC.Types.Id.Info
@@ -161,7 +162,7 @@ genApp ctx i args
       let ww = case concatMap typex_expr (ctxTarget ctx) of
                  [t] | csAssertRts settings ->
                          ifS (isObject t .&&. isThunk t)
-                             (appS "throw" [String "unexpected thunk"]) -- yuck
+                             (appS throwStr [String "unexpected thunk"]) -- yuck
                              mempty
                  _   -> mempty
       return (a `mappend` ww, ExprInline)
@@ -183,7 +184,7 @@ genApp ctx i args
                 _              -> panic "genApp: unexpected arg"
           if isStrictId a' || ctxIsEvaluated a'
             then return (t |= ai, ExprInline)
-            else return (returnS (app "h$e" [ai]), ExprCont)
+            else return (returnS (app (identFS hdEntry) [ai]), ExprCont)
         _ -> panic "genApp: invalid size"
 
     -- no args and Id can't be a function: just enter it
@@ -196,7 +197,7 @@ genApp ctx i args
                        [x] -> return x
                        xs  -> pprPanic "genApp: unexpected multi-var argument"
                                 (vcat [ppr (length xs), ppr i])
-      return (returnS (app "h$e" [enter_id]), ExprCont)
+      return (returnS (app (identFS hdEntry) [enter_id]), ExprCont)
 
     -- fully saturated global function:
     --  - deals with arguments
@@ -285,12 +286,12 @@ data ApplyConv
 -- | Name of the generic apply function
 genericApplyName :: ApplyConv -> FastString
 genericApplyName = \case
-  RegsConv  -> "h$ap_gen_fast"
-  StackConv -> "h$ap_gen"
+  RegsConv  -> identFS hdApGenFastStr
+  StackConv -> identFS hdApGenStr
 
 -- | Expr of the generic apply function
 genericApplyExpr :: ApplyConv -> JStgExpr
-genericApplyExpr conv = var (genericApplyName conv)
+genericApplyExpr conv = global (genericApplyName conv)
 
 
 -- | Return the name of the specialized apply function for the given number of
@@ -327,7 +328,7 @@ specApplyName = \case
 -- Warning: the returned function may not be generated! Use specApplyExprMaybe
 -- if you want to ensure that it exists.
 specApplyExpr :: ApplySpec -> JStgExpr
-specApplyExpr spec = var (specApplyName spec)
+specApplyExpr spec = global (specApplyName spec)
 
 -- | Return the expression of the specialized apply function for the given
 -- number of args, number of arg variables, and calling convention.
@@ -377,7 +378,7 @@ applySpec = [ ApplySpec conv nargs nvars
 --
 -- Warning: tag doesn't take into account the calling convention
 specTag :: ApplySpec -> Int
-specTag spec = Bits.shiftL (specVars spec) 8 Bits..|. (specArgs spec)
+specTag spec = Bits.shiftL (specVars spec) 8 Bits..|. specArgs spec
 
 -- | Generate a tag expression for the given ApplySpec
 specTagExpr :: ApplySpec -> JStgExpr
@@ -390,13 +391,13 @@ specTagExpr = toJExpr . specTag
 mkApplyArr :: JSM JStgStat
 mkApplyArr =
   do mk_ap_gens  <- jFor (|= zero_) (.<. Int 65536) preIncrS
-                    \j -> var "h$apply" .! j |= var "h$ap_gen"
+                    \j -> hdApply .! j |= hdApGen
      mk_pap_gens <- jFor (|= zero_) (.<. Int 128) preIncrS
-                    \j -> var "h$paps" .! j |= var "h$pap_gen"
+                    \j -> hdPaps .! j |=  hdPapGen
      return $ mconcat
-       [ global "h$apply" ||= toJExpr (JList [])
-       , global "h$paps"  ||= toJExpr (JList [])
-       , ApplStat (var "h$initStatic" .^ "push")
+       [ name hdApplyStr ||= toJExpr (JList [])
+       , name hdPapsStr  ||= toJExpr (JList [])
+       , ApplStat (hdInitStatic .^ "push")
          [ jLam' $
            mconcat
            [ mk_ap_gens
@@ -412,12 +413,13 @@ mkApplyArr =
       -- both fast/slow (regs/stack) specialized apply functions have the same
       -- tags. We store the stack ones in the array because they are used as
       -- continuation stack frames.
-      StackConv -> var "h$apply" .! specTagExpr spec |= specApplyExpr spec
+      StackConv -> hdApply .! specTagExpr spec |= specApplyExpr spec
       RegsConv  -> mempty
 
+    hdPap_ = unpackFS hdPapStr_
+
     assignPap :: Int -> JStgStat
-    assignPap p = var "h$paps" .! toJExpr p |=
-                      (var (mkFastString $ ("h$pap_" ++ show p)))
+    assignPap p = hdPaps .! toJExpr p |= global (mkFastString (hdPap_ ++ show p))
 
 -- | Push a continuation on the stack
 --
@@ -453,7 +455,7 @@ genericStackApply cfg = closure info body
          pap <- fun_case cf (papArity r1)
          return $
            mconcat $
-           [ traceRts cfg (jString "h$ap_gen")
+           [ traceRts cfg (jString $ identFS hdApGenStr)
            , cf |= closureInfo r1
            -- switch on closure type
            , SwitchStat (infoClosureType cf)
@@ -467,16 +469,16 @@ genericStackApply cfg = closure info body
 
     -- info table for h$ap_gen
     info = ClosureInfo
-      { ciVar     = global "h$ap_gen"
+      { ciVar     = hdApGenStr
       , ciRegs    = CIRegs 0 [PtrV] -- closure to apply to
-      , ciName    = "h$ap_gen"
+      , ciName    = identFS hdApGenStr
       , ciLayout  = CILayoutVariable
       , ciType    = CIStackFrame
       , ciStatic  = mempty
       }
 
-    default_case cf = appS "throw" [jString "h$ap_gen: unexpected closure type "
-                                    + (infoClosureType cf)]
+    default_case cf = appS throwStr [jString "h$ap_gen: unexpected closure type "
+                                     + (infoClosureType cf)]
 
     thunk_case cfg cf = mconcat
       [ profStat cfg pushRestoreCCS
@@ -484,8 +486,8 @@ genericStackApply cfg = closure info body
       ]
 
     blackhole_case cfg = mconcat
-      [ push' cfg [r1, var "h$return"]
-      , returnS (app "h$blockOnBlackhole" [r1])
+      [ push' cfg [r1, hdReturn]
+      , returnS (app hdBlockOnBlackHoleStr [r1])
       ]
 
     fun_case c arity = jVars \(tag, needed_args, needed_regs, given_args, given_regs, newTag, newAp, p, dat) ->
@@ -496,12 +498,12 @@ genericStackApply cfg = closure info body
          load_reg_values <- loop 0 (.<. needed_regs)
                             \i -> return $
                                   mconcat [ traceRts cfg (jString "h$ap_gen: loading register: " + i)
-                                          , appS "h$setReg" [ i+2 , stack .! (sp-2-i)]
+                                          , appS hdSetRegStr [ i+2 , stack .! (sp-2-i)]
                                           , postIncrS i
                                           ]
          set_reg_values <- loop 0 (.<. given_regs)
            \i -> return $
-                 mconcat [ appS "h$setReg" [ i+2, stack .! (sp-2-i)]
+                 mconcat [ appS hdSetRegStr [ i+2, stack .! (sp-2-i)]
                          , postIncrS i
                          ]
          return $
@@ -537,12 +539,12 @@ genericStackApply cfg = closure info body
                          -- compute new tag with consumed register values and args removed
                          , newTag |= ((given_regs-needed_regs).<<.8) .|. (given_args - needed_args)
                          -- find application function for the remaining regs/args
-                         , newAp |= var "h$apply" .! newTag
+                         , newAp |= hdApply .! newTag
                          , traceRts cfg (jString "h$ap_gen: next: " + (newAp .^ "n"))
 
                          -- Drop used registers from the stack.
                          -- Test if the application function needs a tag and push it.
-                         , ifS (newAp .===. var "h$ap_gen")
+                         , ifS (newAp .===. hdApGen )
                            ((sp |= sp - needed_regs) <> (stack .! (sp - 1) |= newTag))
                            (sp |= sp - needed_regs - 1)
 
@@ -561,7 +563,7 @@ genericStackApply cfg = closure info body
                          -----------------------------
                          [ traceRts cfg (jString "h$ap_gen: undersat")
                          -- find PAP entry function corresponding to given_regs count
-                         , p      |= var "h$paps" .! given_regs
+                         , p      |= hdPaps .! given_regs
 
                          -- build PAP payload: R1 + tag + given register values
                          , newTag |= ((needed_regs-given_regs) .<<. 8) .|. (needed_args-given_args)
@@ -590,7 +592,7 @@ genericStackApply cfg = closure info body
 --
 genericFastApply :: StgToJSConfig -> JSM JStgStat
 genericFastApply s =
-   jFunction (global "h$ap_gen_fast")
+   jFunction (name "h$ap_gen_fast")
    \(MkSolo tag) -> jVar $ \c ->
      do push_stk_app <- pushStackApply c tag
         fast_fun     <- jVar \farity ->
@@ -617,13 +619,13 @@ genericFastApply s =
             , (toJExpr Pap, fast_pap)
             , (toJExpr Con, traceRts s (jString "h$ap_gen_fast: con")
                 <> jwhenS (tag .!=. 0)
-                            (appS "throw" [jString "h$ap_gen_fast: invalid apply"])
+                            (appS throwStr [jString "h$ap_gen_fast: invalid apply"])
                             <> returnS c)
             , (toJExpr Blackhole, traceRts s (jString "h$ap_gen_fast: blackhole")
                 <> push_stk_app
-                <> push' s [r1, var "h$return"]
-                <> returnS (app "h$blockOnBlackhole" [r1]))
-            ] $ appS "throw" [jString "h$ap_gen_fast: unexpected closure type: " + infoClosureType c]
+                <> push' s [r1, hdReturn]
+                <> returnS (app hdBlockOnBlackHoleStr [r1]))
+            ] $ appS throwStr [jString "h$ap_gen_fast: unexpected closure type: " + infoClosureType c]
           ]
 
   where
@@ -634,8 +636,8 @@ genericFastApply s =
              do push_all_regs <- pushAllRegs tag
                 return $ mconcat $
                   [ push_all_regs
-                  , ap |= var "h$apply" .! tag
-                  , ifS (ap .===. var "h$ap_gen")
+                  , ap |= hdApply .! tag
+                  , ifS (ap .===. hdApGen)
                     ((sp |= sp + 2) <> (stack .! (sp-1) |= tag))
                     (sp |= sp + 1)
                   , stack .! sp |= ap
@@ -648,7 +650,7 @@ genericFastApply s =
 
         do get_regs <- loop 0 (.<. myRegs) $
              \i -> return $
-                   (dat .^ "push") `ApplStat` [app "h$getReg" [i+2]] <> postIncrS i
+                   (dat .^ "push") `ApplStat` [app hdGetRegStr [i+2]] <> postIncrS i
            push_args <- pushArgs regsStart myRegs
 
            return $ mconcat $
@@ -668,8 +670,8 @@ genericFastApply s =
                 , traceRts s (jString "h$ap_gen_fast: oversat " + sp)
                 , push_args
                 , newTag |= ((myRegs-( arity.>>.8)).<<.8).|.myAr-ar
-                , newAp |= var "h$apply" .! newTag
-                , ifS (newAp .===. var "h$ap_gen")
+                , newAp |= hdApply .! newTag
+                , ifS (newAp .===. hdApGen)
                   ((sp |= sp + 2) <> (stack .! (sp - 1) |= newTag))
                   (sp |= sp + 1)
                 , stack .! sp |= newAp
@@ -679,7 +681,7 @@ genericFastApply s =
                -- else
                 [traceRts s (jString "h$ap_gen_fast: undersat: " + myRegs + jString " " + tag)
                 , jwhenS (tag .!=. 0) $ mconcat
-                  [ p |= var "h$paps" .! myRegs
+                  [ p |= hdPaps .! myRegs
                   , dat |= toJExpr [r1, ((arity .>>. 8)-myRegs)*256+ar-myAr]
                   , get_regs
                   , r1 |= initClosure s p dat jCurrentCCS
@@ -705,7 +707,7 @@ genericFastApply s =
       loop end (.>=.start)
       \i -> return $
             traceRts s (jString "pushing register: " + i)
-            <> (stack .! (sp + start - i) |= app "h$getReg" [i+1])
+            <> (stack .! (sp + start - i) |= app hdGetRegStr [i+1])
             <> postDecrS i
 
 -- | Make specialized apply function for the given ApplySpec
@@ -730,7 +732,7 @@ stackApply s fun_name nargs nvars =
     else closure info body
   where
     info  = ClosureInfo
-              { ciVar = global fun_name
+              { ciVar = name fun_name
               , ciRegs = CIRegs 0 [PtrV]
               , ciName = fun_name
               , ciLayout = CILayoutUnknown nvars
@@ -738,7 +740,7 @@ stackApply s fun_name nargs nvars =
               , ciStatic = mempty
               }
     info0 = ClosureInfo
-              { ciVar = global fun_name
+              { ciVar = name fun_name
               , ciRegs = CIRegs 0 [PtrV]
               , ciName = fun_name
               , ciLayout = CILayoutFixed 0 []
@@ -762,8 +764,8 @@ stackApply s fun_name nargs nvars =
              [ (toJExpr Thunk, traceRts s (toJExpr $ fun_name <> ": thunk") <> profStat s pushRestoreCCS <> returnS c)
              , (toJExpr Fun, traceRts s (toJExpr $ fun_name <> ": fun") <> fun_case)
              , (toJExpr Pap, traceRts s (toJExpr $ fun_name <> ": pap") <> pap_case)
-             , (toJExpr Blackhole, push' s [r1, var "h$return"] <> returnS (app "h$blockOnBlackhole" [r1]))
-             ] (appS "throw" [toJExpr ("panic: " <> fun_name <> ", unexpected closure type: ") + (infoClosureType c)])
+             , (toJExpr Blackhole, push' s [r1, hdReturn] <> returnS (app hdBlockOnBlackHoleStr [r1]))
+             ] (appS throwStr [toJExpr ("panic: " <> fun_name <> ", unexpected closure type: ") + (infoClosureType c)])
            ]
 
     funExact c = popSkip 1 (reverse $ take nvars jsRegsFromR2) <> returnS c
@@ -824,7 +826,7 @@ stackApply s fun_name nargs nvars =
              [ rs |= (arity .>>. 8)
              , loadRegs rs
              , sp |= sp - rs
-             , newAp |= (var "h$apply" .! ((toJExpr nargs-arity0).|.((toJExpr nvars-rs).<<.8)))
+             , newAp |= (hdApply .! ((toJExpr nargs-arity0).|.((toJExpr nvars-rs).<<.8)))
              , stack .! sp |= newAp
              , profStat s pushRestoreCCS
              , traceRts s (toJExpr (fun_name <> ": new stack frame: ") + (newAp .^ "n"))
@@ -846,7 +848,7 @@ fastApply s fun_name nargs nvars = if nargs == 0 && nvars == 0
                                    -- general case
                                    else jFunction' func body
   where
-      func    = global fun_name
+      func    = name fun_name
       ap_fast :: JSM JStgStat
       ap_fast = enter s r1
 
@@ -869,8 +871,8 @@ fastApply s fun_name nargs nvars = if nargs == 0 && nvars == 0
                               <> fun_case_fun)
                ,(toJExpr Pap, traceRts s (toJExpr (fun_name <> ": pap")) <> (arity |= papArity r1) <> fun_case_pap)
                ,(toJExpr Thunk, traceRts s (toJExpr (fun_name <> ": thunk")) <> push' s (reverse regArgs ++ mkAp nargs nvars) <> profStat s pushRestoreCCS <> returnS c)
-               ,(toJExpr Blackhole, traceRts s (toJExpr (fun_name <> ": blackhole")) <> push' s (reverse regArgs ++ mkAp nargs nvars) <> push' s [r1, var "h$return"] <> returnS (app "h$blockOnBlackhole" [r1]))]
-               (appS "throw" [toJExpr (fun_name <> ": unexpected closure type: ") + infoClosureType c])
+               ,(toJExpr Blackhole, traceRts s (toJExpr (fun_name <> ": blackhole")) <> push' s (reverse regArgs ++ mkAp nargs nvars) <> push' s [r1, global "h$return"] <> returnS (app "h$blockOnBlackhole" [r1]))]
+               (appS throwStr [toJExpr (fun_name <> ": unexpected closure type: ") + infoClosureType c])
              ]
 
       funCase :: JStgExpr -> JStgExpr -> JSM JStgStat
@@ -907,7 +909,7 @@ fastApply s fun_name nargs nvars = if nargs == 0 && nvars == 0
                               + rsRemain)
                 , saveRegs rs
                 , sp |= sp + rsRemain + 1
-                , stack .! sp |= var "h$apply" .! ((rsRemain.<<.8).|. (toJExpr nargs - mask8 arity))
+                , stack .! sp |= hdApply .! ((rsRemain.<<.8).|. (toJExpr nargs - mask8 arity))
                 , profStat s pushRestoreCCS
                 , returnS c
                 ]
@@ -917,7 +919,7 @@ fastApply s fun_name nargs nvars = if nargs == 0 && nvars == 0
               switchAlts = map (\x -> (toJExpr x, stack .! (sp + toJExpr (nvars-x)) |= jsReg (x+2))) [0..nvars-1]
 
 zeroApply :: StgToJSConfig -> JSM JStgStat
-zeroApply s = jFunction (global "h$e")
+zeroApply s = jFunction hdEntry
               $ \(MkSolo c) -> fmap ((r1 |= c) <>) $ enter s c
 
 -- carefully enter a closure that might be a thunk or a function
@@ -926,15 +928,15 @@ zeroApply s = jFunction (global "h$e")
 enter :: StgToJSConfig -> JStgExpr -> JSM JStgStat
 enter s ex = jVar \c ->
   return $ mconcat $
-  [ jwhenS (app "typeof" [ex] .!==. jTyObject) returnStack
+  [ jwhenS (app typeof [ex] .!==. jTyObject) returnStack
   , c |= closureInfo ex
-  , jwhenS (c .===. var "h$unbox_e") ((r1 |= closureField1 ex) <> returnStack)
+  , jwhenS (c .===. hdUnboxEntry) ((r1 |= closureField1 ex) <> returnStack)
   , SwitchStat (infoClosureType 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]))
+    , (toJExpr Blackhole, push' s [hdAp00, ex, hdReturn]
+        <> returnS (app hdBlockOnBlackHoleStr [ex]))
     ] (returnS c)
   ]
 
@@ -944,7 +946,7 @@ updates s = do
   upd_frm_lne <- update_frame_lne
   return $ BlockStat [upd_frm, upd_frm_lne]
   where
-    unbox_closure f1 = Closure { clInfo   = var "h$unbox_e"
+    unbox_closure f1 = Closure { clInfo   = hdUnboxEntry -- global "h$unbox_e"
                                , clField1 = f1
                                , clField2 = null_
                                , clMeta   = 0
@@ -961,9 +963,9 @@ updates s = do
                           ]
     update_frame = closure
                    (ClosureInfo
-                      { ciVar = global "h$upd_frame"
+                      { ciVar = hdUpdFrameStr
                       , ciRegs = CIRegs 0 [PtrV]
-                      , ciName = "h$upd_frame"
+                      , ciName = identFS hdUpdFrameStr
                       , ciLayout = CILayoutFixed 1 [PtrV]
                       , ciType = CIStackFrame
                       , ciStatic = mempty
@@ -972,7 +974,7 @@ updates s = do
                        do upd_loop         <- upd_loop' ss si sir
                           wake_thread_loop <- loop zero_ (.<. waiters .^ "length")
                                               \i -> return $
-                                                    appS "h$wakeupThread" [waiters .! i]
+                                                    appS hdWakeupThread [waiters .! i]
                                                     <> postIncrS i
                           let updateCC updatee = closureCC updatee |= jCurrentCCS
 
@@ -983,11 +985,11 @@ updates s = do
                                  waiters |= closureField2 updatee
                                , jwhenS (waiters .!==. null_) wake_thread_loop
                                , -- update selectors
-                                 jwhenS ((app "typeof" [closureMeta updatee] .===. jTyObject) .&&. (closureMeta updatee .^ "sel"))
+                                 jwhenS ((app typeof [closureMeta updatee] .===. jTyObject) .&&. (closureMeta updatee .^ "sel"))
                                  ((ss |= closureMeta updatee .^ "sel")
                                   <> upd_loop)
                                , -- overwrite the object
-                                 ifS (app "typeof" [r1] .===. jTyObject)
+                                 ifS (app typeof [r1] .===. jTyObject)
                                  (mconcat [ traceRts s (jString "$upd_frame: boxed: " + ((closureInfo r1) .^ "n"))
                                           , copyClosure DontCopyCC updatee r1
                                           ])
@@ -1006,7 +1008,7 @@ updates s = do
 
     update_frame_lne = closure
                      (ClosureInfo
-                        { ciVar = global "h$upd_frame_lne"
+                        { ciVar = name $ fsLit "h$upd_frame_lne"
                         , ciRegs = CIRegs 0 [PtrV]
                         , ciName = "h$upd_frame_lne"
                         , ciLayout = CILayoutFixed 1 [PtrV]
@@ -1016,7 +1018,7 @@ updates s = do
                      $ jVar \updateePos ->
                          return $ mconcat $
                          [ updateePos |= stack .! (sp - 1)
-                         , (stack .! updateePos |= r1)
+                         , stack .! updateePos |= r1
                          , adjSpN' 2
                          , traceRts s (jString "h$upd_frame_lne: updating: "
                                        + updateePos
@@ -1031,35 +1033,35 @@ selectors s =
     sel_one  <- mkSel "1"      closureField1
     sel_twoA <- mkSel "2a"  closureField2
     sel_twoB <- mkSel "2b"  (closureField1 . closureField2)
-    rest     <- mconcat <$> (mapM mkSelN [3..16])
+    rest     <- mconcat <$> mapM mkSelN [3..16]
     return $
       sel_one <> sel_twoA <> sel_twoB <> rest
    where
     mkSelN :: Int -> JSM JStgStat
     mkSelN x = mkSel (mkFastString $ show x)
                      (\e -> SelExpr (closureField2 (toJExpr e))
-                            (global $ mkFastString ("d" ++ show (x-1))))
+                            (name $ mkFastString ("d" ++ show (x-1))))
 
 
     mkSel :: FastString -> (JStgExpr -> JStgExpr) -> JSM JStgStat
-    mkSel name sel = mconcat <$> sequence
-      [jFunction (global createName) $
+    mkSel name_ sel = mconcat <$> sequence
+      [jFunction (name createName) $
        \(MkSolo r) -> return $ mconcat
-          [ traceRts s (toJExpr ("selector create: " <> name <> " for ") + (r .^ "alloc"))
+          [ 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))
           ]
-      , jFunction (global resName) $
+      , jFunction (name resName) $
         \(MkSolo r) -> return $ mconcat
-          [ traceRts s (toJExpr ("selector result: " <> name <> " for ") + (r .^ "alloc"))
+          [ traceRts s (toJExpr ("selector result: " <> name_ <> " for ") + (r .^ "alloc"))
           , returnS (sel r)
           ]
       , closure
         (ClosureInfo
-          { ciVar = global entryName
+          { ciVar = name entryName
           , ciRegs = CIRegs 0 [PtrV]
-          , ciName = "select " <> name
+          , ciName = "select " <> name_
           , ciLayout = CILayoutFixed 1 [PtrV]
           , ciType = CIThunk
           , ciStatic = mempty
@@ -1067,32 +1069,32 @@ selectors s =
         (jVar $ \tgt ->
           return $ mconcat $
           [ tgt |= closureField1 r1
-          , traceRts s (toJExpr ("selector entry: " <> name <> " for ") + (tgt .^ "alloc"))
+          , traceRts s (toJExpr ("selector entry: " <> name_ <> " for ") + (tgt .^ "alloc"))
           , ifS (isThunk tgt .||. isBlackhole tgt)
               (preIncrS sp
-               <> (stack .! sp |= var frameName)
+               <> (stack .! sp |= global frameName)
                <> returnS (app "h$e" [tgt]))
               (returnS (app "h$e" [sel tgt]))
           ])
       , closure
         (ClosureInfo
-          { ciVar = global frameName
+          { ciVar = name frameName
           , ciRegs = CIRegs 0 [PtrV]
-          , ciName = "select " <> name <> " frame"
+          , ciName = "select " <> name_ <> " frame"
           , ciLayout = CILayoutFixed 0 []
           , ciType = CIStackFrame
           , ciStatic = mempty
           })
         $ return $
-        mconcat [ traceRts s (toJExpr ("selector frame: " <> name))
+        mconcat [ traceRts s (toJExpr ("selector frame: " <> name_))
                 , postDecrS sp
                 , returnS (app "h$e" [sel r1])
                 ]
       ]
 
       where
-         v x   = JVar (global x)
-         n ext =  "h$c_sel_" <> name <> ext
+         v x   = JVar (name x)
+         n ext =  "h$c_sel_" <> name_ <> ext
          createName = n ""
          resName    = n "_res"
          entryName  = n "_e"
@@ -1116,7 +1118,7 @@ mkPap s tgt fun n values =
 
     values' | GHC.Prelude.null values = [null_]
             | otherwise   = values
-    entry | length values > numSpecPap = global "h$pap_gen"
+    entry | length values > numSpecPap = name "h$pap_gen"
           | otherwise                  = specPapIdents ! length values
 
 -- | Number of specialized PAPs (pre-generated for a given number of args)
@@ -1130,7 +1132,7 @@ specPap = [0..numSpecPap]
 
 -- | Cache of specialized PAP idents
 specPapIdents :: Array Int Ident
-specPapIdents = listArray (0,numSpecPap) $ map (global . mkFastString . ("h$pap_"++) . show) specPap
+specPapIdents = listArray (0,numSpecPap) $ map (name . mkFastString . ("h$pap_"++) . show) specPap
 
 pap :: StgToJSConfig
     -> Int
@@ -1144,7 +1146,7 @@ pap s r = closure (ClosureInfo
                     , ciStatic = mempty
                     }) body
   where
-    funcIdent = global funcName
+    funcIdent = name funcName
     funcName = mkFastString ("h$pap_" ++ show r)
 
     body = jVars $ \(c, d, f, extra) ->
@@ -1166,7 +1168,7 @@ pap s r = closure (ClosureInfo
     moveCase m = (toJExpr m, jsReg (m+r+1) |= jsReg (m+1))
     loadOwnArgs d = mconcat $ map (\r ->
         jsReg (r+1) |= dField d (r+2)) [1..r]
-    dField d n = SelExpr d (global . mkFastString $ ('d':show (n-1)))
+    dField d n = SelExpr d (name . mkFastString $ ('d':show (n-1)))
 
 -- Construct a generic PAP
 papGen :: StgToJSConfig -> JSM JStgStat
@@ -1192,7 +1194,7 @@ papGen cfg =
                 (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]
+              , appS hdMoveRegs2 [or, r]
               , loadOwnArgs d r
               , r1 |= c
               , returnS f
@@ -1200,8 +1202,8 @@ papGen cfg =
 
 
   where
-    funcIdent = global funcName
-    funcName = "h$pap_gen"
+    funcIdent = name funcName
+    funcName = hdPapGenStr
     loadOwnArgs d r =
       let prop n = d .^ ("d" <> mkFastString (show $ n+1))
           loadOwnArg n = (toJExpr n, jsReg (n+1) |= prop n)
@@ -1210,7 +1212,7 @@ papGen cfg =
 -- general utilities
 -- move the first n registers, starting at R2, m places up (do not use with negative m)
 moveRegs2 :: JSM JStgStat
-moveRegs2 = jFunction (global "h$moveRegs2") moveSwitch
+moveRegs2 = jFunction (name hdMoveRegs2) moveSwitch
   where
     moveSwitch (n,m) = defaultCase n m >>= return . SwitchStat ((n .<<. 8) .|. m) switchCases
     -- fast cases
@@ -1224,13 +1226,13 @@ moveRegs2 = jFunction (global "h$moveRegs2") moveSwitch
     -- fallback
     defaultCase n m =
       loop n (.>.0) (\i -> return $
-                           appS "h$setReg" [i+1+m, app "h$getReg" [i+1]]
+                           appS hdSetRegStr [i+1+m, app hdGetRegStr [i+1]]
                            <> postDecrS i)
 
 
 -- Initalize a variable sized object from an array of values
 initClosure :: StgToJSConfig -> JStgExpr -> JStgExpr -> JStgExpr -> JStgExpr
-initClosure cfg info values ccs = app "h$init_closure"
+initClosure cfg info values ccs = app hdInitClosure
   [ newClosure $ Closure
       { clInfo   = info
       , clField1 = null_

compiler/GHC/StgToJS/Arg.hs

@@ -277,9 +277,9 @@ allocateStaticList _ _ = panic "allocateStaticList: unexpected literal in list"
 jsStaticArg :: StaticArg -> JStgExpr
 jsStaticArg = \case
   StaticLitArg l      -> toJExpr l
-  StaticObjArg t      -> var t
+  StaticObjArg t      -> global t
   StaticConArg c args ->
-    allocDynamicE False (var c) (map jsStaticArg args) Nothing
+    allocDynamicE False (global c) (map jsStaticArg args) Nothing
 
 -- | Generate JS code corresponding to a list of static args
 jsStaticArgs :: [StaticArg] -> JStgExpr

compiler/GHC/StgToJS/Closure.hs

@@ -253,10 +253,10 @@ allocClsA i = toJExpr (global (clsName i))
 
 -- | Cache "xXXX" names
 varCache :: Array Int Ident
-varCache = listArray (0,jsClosureCount) (fmap (global . mkFastString . ('x':) . show) [(0::Int)..jsClosureCount])
+varCache = listArray (0,jsClosureCount) (fmap (name . mkFastString . ('x':) . show) [(0::Int)..jsClosureCount])
 
 varName :: Int -> Ident
 varName i
-  | i < 0 || i > jsClosureCount = global $ mkFastString ('x' : show i)
+  | i < 0 || i > jsClosureCount = name $ mkFastString ('x' : show i)
   | otherwise                   = varCache ! i
 

compiler/GHC/StgToJS/Expr.hs

@@ -40,19 +40,20 @@ import GHC.JS.Ident
 import GHC.StgToJS.Apply
 import GHC.StgToJS.Arg
 import GHC.StgToJS.Closure
+import GHC.StgToJS.DataCon
 import GHC.StgToJS.ExprCtx
 import GHC.StgToJS.FFI
 import GHC.StgToJS.Heap
-import GHC.StgToJS.Monad
-import GHC.StgToJS.DataCon
-import GHC.StgToJS.Types
+import GHC.StgToJS.Ids
 import GHC.StgToJS.Literal
+import GHC.StgToJS.Monad
 import GHC.StgToJS.Prim
 import GHC.StgToJS.Profiling
 import GHC.StgToJS.Regs
-import GHC.StgToJS.Utils
 import GHC.StgToJS.Stack
-import GHC.StgToJS.Ids
+import GHC.StgToJS.Symbols
+import GHC.StgToJS.Types
+import GHC.StgToJS.Utils
 
 import GHC.Types.CostCentre
 import GHC.Types.Tickish
@@ -170,7 +171,7 @@ genBind ctx bndr =
            the_fvjs <- varsForId the_fv
            case (tgts, the_fvjs) of
              ([tgt], [the_fvj]) -> return $ Just
-               (tgt ||= ApplExpr (var ("h$c_sel_" <> mkFastString sel_tag)) [the_fvj])
+               (tgt ||= ApplExpr (global (hdCSelStr <> mkFastString sel_tag)) [the_fvj])
              _ -> panic "genBind.assign: invalid size"
      assign b (StgRhsClosure _ext _ccs _upd [] expr _typ)
        | isInlineExpr expr = do
@@ -233,7 +234,7 @@ genEntryLne ctx i rhs@(StgRhsClosure _ext _cc update args body typ) =
       mk_bh | isUpdatable update =
               do x <- freshIdent
                  return $ mconcat
-                   [ x ||= ApplExpr (var "h$bh_lne") [Sub sp (toJExpr myOffset), toJExpr (payloadSize+1)]
+                   [ x ||= ApplExpr hdBlackHoleLNE [Sub sp (toJExpr myOffset), toJExpr (payloadSize+1)]
                    , IfStat (Var x) (ReturnStat (Var x)) mempty
                    ]
             | otherwise = pure mempty
@@ -242,7 +243,7 @@ genEntryLne ctx i rhs@(StgRhsClosure _ext _cc update args body typ) =
   body   <- genBody ctx R1 args body typ
   ei@(identFS -> eii) <- identForEntryId i
   sr   <- genStaticRefsRhs rhs
-  let f = (blk_hl <> locals <> body)
+  let f = blk_hl <> locals <> body
   emitClosureInfo $ ClosureInfo
     { ciVar = ei
     , ciRegs = CIRegs 0 $ concatMap idJSRep args
@@ -388,7 +389,7 @@ verifyRuntimeReps xs = do
     ver j DoubleV = v "h$verify_rep_double"  [j]
     ver j ArrV    = v "h$verify_rep_arr"     [j]
     ver _ _       = mempty
-    v f as = ApplStat (var f) as
+    v f as = ApplStat (global f) as
 
 -- | Given a set of 'Id's, bind each 'Id' to the appropriate data fields in N
 -- registers. This assumes these data fields have already been populated in the
@@ -416,7 +417,7 @@ loadLiveFun l = do
                , l''
                ]
   where
-        loadLiveVar d n v = let ident = global (dataFieldName n)
+        loadLiveVar d n v = let ident = name (dataFieldName n)
                             in  v ||= SelExpr d ident
 
 -- | Pop a let-no-escape frame off the stack
@@ -458,7 +459,7 @@ genUpdFrame u i
 --
 bhSingleEntry :: StgToJSConfig -> JStgStat
 bhSingleEntry _settings = mconcat
-  [ closureInfo   r1 |= var "h$blackholeTrap"
+  [ closureInfo   r1 |= hdBlackHoleTrap
   , closureField1 r1 |= undefined_
   , closureField2 r1 |= undefined_
   ]
@@ -784,7 +785,7 @@ verifyMatchRep x alt = do
     else case alt of
       AlgAlt tc -> do
         ix <- varsForId x
-        pure $ ApplStat (var "h$verify_match_alg") (ValExpr(JStr(mkFastString (renderWithContext defaultSDocContext (ppr tc)))):ix)
+        pure $ ApplStat (global "h$verify_match_alg") (ValExpr (JStr (mkFastString (renderWithContext defaultSDocContext (ppr tc)))):ix)
       _ -> pure mempty
 
 -- | A 'Branch' represents a possible branching path of an Stg case statement,
@@ -946,7 +947,7 @@ loadParams from args = do
     loadIfUsed  _ _   _    = mempty
 
     loadConVarsIfUsed fr cs = mconcat $ zipWith f cs [(1::Int)..]
-      where f (x,u) n = loadIfUsed (SelExpr fr (global (dataFieldName n))) x u
+      where f (x,u) n = loadIfUsed (SelExpr fr (name (dataFieldName n))) x u
 
 -- | Determine if a branch will end in a continuation or not. If not the inline
 -- branch must be normalized. See 'normalizeBranches'
@@ -1021,7 +1022,7 @@ allocDynAll haveDecl middle cls = do
                                        , (closureMeta_  , zero_)
                                        ]
                              ++ fmap (\cid -> ("cc", ValExpr (JVar cid))) ccs)
-            else ApplExpr (var "h$c") (f : fmap (ValExpr . JVar) ccs)
+            else ApplExpr hdC (f : fmap (ValExpr . JVar) ccs)
         ]
 
     fillObjs :: [JStgStat]
@@ -1048,7 +1049,7 @@ allocDynAll haveDecl middle cls = do
 
     checkObjs :: [JStgStat]
     checkObjs | csAssertRts settings  =
-                map (\(i,_,_,_) -> ApplStat (var "h$checkObj") [Var i]) cls
+                map (\(i,_,_,_) -> ApplStat hdCheckObj [Var i]) cls
               | otherwise = mempty
 
   objs <- makeObjs

compiler/GHC/StgToJS/FFI.hs

@@ -11,17 +11,17 @@ where
 import GHC.Prelude
 
 import GHC.JS.JStg.Syntax
-import GHC.JS.Ident
 import GHC.JS.Make
 
 import GHC.StgToJS.Arg
 import GHC.StgToJS.ExprCtx
-import GHC.StgToJS.Monad
-import GHC.StgToJS.Types
+import GHC.StgToJS.Ids
 import GHC.StgToJS.Literal
+import GHC.StgToJS.Monad
 import GHC.StgToJS.Regs
+import GHC.StgToJS.Symbols
+import GHC.StgToJS.Types
 import GHC.StgToJS.Utils
-import GHC.StgToJS.Ids
 
 import GHC.Types.RepType
 import GHC.Types.ForeignCall
@@ -44,7 +44,7 @@ import qualified Data.List as L
 
 genPrimCall :: ExprCtx -> PrimCall -> [StgArg] -> Type -> G (JStgStat, ExprResult)
 genPrimCall ctx (PrimCall lbl _) args t = do
-  j <- parseFFIPattern False False False ("h$" ++ unpackFS lbl) t (concatMap typex_expr $ ctxTarget ctx) args
+  j <- parseFFIPattern False False False (unpackFS hdStr ++ unpackFS lbl) t (concatMap typex_expr $ ctxTarget ctx) args
   return (j, ExprInline)
 
 -- | generate the actual call
@@ -79,8 +79,7 @@ parseFFIPattern catchExcep async jscc pat t es as
       --  } catch(except) {
       --    return h$throwJSException(except);
       --  }
-      let ex = global "except"
-      return (TryStat c ex (ReturnStat (ApplExpr (var "h$throwJSException") [toJExpr ex])) mempty)
+      return (TryStat c exceptStr (ReturnStat (ApplExpr hdThrowJSException [except])) mempty)
   | otherwise  = parseFFIPatternA async jscc pat t es as
 
 parseFFIPatternA :: Bool  -- ^ async
@@ -98,18 +97,18 @@ parseFFIPatternA True True pat t es as  = do
   d  <- freshIdent
   stat <- parseFFIPattern' (Just (toJExpr cb)) True pat t es as
   return $ mconcat
-    [ x  ||= (toJExpr (jhFromList [("mv", null_)]))
-    , cb ||= ApplExpr (var "h$mkForeignCallback") [toJExpr x]
+    [ x  ||= (toJExpr (jhFromList [(mv, null_)]))
+    , cb ||= ApplExpr hdMkForeignCallback [toJExpr x]
     , stat
-    , IfStat (InfixExpr StrictEqOp (toJExpr x .^ "mv") null_)
+    , IfStat (InfixExpr StrictEqOp (toJExpr x .^ mv) null_)
           (mconcat
-            [ toJExpr x .^ "mv" |= UOpExpr NewOp (ApplExpr (var "h$MVar") [])
+            [ toJExpr x .^ mv |= UOpExpr NewOp (ApplExpr hdMVar [])
             , sp |= Add sp one_
-            , (IdxExpr stack sp) |= var "h$unboxFFIResult"
-            , ReturnStat $ ApplExpr (var "h$takeMVar") [toJExpr x .^ "mv"]
+            , (IdxExpr stack sp) |= hdUnboxFFIResult
+            , ReturnStat $ ApplExpr hdTakeMVar [toJExpr x .^ mv]
             ])
           (mconcat
-            [ d ||= toJExpr x .^ "mv"
+            [ d ||= toJExpr x .^ mv
             , copyResult (toJExpr d)
             ])
     ]
@@ -155,7 +154,7 @@ parseFFIPattern' callback javascriptCc pat t ret args
     copyResult rs = mconcat $ zipWith (\t r -> toJExpr r |= toJExpr t) (enumFrom Ret1) rs
 
     traceCall cs as
-        | csTraceForeign cs = ApplStat (var "h$traceForeign") [toJExpr pat, toJExpr as]
+        | csTraceForeign cs = ApplStat hdTraceForeign [toJExpr pat, toJExpr as]
         | otherwise         = mempty
 
 -- generate arg to be passed to FFI call, with marshalling JStgStat to be run
@@ -189,7 +188,7 @@ genForeignCall _ctx
                _t
                [obj]
                args
-  | tgt == fsLit "h$buildObject"
+  | tgt == hdBuildObjectStr
   , Just pairs <- getObjectKeyValuePairs args = do
       pairs' <- mapM (\(k,v) -> genArg v >>= \vs -> return (k, head vs)) pairs
       return ( (|=) obj (ValExpr (JHash $ listToUniqMap pairs'))
@@ -197,18 +196,19 @@ genForeignCall _ctx
              )
 
 genForeignCall ctx (CCall (CCallSpec ccTarget cconv safety)) t tgt args = do
-  emitForeign (ctxSrcSpan ctx) (mkFastString lbl) safety cconv (map showArgType args) (showType t)
-  (,exprResult) <$> parseFFIPattern catchExcep async isJsCc lbl t tgt' args
+  emitForeign (ctxSrcSpan ctx) lbl safety cconv (map showArgType args) (showType t)
+  (,exprResult) <$> parseFFIPattern catchExcep async isJsCc (unpackFS lbl) t tgt' args
   where
     isJsCc = cconv == JavaScriptCallConv
 
     lbl | (StaticTarget _ clbl _mpkg _isFunPtr) <- ccTarget
-            = let clbl' = unpackFS clbl
-              in  if | isJsCc -> clbl'
+            = let clbl'    = unpackFS clbl
+                  hDollarS = unpackFS hdStr
+              in  if | isJsCc -> clbl
                      | wrapperPrefix `L.isPrefixOf` clbl' ->
-                         ("h$" ++ (drop 2 $ dropWhile isDigit $ drop (length wrapperPrefix) clbl'))
-                     | otherwise -> "h$" ++ clbl'
-        | otherwise = "h$callDynamic"
+                         mkFastString (hDollarS ++ (drop 2 $ dropWhile isDigit $ drop (length wrapperPrefix) clbl'))
+                     | otherwise -> mkFastString $ hDollarS ++ clbl'
+        | otherwise = hdCallDynamicStr
 
     exprResult | async     = ExprCont
                | otherwise = ExprInline
@@ -222,7 +222,7 @@ genForeignCall ctx (CCall (CCallSpec ccTarget cconv safety)) t tgt args = do
     tgt'  | async     = take (length tgt) jsRegsFromR1
           | otherwise = tgt
 
-    wrapperPrefix = "ghczuwrapperZC"
+    wrapperPrefix = unpackFS wrapperColonStr
 
 getObjectKeyValuePairs :: [StgArg] -> Maybe [(FastString, StgArg)]
 getObjectKeyValuePairs [] = Just []
@@ -242,4 +242,4 @@ showType :: Type -> FastString
 showType t
   | Just tc <- tyConAppTyCon_maybe (unwrapType t) =
       mkFastString (renderWithContext defaultSDocContext (ppr tc))
-  | otherwise = "<unknown>"
+  | otherwise = unknown

compiler/GHC/StgToJS/Heap.hs

@@ -90,7 +90,7 @@ closureType :: JStgExpr -> JStgExpr
 closureType = infoClosureType . closureInfo
 
 isObject :: JStgExpr -> JStgExpr
-isObject c = typeof c .===. String "object"
+isObject c = typeOf c .===. String "object"
 
 isThunk :: JStgExpr -> JStgExpr
 isThunk c = closureType c .===. toJExpr Thunk

compiler/GHC/StgToJS/Ids.hs

@@ -78,9 +78,8 @@ freshIdent :: G Ident
 freshIdent = do
   i <- freshUnique
   mod <- State.gets gsModule
-  let !name = mkFreshJsSymbol mod i
-  return (global name)
-
+  let !sym_name = mkFreshJsSymbol mod i
+  return (name sym_name)
 
 -- | Generate unique Ident for the given ID (uncached!)
 --
@@ -100,19 +99,19 @@ freshIdent = do
 -- Int64#), Addr#, StablePtr#, unboxed tuples, etc.
 --
 makeIdentForId :: Id -> Maybe Int -> IdType -> Module -> Ident
-makeIdentForId i num id_type current_module = global ident
+makeIdentForId i num id_type current_module = name ident
   where
     exported = isExportedId i
-    name     = getName i
+    name'    = getName i
     mod
       | exported
-      , Just m <- nameModule_maybe name
+      , Just m <- nameModule_maybe name'
       = m
       | otherwise
       = current_module
 
     !ident   = mkFastStringByteString $ mconcat
-      [ mkJsSymbolBS exported mod (occNameMangledFS (nameOccName name))
+      [ mkJsSymbolBS exported mod (occNameMangledFS (nameOccName name'))
 
         -------------
         -- suffixes

compiler/GHC/StgToJS/Linker/Linker.hs

@@ -1240,24 +1240,24 @@ staticInitStat :: StaticInfo -> JS.JStat
 staticInitStat (StaticInfo i sv mcc) =
   jStgStatToJS $
   case sv of
-    StaticData con args         -> appS "h$sti" $ add_cc_arg
-                                    [ var i
-                                    , var con
+    StaticData con args         -> appS hdStiStr $ add_cc_arg
+                                    [ global i
+                                    , global con
                                     , jsStaticArgs args
                                     ]
-    StaticFun  f   args         -> appS "h$sti" $ add_cc_arg
-                                    [ var i
-                                    , var f
+    StaticFun  f   args         -> appS hdStiStr $ add_cc_arg
+                                    [ global i
+                                    , global f
                                     , jsStaticArgs args
                                     ]
-    StaticList args mt          -> appS "h$stl" $ add_cc_arg
-                                    [ var i
+    StaticList args mt          -> appS hdStlStr $ add_cc_arg
+                                    [ global i
                                     , jsStaticArgs args
                                     , toJExpr $ maybe null_ (toJExpr . TxtI) mt
                                     ]
-    StaticThunk (Just (f,args)) -> appS "h$stc" $ add_cc_arg
-                                    [ var i
-                                    , var f
+    StaticThunk (Just (f,args)) -> appS hdStcStr $ add_cc_arg
+                                    [ global i
+                                    , global f
                                     , jsStaticArgs args
                                     ]
     _                           -> mempty
@@ -1271,19 +1271,19 @@ staticInitStat (StaticInfo i sv mcc) =
 staticDeclStat :: StaticInfo -> JS.JStat
 staticDeclStat (StaticInfo global_name static_value _) = jStgStatToJS decl
   where
-    global_ident = global global_name
+    global_ident = name global_name
     decl_init v  = global_ident ||= v
-    decl_no_init = appS "h$di" [toJExpr global_ident]
+    decl_no_init = appS hdDiStr [toJExpr global_ident]
 
     decl = case static_value of
       StaticUnboxed u     -> decl_init (unboxed_expr u)
       StaticThunk Nothing -> decl_no_init -- CAF initialized in an alternative way
-      _                   -> decl_init (app "h$d" [])
+      _                   -> decl_init (app hdDStr [])
 
     unboxed_expr = \case
-      StaticUnboxedBool b          -> app "h$p" [toJExpr b]
-      StaticUnboxedInt i           -> app "h$p" [toJExpr i]
-      StaticUnboxedDouble d        -> app "h$p" [toJExpr (unSaneDouble d)]
+      StaticUnboxedBool b          -> app hdPStr [toJExpr b]
+      StaticUnboxedInt i           -> app hdPStr [toJExpr i]
+      StaticUnboxedDouble d        -> app hdPStr [toJExpr (unSaneDouble d)]
       -- GHCJS used a function wrapper for this:
       -- StaticUnboxedString str      -> ApplExpr (initStr str) []
       -- But we are defining it statically for now.
@@ -1295,5 +1295,5 @@ staticDeclStat (StaticInfo global_name static_value _) = jStgStatToJS decl
     initStr :: BS.ByteString -> JStgExpr
     initStr str =
       case decodeModifiedUTF8 str of
-        Just t  -> app "h$encodeModifiedUtf8" [ValExpr (JStr t)]
-        Nothing -> app "h$rawStringData" [ValExpr $ to_byte_list str]
+        Just t  -> app hdEncodeModifiedUtf8Str [ValExpr (JStr t)]
+        Nothing -> app hdRawStringDataStr      [ValExpr $ to_byte_list str]

compiler/GHC/StgToJS/Literal.hs

@@ -14,10 +14,10 @@ import GHC.JS.JStg.Syntax
 import GHC.JS.Make
 import GHC.JS.Ident
 
-import GHC.StgToJS.Types
-import GHC.StgToJS.Monad
 import GHC.StgToJS.Ids
+import GHC.StgToJS.Monad
 import GHC.StgToJS.Symbols
+import GHC.StgToJS.Types
 
 import GHC.Data.FastString
 import GHC.Types.Literal
@@ -62,8 +62,8 @@ genLit = \case
   LitFloat r               -> return [ toJExpr (r2f r) ]
   LitDouble r              -> return [ toJExpr (r2d r) ]
   LitLabel name fod
-    | fod == IsFunction      -> return [ ApplExpr (var "h$mkFunctionPtr")
-                                                  [var (mkRawSymbol True name)]
+    | fod == IsFunction      -> return [ ApplExpr hdMkFunctionPtr
+                                                  [global (mkRawSymbol True name)]
                                        , ValExpr (JInt 0)
                                        ]
     | otherwise              -> return [ toJExpr (global (mkRawSymbol True name))

compiler/GHC/StgToJS/Object.hs

@@ -538,7 +538,7 @@ instance Binary Sat.JVal where
 
 instance Binary Ident where
   put_ bh (identFS -> xs) = put_ bh xs
-  get  bh                = global <$> get bh
+  get  bh                 = name <$> get bh
 
 instance Binary ClosureInfo where
   put_ bh (ClosureInfo v regs name layo typ static) = do

compiler/GHC/StgToJS/Profiling.hs

@@ -28,14 +28,15 @@ where
 import GHC.Prelude
 
 import GHC.JS.Syntax
+import GHC.JS.JStg.Syntax (JStgExpr)
 import qualified GHC.JS.JStg.Syntax as JStg
 import GHC.JS.Make
 import GHC.JS.Ident
 
+import GHC.StgToJS.Monad
 import GHC.StgToJS.Regs
-import GHC.StgToJS.Types
 import GHC.StgToJS.Symbols
-import GHC.StgToJS.Monad
+import GHC.StgToJS.Types
 
 import GHC.Types.CostCentre
 
@@ -46,6 +47,33 @@ import GHC.Utils.Outputable
 import GHC.Utils.Panic
 import qualified Control.Monad.Trans.State.Strict as State
 
+--------------------------------------------------------------------------------
+-- Symbols
+
+hdCC :: JStgExpr
+hdCC = JStg.global "h$CC"
+
+hdCCS :: JStgExpr
+hdCCS = JStg.global "h$CCS"
+
+hdEnterFunCCS :: JStgExpr
+hdEnterFunCCS = JStg.global "h$enterFunCCS"
+
+cc :: Ident
+cc = name "cc"
+
+ccs :: Ident
+ccs = name "ccs"
+
+hdPushCostCentre :: JStgExpr
+hdPushCostCentre = JStg.global "h$pushCostCentre"
+
+hdPushRestoreCCS :: JStgExpr
+hdPushRestoreCCS = JStg.global "h$pushRestoreCCS"
+
+hdEnterThunkCCS :: JStgExpr
+hdEnterThunkCCS = JStg.global "h$enterThunkCCS"
+
 --------------------------------------------------------------------------------
 -- Initialization
 
@@ -62,7 +90,7 @@ emitCostCentreDecl cc = do
       modl   = moduleNameString $ moduleName $ cc_mod cc
       loc    = renderWithContext defaultSDocContext (ppr (costCentreSrcSpan cc))
       js     = JStg.DeclStat ccsLbl
-        (Just (JStg.UOpExpr JStg.NewOp (JStg.ApplExpr (JStg.var "h$CC")
+        (Just (JStg.UOpExpr JStg.NewOp (JStg.ApplExpr hdCC
                                [ toJExpr label
                                , toJExpr modl
                                , toJExpr loc
@@ -79,7 +107,7 @@ emitCostCentreStackDecl ccs =
         let js =
               JStg.DeclStat ccsLbl
               (Just (JStg.UOpExpr JStg.NewOp
-                     (JStg.ApplExpr (JStg.var "h$CCS") [null_, toJExpr ccLbl])))
+                     (JStg.ApplExpr hdCCS [null_, toJExpr ccLbl])))
         emitGlobal js
       Nothing -> pprPanic "emitCostCentreStackDecl" (ppr ccs)
 
@@ -88,37 +116,36 @@ emitCostCentreStackDecl ccs =
 
 enterCostCentreFun :: CostCentreStack -> JStg.JStgStat
 enterCostCentreFun ccs
-  | isCurrentCCS ccs = JStg.ApplStat (JStg.var "h$enterFunCCS")
-                       [jCurrentCCS, JStg.SelExpr r1 (global "cc")]
+  | isCurrentCCS ccs = JStg.ApplStat hdEnterFunCCS [jCurrentCCS, JStg.SelExpr r1 cc]
   | otherwise = mempty -- top-level function, nothing to do
 
 enterCostCentreThunk :: JStg.JStgStat
-enterCostCentreThunk = JStg.ApplStat (JStg.var "h$enterThunkCCS") [JStg.SelExpr r1 (global "cc")]
+enterCostCentreThunk = JStg.ApplStat hdEnterThunkCCS [JStg.SelExpr r1 cc]
 
 setCC :: CostCentre -> Bool -> Bool -> G JStg.JStgStat
 setCC cc _tick True = do
   ccI@(identFS -> _ccLbl) <- costCentreLbl cc
   addDependency $ OtherSymb (cc_mod cc)
                             (moduleGlobalSymbol $ cc_mod cc)
-  return $ jCurrentCCS |= JStg.ApplExpr (JStg.var "h$pushCostCentre") [ jCurrentCCS
-                                                                      , JStg.Var ccI
-                                                                      ]
+  return $ jCurrentCCS |= JStg.ApplExpr hdPushCostCentre [ jCurrentCCS
+                                                         , JStg.Var ccI
+                                                         ]
 setCC _cc _tick _push = return mempty
 
 pushRestoreCCS :: JStg.JStgStat
-pushRestoreCCS = JStg.ApplStat (JStg.var "h$pushRestoreCCS") []
+pushRestoreCCS = JStg.ApplStat hdPushRestoreCCS []
 
 --------------------------------------------------------------------------------
 -- Some cost-centre stacks to be used in generator
 
 jCurrentCCS :: JStg.JStgExpr
-jCurrentCCS = JStg.SelExpr (JStg.var "h$currentThread") (global "ccs")
+jCurrentCCS = JStg.SelExpr hdCurrentThread ccs
 
 jCafCCS :: JStg.JStgExpr
-jCafCCS = JStg.var "h$CAF"
+jCafCCS = JStg.global "h$CAF"
 
 jSystemCCS :: JStg.JStgExpr
-jSystemCCS = JStg.var "h$CCS_SYSTEM"
+jSystemCCS = JStg.global "h$CCS_SYSTEM"
 --------------------------------------------------------------------------------
 -- Helpers for generating profiling related things
 
@@ -138,6 +165,7 @@ ifProfilingM m = do
 -- | If profiling is enabled, then use input JStgStat, else ignore
 profStat :: StgToJSConfig -> JStg.JStgStat -> JStg.JStgStat
 profStat cfg e = if csProf cfg then e else mempty
+
 --------------------------------------------------------------------------------
 -- Generating cost-centre and cost-centre stack variables
 
@@ -150,7 +178,7 @@ costCentreLbl' cc = do
     moduleNameColons (moduleName curModl) ++ "_" ++ if isCafCC cc then "CAF_ccs" else lbl
 
 costCentreLbl :: CostCentre -> G Ident
-costCentreLbl cc = global . mkFastString <$> costCentreLbl' cc
+costCentreLbl cc = name . mkFastString <$> costCentreLbl' cc
 
 costCentreStackLbl' :: CostCentreStack -> G (Maybe String)
 costCentreStackLbl' ccs = do
@@ -164,7 +192,7 @@ costCentreStackLbl' ccs = do
             Nothing -> pure Nothing
 
 costCentreStackLbl :: CostCentreStack -> G (Maybe Ident)
-costCentreStackLbl ccs = fmap (global . mkFastString) <$> costCentreStackLbl' ccs
+costCentreStackLbl ccs = fmap (name . mkFastString) <$> costCentreStackLbl' ccs
 
 singletonCCSLbl' :: CostCentre -> G String
 singletonCCSLbl' cc = do
@@ -178,7 +206,7 @@ singletonCCSLbl' cc = do
               ]
 
 singletonCCSLbl :: CostCentre -> G Ident
-singletonCCSLbl cc = global . mkFastString <$> singletonCCSLbl' cc
+singletonCCSLbl cc = name . mkFastString <$> singletonCCSLbl' cc
 
 ccsVarJ :: CostCentreStack -> G (Maybe JStg.JStgExpr)
 ccsVarJ ccs = do