diff options
| -rw-r--r-- | compiler/GHC/JS/Make.hs | 44 | ||||
| -rw-r--r-- | compiler/GHC/StgToJS/Closure.hs | 87 | ||||
| -rw-r--r-- | compiler/GHC/StgToJS/DataCon.hs | 18 | ||||
| -rw-r--r-- | compiler/GHC/StgToJS/Expr.hs | 3 | ||||
| -rw-r--r-- | compiler/GHC/StgToJS/Rts/Rts.hs | 76 |
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) |