[Git][ghc/ghc][wip/js-rts-fixmes] Cache names used commonly in JS backend RTS generation
Josh Meredith (@JoshMeredith)
gitlab at gitlab.haskell.org
Thu Feb 2 07:31:31 UTC 2023
Josh Meredith pushed to branch wip/js-rts-fixmes at Glasgow Haskell Compiler / GHC
Commits:
bc14c389 by Josh Meredith at 2023-02-02T07:31:08+00:00
Cache names used commonly in JS backend RTS generation
- - - - -
2 changed files:
- compiler/GHC/JS/Make.hs
- compiler/GHC/StgToJS/Rts/Rts.hs
Changes:
=====================================
compiler/GHC/JS/Make.hs
=====================================
@@ -129,7 +129,10 @@ module GHC.JS.Make
-- * Miscellaneous
-- $misc
, allocData, allocClsA
+ , dataName
+ , clsName
, dataFieldName, dataFieldNames
+ , varName, varNames
)
where
@@ -646,7 +649,7 @@ nFieldCache = 16384
dataFieldName :: Int -> FastString
dataFieldName i
- | i < 1 || i > nFieldCache = panic "dataFieldName" (ppr i)
+ | i < 0 || i > nFieldCache = panic "dataFieldName" (ppr i)
| otherwise = dataFieldCache ! i
dataFieldNames :: [FastString]
@@ -657,6 +660,11 @@ dataFieldNames = fmap dataFieldName [1..nFieldCache]
dataCache :: Array Int FastString
dataCache = listArray (0,1024) (map (mkFastString . ("h$d"++) . show) [(0::Int)..1024])
+dataName :: Int -> FastString
+dataName i
+ | i < 0 || i > 1024 = panic "dataCacheName" (ppr i)
+ | otherwise = dataCache ! i
+
allocData :: Int -> JExpr
allocData i = toJExpr (TxtI (dataCache ! i))
@@ -664,9 +672,26 @@ allocData i = toJExpr (TxtI (dataCache ! i))
clsCache :: Array Int FastString
clsCache = listArray (0,1024) (map (mkFastString . ("h$c"++) . show) [(0::Int)..1024])
+clsName :: Int -> FastString
+clsName i
+ | i < 0 || i > 1024 = panic "clsCacheName" (ppr i)
+ | otherwise = clsCache ! i
+
allocClsA :: Int -> JExpr
allocClsA i = toJExpr (TxtI (clsCache ! i))
+-- | Cache "xXXX" names
+varCache :: Array Int FastString
+varCache = listArray (0,1024) (map (mkFastString . ('x':) . show) [(0::Int)..1024])
+
+varName :: Int -> Ident
+varName i
+ | i < 0 || i > 1024 = panic "varCacheName" (ppr i)
+ | otherwise = TxtI $ varCache ! i
+
+varNames :: [Ident]
+varNames = fmap varName [1..1024]
+
--------------------------------------------------------------------------------
-- New Identifiers
=====================================
compiler/GHC/StgToJS/Rts/Rts.hs
=====================================
@@ -90,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
@@ -149,15 +138,15 @@ closureConstructors s = BlockStat
where
n | Just n' <- n0 = n'
| Nothing <- n0 = 0
- funName | Just n' <- n0 = TxtI $ mkFastString ("h$c" ++ show n')
+ 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' (take n varNames)
fun = JFunc args funBod
-- x1 goes into closureField1. All the other args are bundled into an
-- object in closureField2: { d1 = x2, d2 = x3, ... }
--
- vars = map (var . mkFastString . ('x':) . show) [1..n]
+ vars = map toJExpr $ take n varNames
x1 = case vars of
[] -> null_
@@ -166,9 +155,7 @@ closureConstructors s = BlockStat
[] -> null_
[_] -> null_
[_,x] -> x
- _:x:xs -> ValExpr . JHash . listToUniqMap $ zip
- (map (mkFastString . ('d':) . show) [(1::Int)..])
- (x:xs)
+ _:x:xs -> ValExpr . JHash . listToUniqMap $ zip dataFieldNames (x:xs)
funBod = jVar $ \x ->
[ checkC
@@ -187,10 +174,9 @@ 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]
- extra_args = ValExpr . JHash . listToUniqMap . zip ds $ map (toJExpr . TxtI) ds
- fun = JFunc (map TxtI ds) (checkD <> returnS extra_args)
+ funName = TxtI $ dataName n
+ extra_args = ValExpr . JHash . listToUniqMap . zip dataFieldNames $ map (toJExpr . TxtI) dataFieldNames
+ fun = JFunc (map TxtI dataFieldNames) (checkD <> returnS extra_args)
-- | JS Payload to perform stack manipulation in the RTS
stackManip :: JStat
@@ -199,7 +185,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 = take n varNames
fun = JFunc as ((sp |= sp + toJExpr n)
<> mconcat (zipWith (\i a -> stack .! (sp - toJExpr (n-i)) |= toJExpr a)
[1..] as))
@@ -212,7 +198,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 = take n varNames
fun = JFunc args $
mconcat [ sp |= sp + toJExpr (h+1)
, mconcat (zipWith (\b a -> stack .! (sp - toJExpr (h-b)) |= toJExpr a) bits args)
@@ -272,7 +258,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 = take n varNames
assign = zipWith (\a r -> toJExpr r |= toJExpr a)
args (reverse $ take n regsFromR1)
fname = TxtI $ mkFastString ("h$l" ++ show n)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bc14c389743bcf0f58cc3d73370d40738ab92181
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bc14c389743bcf0f58cc3d73370d40738ab92181
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230202/3b5ddb8a/attachment-0001.html>
More information about the ghc-commits
mailing list