Factor JS Rts generation for h$c{_,0,1,2} into h$c{n} and improve name caching

5 files changed, 107 insertions, 121 deletions

diff --git a/compiler/GHC/JS/Make.hs b/compiler/GHC/JS/Make.hs
index 6dee4cec93..f57643094c 100644
--- a/compiler/GHC/JS/Make.hs
+++ b/compiler/GHC/JS/Make.hs
@@ -126,10 +126,6 @@ module GHC.JS.Make
     math_cosh, math_sinh, math_tanh, math_expm1, math_log1p, math_fround
   -- * Statement helpers
   , decl
-  -- * Miscellaneous
-  -- $misc
-  , allocData, allocClsA
-  , dataFieldName, dataFieldNames
   )
 where
 
@@ -139,13 +135,10 @@ import GHC.JS.Syntax
 
 import Control.Arrow ((***))
 
-import Data.Array
 import qualified Data.Map as M
 
-import GHC.Utils.Outputable (Outputable (..))
 import GHC.Data.FastString
 import GHC.Utils.Monad.State.Strict
-import GHC.Utils.Panic
 import GHC.Utils.Misc
 import GHC.Types.Unique.Map
 
@@ -632,43 +625,6 @@ instance Fractional JExpr where
 
 
 --------------------------------------------------------------------------------
---                             Miscellaneous
---------------------------------------------------------------------------------
--- $misc
--- Everything else,
-
--- | Cache "dXXX" field names
-dataFieldCache :: Array Int FastString
-dataFieldCache = listArray (0,nFieldCache) (map (mkFastString . ('d':) . show) [(0::Int)..nFieldCache])
-
-nFieldCache :: Int
-nFieldCache  = 16384
-
-dataFieldName :: Int -> FastString
-dataFieldName i
-  | i < 1 || i > nFieldCache = panic "dataFieldName" (ppr i)
-  | otherwise                = dataFieldCache ! i
-
-dataFieldNames :: [FastString]
-dataFieldNames = fmap dataFieldName [1..nFieldCache]
-
-
--- | Cache "h$dXXX" names
-dataCache :: Array Int FastString
-dataCache = listArray (0,1024) (map (mkFastString . ("h$d"++) . show) [(0::Int)..1024])
-
-allocData :: Int -> JExpr
-allocData i = toJExpr (TxtI (dataCache ! i))
-
--- | Cache "h$cXXX" names
-clsCache :: Array Int FastString
-clsCache = listArray (0,1024) (map (mkFastString . ("h$c"++) . show) [(0::Int)..1024])
-
-allocClsA :: Int -> JExpr
-allocClsA i = toJExpr (TxtI (clsCache ! i))
-
-
---------------------------------------------------------------------------------
 -- New Identifiers
 --------------------------------------------------------------------------------
 
diff --git a/compiler/GHC/StgToJS/Closure.hs b/compiler/GHC/StgToJS/Closure.hs
index 7c758ede95..4604eccdb7 100644
--- a/compiler/GHC/StgToJS/Closure.hs
+++ b/compiler/GHC/StgToJS/Closure.hs
@@ -10,6 +10,15 @@ module GHC.StgToJS.Closure
   , assignClosure
   , CopyCC (..)
   , copyClosure
+  , mkClosure
+  -- $names
+  , allocData
+  , allocClsA
+  , dataName
+  , clsName
+  , dataFieldName
+  , varName
+  , jsClosureCount
   )
 where
 
@@ -24,6 +33,9 @@ import GHC.StgToJS.Regs (stack,sp)
 import GHC.JS.Make
 import GHC.JS.Syntax
 
+import GHC.Types.Unique.Map
+
+import Data.Array
 import Data.Monoid
 import qualified Data.Bits as Bits
 
@@ -154,3 +166,78 @@ copyClosure copy_cc t s = BlockStat
   ] <> case copy_cc of
       DontCopyCC -> mempty
       CopyCC     -> closureCC t |= closureCC s
+
+mkClosure :: JExpr -> [JExpr] -> JExpr -> Maybe JExpr -> Closure
+mkClosure entry fields meta cc = Closure
+  { clEntry  = entry
+  , clField1 = x1
+  , clField2 = x2
+  , clMeta   = meta
+  , clCC     = cc
+  }
+  where
+    x1 = case fields of
+           []  -> null_
+           x:_ -> x
+    x2 = case fields of
+           []     -> null_
+           [_]    -> null_
+           [_,x]  -> x
+           _:x:xs -> ValExpr . JHash . listToUniqMap $ zip (map dataFieldName [1..]) (x:xs)
+
+
+-------------------------------------------------------------------------------
+--                             Name Caches
+-------------------------------------------------------------------------------
+-- $names
+
+-- | Cache "dXXX" field names
+dataFieldCache :: Array Int FastString
+dataFieldCache = listArray (0,nFieldCache) (map (mkFastString . ('d':) . show) [(0::Int)..nFieldCache])
+
+-- | Data names are used in the AST, and logging has determined that 255 is the maximum number we see.
+nFieldCache :: Int
+nFieldCache  = 255
+
+-- | We use this in the RTS to determine the number of generated closures. These closures use the names
+-- cached here, so we bind them to the same number.
+jsClosureCount :: Int
+jsClosureCount  = 24
+
+dataFieldName :: Int -> FastString
+dataFieldName i
+  | i < 0 || i > nFieldCache = mkFastString ('d' : show i)
+  | otherwise                = dataFieldCache ! i
+
+-- | Cache "h$dXXX" names
+dataCache :: Array Int FastString
+dataCache = listArray (0,jsClosureCount) (map (mkFastString . ("h$d"++) . show) [(0::Int)..jsClosureCount])
+
+dataName :: Int -> FastString
+dataName i
+  | i < 0 || i > nFieldCache = mkFastString ("h$d" ++ show i)
+  | otherwise                = dataCache ! i
+
+allocData :: Int -> JExpr
+allocData i = toJExpr (TxtI (dataName i))
+
+-- | Cache "h$cXXX" names
+clsCache :: Array Int FastString
+clsCache = listArray (0,jsClosureCount) (map (mkFastString . ("h$c"++) . show) [(0::Int)..jsClosureCount])
+
+clsName :: Int -> FastString
+clsName i
+  | i < 0 || i > jsClosureCount = mkFastString ("h$c" ++ show i)
+  | otherwise                   = clsCache ! i
+
+allocClsA :: Int -> JExpr
+allocClsA i = toJExpr (TxtI (clsName i))
+
+-- | Cache "xXXX" names
+varCache :: Array Int Ident
+varCache = listArray (0,jsClosureCount) (map (TxtI . mkFastString . ('x':) . show) [(0::Int)..jsClosureCount])
+
+varName :: Int -> Ident
+varName i
+  | i < 0 || i > jsClosureCount = TxtI $ mkFastString ('x' : show i)
+  | otherwise                   = varCache ! i
diff --git a/compiler/GHC/StgToJS/DataCon.hs b/compiler/GHC/StgToJS/DataCon.hs
index 242ea7f189..cf82c2f6ac 100644
--- a/compiler/GHC/StgToJS/DataCon.hs
+++ b/compiler/GHC/StgToJS/DataCon.hs
@@ -42,11 +42,9 @@ import GHC.StgToJS.Ids
 import GHC.Core.DataCon
 
 import GHC.Types.CostCentre
-import GHC.Types.Unique.Map
 
 import GHC.Utils.Outputable
 import GHC.Utils.Panic
-import GHC.Data.FastString
 
 import Data.Maybe
 
@@ -97,23 +95,11 @@ allocDynamicE :: Bool          -- ^ csInlineAlloc from StgToJSConfig
               -> Maybe JExpr
               -> JExpr
 allocDynamicE  inline_alloc entry free cc
-  | inline_alloc || length free > 24 = newClosure $ Closure
-      { clEntry  = entry
-      , clField1 = fillObj1
-      , clField2 = fillObj2
-      , clMeta   = ValExpr (JInt 0)
-      , clCC     = cc
-      }
+  | inline_alloc || length free > jsClosureCount
+    = newClosure $ mkClosure entry free (ValExpr (JInt 0)) cc
   | otherwise = ApplExpr allocFun (toJExpr entry : free ++ maybeToList cc)
   where
     allocFun = allocClsA (length free)
-    (fillObj1,fillObj2)
-       = case free of
-                []  -> (null_, null_)
-                [x] -> (x,null_)
-                [x,y] -> (x,y)
-                (x:xs) -> (x,toJExpr (JHash $ listToUniqMap (zip dataFields xs)))
-    dataFields = map (mkFastString . ('d':) . show) [(1::Int)..]
 
 -- | Allocate a dynamic object
 allocDynamic :: StgToJSConfig -> Bool -> Ident -> JExpr -> [JExpr] -> Maybe JExpr -> JStat
diff --git a/compiler/GHC/StgToJS/Expr.hs b/compiler/GHC/StgToJS/Expr.hs
index b398cdf501..d42d93afe8 100644
--- a/compiler/GHC/StgToJS/Expr.hs
+++ b/compiler/GHC/StgToJS/Expr.hs
@@ -35,6 +35,7 @@ import GHC.JS.Make
 
 import GHC.StgToJS.Apply
 import GHC.StgToJS.Arg
+import GHC.StgToJS.Closure
 import GHC.StgToJS.ExprCtx
 import GHC.StgToJS.FFI
 import GHC.StgToJS.Heap
@@ -1006,7 +1007,7 @@ allocDynAll haveDecl middle cls = do
                         ]
             (ex:es)  -> mconcat
                         [ toJExpr i .^ closureField1_ |= toJExpr ex
-                        , toJExpr i .^ closureField2_ |= toJExpr (jhFromList (zip dataFieldNames es))
+                        , toJExpr i .^ closureField2_ |= toJExpr (jhFromList (zip (map dataFieldName [1..]) es))
                         ]
       | otherwise = case es of
             []      -> mempty
diff --git a/compiler/GHC/StgToJS/Rts/Rts.hs b/compiler/GHC/StgToJS/Rts/Rts.hs
index 55e1a3f312..dbbac5d3b1 100644
--- a/compiler/GHC/StgToJS/Rts/Rts.hs
+++ b/compiler/GHC/StgToJS/Rts/Rts.hs
@@ -81,36 +81,8 @@ resetResultVar r = toJExpr r |= null_
 -- JIT can optimize better.
 closureConstructors :: StgToJSConfig -> JStat
 closureConstructors s = BlockStat
-  [ declClsConstr "h$c" ["f"] $ Closure
-      { clEntry  = var "f"
-      , clField1 = null_
-      , clField2 = null_
-      , clMeta   = 0
-      , clCC     = ccVal
-      }
-  , declClsConstr "h$c0" ["f"] $ Closure
-      { clEntry  = var "f"
-      , clField1 = null_
-      , clField2 = null_
-      , clMeta   = 0
-      , clCC     = ccVal
-      }
-  , declClsConstr "h$c1" ["f", "x1"] $ Closure
-      { clEntry  = var "f"
-      , clField1 = var "x1"
-      , clField2 = null_
-      , clMeta   = 0
-      , clCC     = ccVal
-      }
-  , declClsConstr "h$c2" ["f", "x1", "x2"] $ Closure
-      { clEntry  = var "f"
-      , clField1 = var "x1"
-      , clField2 = var "x2"
-      , clMeta   = 0
-      , clCC     = ccVal
-      }
-  , mconcat (map mkClosureCon [3..24])
-  , mconcat (map mkDataFill [1..24])
+  [ mconcat (map mkClosureCon (Nothing : map Just [0..jsClosureCount]))
+  , mconcat (map mkDataFill [1..jsClosureCount])
   ]
   where
     prof = csProf s
@@ -118,19 +90,8 @@ closureConstructors s = BlockStat
       -- 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
 
@@ -172,29 +133,24 @@ closureConstructors s = BlockStat
 
            | otherwise = mempty
 
-    mkClosureCon :: Int -> JStat
-    mkClosureCon n = funName ||= toJExpr fun
+    mkClosureCon :: Maybe Int -> JStat
+    mkClosureCon n0 = funName ||= toJExpr fun
       where
-        funName = TxtI $ mkFastString ("h$c" ++ show n)
+        n | Just n' <- n0 = n'
+          | Nothing <- n0 = 0
+        funName | Just n' <- n0 = TxtI $ clsName n'
+                | Nothing <- n0 = TxtI $ mkFastString "h$c"
         -- args are: f x1 x2 .. xn [cc]
-        args   = TxtI "f" : addCCArg' (map (TxtI . mkFastString . ('x':) . show) [(1::Int)..n])
+        args   = TxtI "f" : addCCArg' (map varName [1..n])
         fun    = JFunc args funBod
         -- x1 goes into closureField1. All the other args are bundled into an
         -- object in closureField2: { d1 = x2, d2 = x3, ... }
         --
-        extra_args = ValExpr . JHash . listToUniqMap $ zip
-                   (map (mkFastString . ('d':) . show) [(1::Int)..])
-                   (map (toJExpr . TxtI . mkFastString . ('x':) . show) [2..n])
+        vars   = map (toJExpr . varName) [1..n]
 
         funBod = jVar $ \x ->
             [ checkC
-            , x |= newClosure Closure
-               { clEntry  = var "f"
-               , clField1 = var "x1"
-               , clField2 = extra_args
-               , clMeta   = 0
-               , clCC     = ccVal
-               }
+            , x |= newClosure (mkClosure (var "f") vars 0 ccVal)
             , notifyAlloc x
             , traceAlloc x
             , returnS x
@@ -203,8 +159,8 @@ closureConstructors s = BlockStat
     mkDataFill :: Int -> JStat
     mkDataFill n = funName ||= toJExpr fun
       where
-        funName    = TxtI $ mkFastString ("h$d" ++ show n)
-        ds         = map (mkFastString . ('d':) . show) [(1::Int)..n]
+        funName    = TxtI $ dataName n
+        ds         = map dataFieldName [1..n]
         extra_args = ValExpr . JHash . listToUniqMap . zip ds $ map (toJExpr . TxtI) ds
         fun        = JFunc (map TxtI ds) (checkD <> returnS extra_args)
 
@@ -215,7 +171,7 @@ stackManip = mconcat (map mkPush [1..32]) <>
   where
     mkPush :: Int -> JStat
     mkPush n = let funName = TxtI $ mkFastString ("h$p" ++ show n)
-                   as      = map (TxtI . mkFastString . ('x':) . show) [1..n]
+                   as      = map varName [1..n]
                    fun     = JFunc as ((sp |= sp + toJExpr n)
                                        <> mconcat (zipWith (\i a -> stack .! (sp - toJExpr (n-i)) |= toJExpr a)
                                                    [1..] as))
@@ -228,7 +184,7 @@ stackManip = mconcat (map mkPush [1..32]) <>
                       bits    = bitsIdx sig
                       n       = length bits
                       h       = last bits
-                      args    = map (TxtI . mkFastString . ('x':) . show) [1..n]
+                      args    = map varName [1..n]
                       fun     = JFunc args $
                         mconcat [ sp |= sp + toJExpr (h+1)
                                 , mconcat (zipWith (\b a -> stack .! (sp - toJExpr (h-b)) |= toJExpr a) bits args)
@@ -288,7 +244,7 @@ loadRegs :: JStat
 loadRegs = mconcat $ map mkLoad [1..32]
   where
     mkLoad :: Int -> JStat
-    mkLoad n = let args   = map (TxtI . mkFastString . ("x"++) . show) [1..n]
+    mkLoad n = let args   = map varName [1..n]
                    assign = zipWith (\a r -> toJExpr r |= toJExpr a)
                               args (reverse $ take n regsFromR1)
                    fname  = TxtI $ mkFastString ("h$l" ++ show n)