[Git][ghc/ghc][wip/js-staging] Doc
Sylvain Henry (@hsyl20)
gitlab at gitlab.haskell.org
Mon Aug 8 14:40:40 UTC 2022
Sylvain Henry pushed to branch wip/js-staging at Glasgow Haskell Compiler / GHC
Commits:
649f0fea by Sylvain Henry at 2022-08-08T16:43:24+02:00
Doc
- - - - -
7 changed files:
- compiler/GHC/StgToJS/Apply.hs
- compiler/GHC/StgToJS/CoreUtils.hs
- compiler/GHC/StgToJS/Expr.hs
- compiler/GHC/StgToJS/FFI.hs
- compiler/GHC/StgToJS/Regs.hs
- compiler/GHC/StgToJS/Rts/Rts.hs
- compiler/GHC/StgToJS/Types.hs
Changes:
=====================================
compiler/GHC/StgToJS/Apply.hs
=====================================
@@ -16,12 +16,12 @@
-- Stability : experimental
--
--
--- TODO: Write my description!
+-- Module that deals with expression application in JavaScript. In some cases we
+-- rely on pre-generated functions that are bundled with the RTS (see rtsApply).
-----------------------------------------------------------------------------
module GHC.StgToJS.Apply
( genApp
- , mkApplyArr
, rtsApply
)
where
@@ -68,8 +68,28 @@ import qualified Data.Bits as Bits
import Data.Monoid
import Data.Array
+-- | Pre-generated functions for fast Apply.
+-- These are bundled with the RTS.
+rtsApply :: StgToJSConfig -> JStat
+rtsApply cfg = BlockStat $
+ map (uncurry (stackApply cfg)) applySpec
+ ++ map (uncurry (fastApply cfg)) applySpec
+ ++ map (pap cfg) specPap
+ ++ [ mkApplyArr
+ , genericStackApply cfg
+ , genericFastApply cfg
+ , zeroApply cfg
+ , updates cfg
+ , papGen cfg
+ , moveRegs2
+ , selectors cfg
+ ]
+
--- | Generate an application of some args to an Id
+-- | Generate an application of some args to an Id.
+--
+-- The case where args is null is common as it's used to generate the evaluation
+-- code for an Id.
genApp
:: HasDebugCallStack
=> ExprCtx
@@ -89,6 +109,10 @@ genApp ctx i args
-- , matchVarName "ghcjs-prim" "GHCJS.Prim" "unsafeUnpackJSStringUtf8##" i =
-- (,ExprInline Nothing) . (|=) top . app "h$decodeUtf8z" <$> genIds v
+ -- Case: unpackCStringAppend# "some string"# str
+ --
+ -- Generates h$appendToHsStringA(str, "some string"), which has a faster
+ -- decoding loop.
| [StgLitArg (LitString bs), x] <- args
, [top] <- concatMap typex_expr (ctxTarget ctx)
, getUnique i == unpackCStringAppendIdKey
@@ -120,12 +144,27 @@ genApp ctx i args
, [top] <- concatMap typex_expr (ctxTarget ctx)
= return (top |= null_, ExprInline Nothing)
+ -- unboxed tuple or strict type: return fields individually
| [] <- args
, isUnboxedTupleType (idType i) || isStrictType (idType i)
= do
- a <- assignCoerce1 (ctxTarget ctx) . (alignIdExprs i) <$> genIds i
+ a <- storeIdFields i (ctxTarget ctx)
return (a, ExprInline Nothing)
+ -- Handle alternative heap object representation: in some cases, a heap
+ -- object is not represented as a JS object but directly as a number or a
+ -- string. I.e. only the payload is stored because the box isn't useful.
+ -- It happens for "Int Int#" for example: no need to box the Int# in JS.
+ --
+ -- We must check that:
+ -- - the object is subject to the optimization (cf isUnboxable predicate)
+ -- - we know that it is already evaluated (cf ctxIsEvaluated), otherwise we
+ -- need to evaluate it properly first.
+ --
+ -- In which case we generate a dynamic check (using isObject) that either:
+ -- - returns the payload of the heap object, if it uses the generic heap
+ -- object representation
+ -- - returns the object directly, otherwise
| [] <- args
, [vt] <- idVt i
, isUnboxable vt
@@ -140,10 +179,13 @@ genApp ctx i args
)
_ -> panic "genApp: invalid size"
+ -- case of Id without args and known to be already evaluated: return fields
+ -- individually
| [] <- args
, ctxIsEvaluated ctx i || isStrictId i
= do
- a <- assignCoerce1 (ctxTarget ctx) . (alignIdExprs i) <$> genIds i
+ a <- storeIdFields i (ctxTarget ctx)
+ -- optional runtime assert for detecting unexpected thunks (unevaluated)
settings <- getSettings
let ww = case concatMap typex_expr (ctxTarget ctx) of
[t] | csAssertRts settings ->
@@ -153,6 +195,11 @@ genApp ctx i args
_ -> mempty
return (a `mappend` ww, ExprInline Nothing)
+
+ -- Case: "newtype" datacon wrapper
+ --
+ -- If the wrapped argument is known to be already evaluated, then we don't
+ -- need to enter it.
| DataConWrapId dc <- idDetails i
, isNewTyCon (dataConTyCon dc)
= do
@@ -168,23 +215,36 @@ genApp ctx i args
else return (returnS (app "h$e" [ai]), ExprCont)
_ -> panic "genApp: invalid size"
+ -- no args and Id can't be a function: just enter it
| [] <- args
, idFunRepArity i == 0
, not (might_be_a_function (idType i))
= do
- ii <- enterId
- return (returnS (app "h$e" [ii]), ExprCont)
-
+ enter_id <- genArg (StgVarArg i) >>=
+ \case
+ [x] -> return x
+ xs -> pprPanic "genApp: unexpected multi-var argument"
+ (vcat [ppr (length xs), ppr i])
+ return (returnS (app "h$e" [enter_id]), ExprCont)
+
+ -- fully saturated global function:
+ -- - deals with arguments
+ -- - jumps into the function
| n <- length args
, n /= 0
, idFunRepArity i == n
- , not (isLocalId i)
+ , not (isLocalId i) -- FIXME (Sylvain 2022-08): why are we testing this here and not in the oversaturated case below?
, isStrictId i
= do
as' <- concatMapM genArg args
- jmp <- jumpToII i as' =<< r1
+ is <- assignAll jsRegsFromR1 <$> genIds i
+ jmp <- jumpToII i as' is
return (jmp, ExprCont)
+ -- oversaturated function:
+ -- - push continuation with extra args
+ -- - deals with arguments
+ -- - jumps into the function
| idFunRepArity i < length args
, isStrictId i
, idFunRepArity i > 0
@@ -192,25 +252,19 @@ genApp ctx i args
let (reg,over) = splitAt (idFunRepArity i) args
reg' <- concatMapM genArg reg
pc <- pushCont over
- jmp <- jumpToII i reg' =<< r1
+ is <- assignAll jsRegsFromR1 <$> genIds i
+ jmp <- jumpToII i reg' is
return (pc <> jmp, ExprCont)
+ -- generic apply:
+ -- - try to find a pre-generated apply function that matches
+ -- - use it if any
+ -- - otherwise use generic apply function h$ap_gen_fast
| otherwise
= do
- jmp <- jumpToFast args =<< r1
+ is <- assignAll jsRegsFromR1 <$> genIds i
+ jmp <- jumpToFast args is
return (jmp, ExprCont)
- where
- enterId :: G JExpr
- enterId = genArg (StgVarArg i) >>=
- \case
- [x] -> return x
- xs -> pprPanic "genApp: unexpected multi-var argument"
- (vcat [ppr (length xs), ppr i])
-
- r1 :: G JStat
- r1 = do
- ids <- genIds i
- return $ mconcat $ zipWith (\r u -> toJExpr r |= toJExpr u) (enumFrom R1) ids
-- avoid one indirection for global ids
-- fixme in many cases we can also jump directly to the entry for local?
@@ -231,38 +285,40 @@ jumpToII i args afterLoad
, returnS ei
]
where
- ra = mconcat . reverse $ zipWith (\r a -> toJExpr r |= a) (enumFrom R2) args
+ ra = mconcat . reverse $ zipWith (\r a -> r |= a) jsRegsFromR2 args
+-- | Try to use a specialized pre-generated application function.
+-- If there is none, use h$ap_gen_fast instead
jumpToFast :: HasDebugCallStack => [StgArg] -> JStat -> G JStat
jumpToFast as afterLoad = do
regs <- concatMapM genArg as
- (fun, spec) <- selectApply True (as,regs)
+ spec <- selectApply True as regs
pure $ mconcat
[ mconcat (ra regs)
, afterLoad
- , if spec
- then returnS (ApplExpr fun [])
- else returnS (ApplExpr fun [toJExpr (mkTag regs as)])
+ , case spec of
+ Right fun -> returnS (ApplExpr fun [])
+ Left fun -> returnS (ApplExpr fun [toJExpr (mkTag regs as)])
]
where
- ra regs = reverse $ zipWith (\r ex -> toJExpr r |= ex) (enumFrom R2) regs
+ ra regs = reverse $ zipWith (\r ex -> r |= ex) jsRegsFromR2 regs
mkTag rs as = (length rs `Bits.shiftL` 8) Bits..|. length as
--- find a specialized application path if there is one
+-- | Find a specialized application function if there is one
selectApply
- :: Bool -- ^ true for fast apply, false for stack apply
- -> ([StgArg], [JExpr]) -- ^ arguments
- -> G (JExpr, Bool) -- ^ the function to call, true if specialized path
-selectApply fast (args, as) =
+ :: Bool -- ^ true for fast apply, false for stack apply
+ -> [StgArg] -- ^ Raw arguments
+ -> [JExpr] -- ^ JS arguments
+ -> G (Either JExpr JExpr) -- ^ the function to call (Left for generic, Right for specialized)
+selectApply fast args as =
case specApply fast (length args) (length as) of
- Just e -> return (e, True)
- Nothing -> return (var $ "h$ap_gen" <> fastSuff, False)
+ Just e -> return (Right e)
+ Nothing -> return (Left (var $ "h$ap_gen" <> fastSuff))
where
fastSuff | fast = "_fast"
| otherwise = ""
-
-- specialized apply for these
-- make sure that once you are in spec, you stay there
applySpec :: [(Int,Int)] -- regs,arity
@@ -317,62 +373,81 @@ mkApplyArr = mconcat
assignPap p = var "h$paps" .! toJExpr p |=
(var (mkFastString $ ("h$pap_" ++ show p)))
+-- | Push a continuation on the stack
+--
+-- First push the given args, then push an apply function (specialized if
+-- possible, otherwise the generic h$ap_gen function).
pushCont :: HasDebugCallStack
=> [StgArg]
-> G JStat
pushCont as = do
as' <- concatMapM genArg as
- (app, spec) <- selectApply False (as,as')
- if spec
- then push $ reverse $ app : as'
- else push $ reverse $ app : mkTag as' as : as'
+ spec <- selectApply False as as'
+ case spec of
+ Right app -> push $ reverse $ app : as'
+ Left app -> push $ reverse $ app : mkTag as' as : as'
where
mkTag rs ns = toJExpr ((length rs `Bits.shiftL` 8) Bits..|. length ns)
-rtsApply :: StgToJSConfig -> JStat
-rtsApply cfg = BlockStat $
- map (uncurry (stackApply cfg)) applySpec
- ++ map (uncurry (fastApply cfg)) applySpec
- ++ map (pap cfg) specPap
- ++ [ mkApplyArr
- , genericStackApply cfg
- , genericFastApply cfg
- , zeroApply cfg
- , updates cfg
- , papGen cfg
- , moveRegs2
- , selectors cfg
- ]
-
--- generic stack apply that can do everything, but less efficiently
--- on stack: tag: (regs << 8 | arity)
--- fixme: set closure info of stack frame
+-- | Generic stack apply function (h$ap_gen) that can do everything, but less
+-- efficiently than other more specialized functions.
+--
+-- Stack layout:
+-- 0. tag: (regs << 8 | arity)
+-- 1. args
+--
+-- Regs:
+-- R1 = closure to apply to
+--
+-- FIXME: set closure info of stack frame
genericStackApply :: StgToJSConfig -> JStat
-genericStackApply s =
- closure (ClosureInfo "h$ap_gen" (CIRegs 0 [PtrV]) "h$ap_gen" CILayoutVariable CIStackFrame mempty)
- (jVar \cf ->
- [ traceRts s (jString "h$ap_gen")
- , cf |= closureEntry r1
- , SwitchStat (entryClosureType cf)
- [ (toJExpr Thunk, profStat s pushRestoreCCS <> returnS cf)
- , (toJExpr Fun, funCase cf (funArity' cf))
- , (toJExpr Pap, funCase cf (papArity r1))
- , (toJExpr Blackhole, push' s [r1, var "h$return"]
- <> returnS (app "h$blockOnBlackhole" [r1]))
- ] (appS "throw" [jString "h$ap_gen: unexpected closure type " + (entryClosureType cf)])
- ]
- )
+genericStackApply cfg =
+ closure info $ jVar \cf ->
+ [ traceRts cfg (jString "h$ap_gen")
+ , cf |= closureEntry r1
+ -- switch on closure type
+ , SwitchStat (entryClosureType cf)
+ [ (toJExpr Thunk , thunk_case cfg cf)
+ , (toJExpr Fun , fun_case cf (funArity' cf))
+ , (toJExpr Pap , fun_case cf (papArity r1))
+ , (toJExpr Blackhole, blackhole_case cfg)
+ ]
+ (default_case cf)
+ ]
where
- funCase c arity = jVar \myArity ar myAr myRegs regs newTag newAp p dat ->
+ -- info table for h$ap_gen
+ info = ClosureInfo
+ { ciVar = "h$ap_gen"
+ , ciRegs = CIRegs 0 [PtrV] -- closure to apply to
+ , ciName = "h$ap_gen"
+ , ciLayout = CILayoutVariable
+ , ciType = CIStackFrame
+ , ciStatic = mempty
+ }
+
+ default_case cf = appS "throw" [jString "h$ap_gen: unexpected closure type "
+ + (entryClosureType cf)]
+
+ thunk_case cfg cf = mconcat
+ [ profStat cfg pushRestoreCCS
+ , returnS cf
+ ]
+
+ blackhole_case cfg = mconcat
+ [ push' cfg [r1, var "h$return"]
+ , returnS (app "h$blockOnBlackhole" [r1])
+ ]
+
+ fun_case c arity = jVar \myArity ar myAr myRegs regs newTag newAp p dat ->
[ myArity |= stack .! (sp - 1)
, ar |= mask8 arity
, myAr |= mask8 myArity
, myRegs |= myArity .>>. 8
- , traceRts s (jString "h$ap_gen: args: " + myAr
+ , traceRts cfg (jString "h$ap_gen: args: " + myAr
+ jString " regs: " + myRegs)
, ifBlockS (myAr .===. ar)
-- then
- [ traceRts s (jString "h$ap_gen: exact")
+ [ traceRts cfg (jString "h$ap_gen: exact")
, loop 0 (.<. myRegs)
(\i -> appS "h$setReg" [i+2, stack .! (sp-2-i)]
<> postIncrS i)
@@ -383,40 +458,44 @@ genericStackApply s =
[ ifBlockS (myAr .>. ar)
--then
[ regs |= arity .>>. 8
- , traceRts s (jString "h$ap_gen: oversat: arity: " + ar
+ , traceRts cfg (jString "h$ap_gen: oversat: arity: " + ar
+ jString " regs: " + regs)
, loop 0 (.<. regs)
- (\i -> traceRts s (jString "h$ap_gen: loading register: " + i)
+ (\i -> traceRts cfg (jString "h$ap_gen: loading register: " + i)
<> appS "h$setReg" [i+2, stack .! (sp-2-i)]
<> postIncrS i)
, newTag |= ((myRegs-regs).<<.8).|.myAr - ar
, newAp |= var "h$apply" .! newTag
- , traceRts s (jString "h$ap_gen: next: " + (newAp .^ "n"))
+ , traceRts cfg (jString "h$ap_gen: next: " + (newAp .^ "n"))
, ifS (newAp .===. var "h$ap_gen")
((sp |= sp - regs) <> (stack .! (sp - 1) |= newTag))
(sp |= sp - regs - 1)
, stack .! sp |= newAp
- , profStat s pushRestoreCCS
+ , profStat cfg pushRestoreCCS
, returnS c
]
-- else
- [ traceRts s (jString "h$ap_gen: undersat")
+ [ traceRts cfg (jString "h$ap_gen: undersat")
, p |= var "h$paps" .! myRegs
, dat |= toJExpr [r1, ((arity .>>. 8)-myRegs)*256+ar-myAr]
, loop 0 (.<. myRegs)
(\i -> (dat .^ "push") `ApplStat` [stack .! (sp - i - 2)]
<> postIncrS i)
, sp |= sp - myRegs - 2
- , r1 |= initClosure s p dat jCurrentCCS
+ , r1 |= initClosure cfg p dat jCurrentCCS
, returnStack
]
]
]
-{-
- generic fast apply: can handle anything (slowly)
- signature tag in argument
--}
+-- | Generic fast apply function (h$ap_gen_fast) that can do everything, but less
+-- efficiently than other more specialized functions.
+--
+-- Signature tag in argument. Tag: (regs << 8 | arity)
+--
+-- Regs:
+-- R1 = closure to apply to
+--
genericFastApply :: StgToJSConfig -> JStat
genericFastApply s =
TxtI "h$ap_gen_fast" ||= jLam \tag -> jVar \c ->
@@ -512,7 +591,7 @@ genericFastApply s =
]
where
pushReg :: Int -> (JExpr, JStat)
- pushReg r = (toJExpr (r-1), stack .! (sp - toJExpr (r - 2)) |= toJExpr (intToJSReg r))
+ pushReg r = (toJExpr (r-1), stack .! (sp - toJExpr (r - 2)) |= jsReg r)
pushArgs :: JExpr -> JExpr -> JStat
pushArgs start end =
@@ -548,7 +627,7 @@ stackApply s r n =
] (appS "throw" [toJExpr ("panic: " <> funcName <> ", unexpected closure type: ") + (entryClosureType c)])
]
- funExact c = popSkip' 1 (reverse $ take r (map toJExpr $ enumFrom R2)) <> returnS c
+ funExact c = popSkip' 1 (reverse $ take r jsRegsFromR2) <> returnS c
stackArgs = map (\x -> stack .! (sp - toJExpr x)) [1..r]
papCase :: JExpr -> JStat
@@ -620,7 +699,7 @@ stackApply s r n =
where
loadRegs rs = SwitchStat rs switchAlts mempty
where
- switchAlts = map (\x -> (toJExpr x, toJExpr (intToJSReg (x+1)) |= stack .! (sp - toJExpr x))) [r,r-1..1]
+ switchAlts = map (\x -> (toJExpr x, jsReg (x+1) |= stack .! (sp - toJExpr x))) [r,r-1..1]
{-
stg_ap_r_n_fast is entered if a function of unknown arity
@@ -634,7 +713,7 @@ fastApply s r n = func ||= toJExpr (JFunc myFunArgs body)
myFunArgs = []
- regArgs = take r (enumFrom R2)
+ regArgs = take r jsRegsFromR2
mkAp :: Int -> Int -> [JExpr]
mkAp n' r' = [ var . mkFastString $ "h$ap_" ++ show n' ++ "_" ++ show r' ]
@@ -651,8 +730,8 @@ fastApply s r n = func ||= toJExpr (JFunc myFunArgs body)
<> (farity |= funArity' c)
<> funCase c farity)
,(toJExpr Pap, traceRts s (toJExpr (funName <> ": pap")) <> (arity |= papArity r1) <> funCase c arity)
- ,(toJExpr Thunk, traceRts s (toJExpr (funName <> ": thunk")) <> push' s (reverse (map toJExpr $ take r (enumFrom R2)) ++ mkAp n r) <> profStat s pushRestoreCCS <> returnS c)
- ,(toJExpr Blackhole, traceRts s (toJExpr (funName <> ": blackhole")) <> push' s (reverse (map toJExpr $ take r (enumFrom R2)) ++ mkAp n r) <> push' s [r1, var "h$return"] <> returnS (app "h$blockOnBlackhole" [r1]))]
+ ,(toJExpr Thunk, traceRts s (toJExpr (funName <> ": thunk")) <> push' s (reverse regArgs ++ mkAp n r) <> profStat s pushRestoreCCS <> returnS c)
+ ,(toJExpr Blackhole, traceRts s (toJExpr (funName <> ": blackhole")) <> push' s (reverse regArgs ++ mkAp n r) <> push' s [r1, var "h$return"] <> returnS (app "h$blockOnBlackhole" [r1]))]
(appS "throw" [toJExpr (funName <> ": unexpected closure type: ") + entryClosureType c])
]
@@ -668,7 +747,7 @@ fastApply s r n = func ||= toJExpr (JFunc myFunArgs body)
(traceRts s (toJExpr (funName <> ": oversat")) <> oversatCase c arity)
-- else
(traceRts s (toJExpr (funName <> ": undersat"))
- <> mkPap s pap r1 (toJExpr n) (map toJExpr regArgs)
+ <> mkPap s pap r1 (toJExpr n) regArgs
<> (r1 |= toJExpr pap)
<> returnStack))
]
@@ -698,7 +777,7 @@ fastApply s r n = func ||= toJExpr (JFunc myFunArgs body)
where
saveRegs n = SwitchStat n switchAlts mempty
where
- switchAlts = map (\x -> (toJExpr x, stack .! (sp + toJExpr (r-x)) |= toJExpr (intToJSReg (x+2)))) [0..r-1]
+ switchAlts = map (\x -> (toJExpr x, stack .! (sp + toJExpr (r-x)) |= jsReg (x+2))) [0..r-1]
zeroApply :: StgToJSConfig -> JStat
zeroApply s = mconcat
@@ -896,9 +975,9 @@ pap s r = closure (ClosureInfo funcName CIRegsUnknown funcName (CILayoutUnknown
]
moveBy extra = SwitchStat extra
(reverse $ map moveCase [1..maxReg-r-1]) mempty
- moveCase m = (toJExpr m, toJExpr (intToJSReg (m+r+1)) |= toJExpr (intToJSReg (m+1)))
+ moveCase m = (toJExpr m, jsReg (m+r+1) |= jsReg (m+1))
loadOwnArgs d = mconcat $ map (\r ->
- toJExpr (intToJSReg (r+1)) |= dField d (r+2)) [1..r]
+ jsReg (r+1) |= dField d (r+2)) [1..r]
dField d n = SelExpr d (TxtI . mkFastString $ ('d':show (n-1)))
-- Construct a generic PAP
@@ -928,7 +1007,7 @@ papGen cfg =
funcName = "h$pap_gen"
loadOwnArgs d r =
let prop n = d .^ ("d" <> mkFastString (show $ n+1))
- loadOwnArg n = (toJExpr n, toJExpr (intToJSReg (n+1)) |= prop n)
+ loadOwnArg n = (toJExpr n, jsReg (n+1) |= prop n)
in SwitchStat r (map loadOwnArg [127,126..1]) mempty
-- general utilities
@@ -946,7 +1025,7 @@ moveRegs2 = TxtI "h$moveRegs2" ||= jLam moveSwitch
(n `Bits.shiftL` 8) Bits..|. m
, mconcat (map (`moveRegFast` m) [n+1,n..2])
<> BreakStat Nothing {-[j| break; |]-})
- moveRegFast n m = toJExpr (intToJSReg (n+m)) |= toJExpr (intToJSReg n)
+ moveRegFast n m = jsReg (n+m) |= jsReg n
-- fallback
defaultCase n m =
loop n (.>.0) (\i -> appS "h$setReg" [i+1+m, app "h$getReg" [i+1]] `mappend` postDecrS i)
@@ -967,3 +1046,12 @@ initClosure cfg entry values ccs =
, values
]
+-- | Return an expression for every field of the given Id
+getIdFields :: Id -> G [TypedExpr]
+getIdFields i = assocIdExprs i <$> genIds i
+
+-- | Store fields of Id into the given target expressions
+storeIdFields :: Id -> [TypedExpr] -> G JStat
+storeIdFields i dst = do
+ fields <- getIdFields i
+ pure (assignCoerce1 dst fields)
=====================================
compiler/GHC/StgToJS/CoreUtils.hs
=====================================
@@ -49,6 +49,7 @@ isUnboxable DoubleV = True
isUnboxable IntV = True -- includes Char#
isUnboxable _ = False
+-- | Number of slots occupied by a PrimRep
data SlotCount
= NoSlot
| OneSlot
@@ -58,15 +59,18 @@ data SlotCount
instance Outputable SlotCount where
ppr = text . show
-varSize :: VarType -> Int
-varSize = slotCount . varSlotCount
-
+-- | Return SlotCount as an Int
slotCount :: SlotCount -> Int
slotCount = \case
NoSlot -> 0
OneSlot -> 1
TwoSlots -> 2
+
+-- | Number of slots occupied by a value with the given VarType
+varSize :: VarType -> Int
+varSize = slotCount . varSlotCount
+
varSlotCount :: VarType -> SlotCount
varSlotCount VoidV = NoSlot
varSlotCount LongV = TwoSlots -- hi, low
@@ -240,21 +244,25 @@ typePrimReps = typePrimRep . unwrapType
primRepSize :: PrimRep -> SlotCount
primRepSize p = varSlotCount (primRepVt p)
--- | Assign values to each prim rep slot
-alignPrimReps :: Outputable a => [PrimRep] -> [a] -> [(PrimRep, [a])]
-alignPrimReps [] _ = []
-alignPrimReps (r:rs) vs = case (primRepSize r,vs) of
- (NoSlot, xs) -> (r,[]) : alignPrimReps rs xs
- (OneSlot, x:xs) -> (r,[x]) : alignPrimReps rs xs
- (TwoSlots, x:y:xs) -> (r,[x,y]) : alignPrimReps rs xs
- err -> pprPanic "alignPrimReps" (ppr err)
-
-alignIdPrimReps :: Outputable a => Id -> [a] -> [(PrimRep, [a])]
-alignIdPrimReps i = alignPrimReps (idPrimReps i)
-
-
-alignIdExprs :: Id -> [JExpr] -> [TypedExpr]
-alignIdExprs i es = fmap (uncurry TypedExpr) (alignIdPrimReps i es)
+-- | Associate the given values to each RrimRep in the given order, taking into
+-- account the number of slots per PrimRep
+assocPrimReps :: Outputable a => [PrimRep] -> [a] -> [(PrimRep, [a])]
+assocPrimReps [] _ = []
+assocPrimReps (r:rs) vs = case (primRepSize r,vs) of
+ (NoSlot, xs) -> (r,[]) : assocPrimReps rs xs
+ (OneSlot, x:xs) -> (r,[x]) : assocPrimReps rs xs
+ (TwoSlots, x:y:xs) -> (r,[x,y]) : assocPrimReps rs xs
+ err -> pprPanic "assocPrimReps" (ppr err)
+
+-- | Associate the given values to the Id's PrimReps, taking into account the
+-- number of slots per PrimRep
+assocIdPrimReps :: Outputable a => Id -> [a] -> [(PrimRep, [a])]
+assocIdPrimReps i = assocPrimReps (idPrimReps i)
+
+-- | Associate the given JExpr to the Id's PrimReps, taking into account the
+-- number of slots per PrimRep
+assocIdExprs :: Id -> [JExpr] -> [TypedExpr]
+assocIdExprs i es = fmap (uncurry TypedExpr) (assocIdPrimReps i es)
-- | Return False only if we are *sure* it's a data type
-- Look through newtypes etc as much as possible
=====================================
compiler/GHC/StgToJS/Expr.hs
=====================================
@@ -62,7 +62,6 @@ import qualified Control.Monad.Trans.State.Strict as State
import GHC.Data.FastString
import qualified GHC.Data.List.SetOps as ListSetOps
-import Data.Ord
import Data.Monoid
import Data.Maybe
import Data.Function
@@ -154,7 +153,7 @@ genBind ctx bndr =
| snd (isInlineExpr (ctxEvaluatedIds ctx) expr) = do
d <- declIds b
tgt <- genIds b
- let ctx' = ctx { ctxTarget = alignIdExprs b tgt }
+ let ctx' = ctx { ctxTarget = assocIdExprs b tgt }
(j, _) <- genExpr ctx' expr
return (Just (d <> j))
assign _b StgRhsCon{} = return Nothing
@@ -289,12 +288,12 @@ genBody ctx i startReg args e = do
la <- loadArgs startReg args
lav <- verifyRuntimeReps args
let ids :: [TypedExpr]
- ids = -- take (resultSize args $ idType i) (map toJExpr $ enumFrom R1)
+ ids = -- take (resultSize args $ idType i) jsRegsFromR1
reverse . fst $
foldl' (\(rs, vs) (rep, size) ->
let (vs0, vs1) = splitAt size vs
in (TypedExpr rep vs0:rs,vs1))
- ([], map toJExpr $ enumFrom R1)
+ ([], jsRegsFromR1)
(resultSize args $ idType i)
(e, _r) <- genExpr (ctx { ctxTarget = ids }) e
return $ la <> lav <> e <> returnStack
@@ -341,7 +340,7 @@ resultSize [] t
-- RuntimeRep.
-- FIXME: Luite (2022,07): typeLevity_maybe can panic, doesn't the next case
-- give us the right answer?
- -- | Nothing <- typeLevity_maybe t' = [(LiftedRep, 1)]
+ -- Nothing <- typeLevity_maybe t' = [(LiftedRep, 1)]
| otherwise = fmap (\p -> (p, slotCount (primRepSize p))) (typePrimReps t)
where
t' = unwrapType t
@@ -521,7 +520,7 @@ genCase ctx bnd e at alts l
| snd (isInlineExpr (ctxEvaluatedIds ctx) e) = withNewIdent $ \ccsVar -> do
bndi <- genIdsI bnd
let ctx' = ctxSetTop bnd
- $ ctxSetTarget (alignIdExprs bnd (map toJExpr bndi))
+ $ ctxSetTarget (assocIdExprs bnd (map toJExpr bndi))
$ ctx
(ej, r) <- genExpr ctx' e
let d = case r of
@@ -547,7 +546,7 @@ genCase ctx bnd e at alts l
| otherwise = do
rj <- genRet (ctxAssertEvaluated bnd ctx) bnd at alts l
let ctx' = ctxSetTop bnd
- $ ctxSetTarget (alignIdExprs bnd (map toJExpr [R1 ..]))
+ $ ctxSetTarget (assocIdExprs bnd (map toJExpr [R1 ..]))
$ ctx
(ej, _r) <- genExpr ctx' e
return (rj <> ej, ExprCont)
@@ -733,7 +732,7 @@ normalizeBranches ctx brs
(ExprInline Nothing, brs)
where
mkCont b = case branch_result b of
- ExprInline{} -> b { branch_stat = branch_stat b <> assignAll (map toJExpr $ enumFrom R1)
+ ExprInline{} -> b { branch_stat = branch_stat b <> assignAll jsRegsFromR1
(concatMap typex_expr $ ctxTarget ctx)
, branch_result = ExprCont
}
=====================================
compiler/GHC/StgToJS/FFI.hs
=====================================
@@ -332,7 +332,7 @@ genForeignCall ctx (CCall (CCallSpec ccTarget cconv safety)) t tgt args = do
async | isJsCc = playInterruptible safety
| otherwise = playInterruptible safety || playSafe safety
- tgt' | async = take (length tgt) (map toJExpr $ enumFrom R1)
+ tgt' | async = take (length tgt) jsRegsFromR1
| otherwise = tgt
wrapperPrefix = "ghczuwrapperZC"
=====================================
compiler/GHC/StgToJS/Regs.hs
=====================================
@@ -6,9 +6,14 @@ module GHC.StgToJS.Regs
, sp
, stack
, r1, r2, r3, r4
+ , regsFromR1
+ , regsFromR2
+ , jsRegsFromR1
+ , jsRegsFromR2
, StgRet (..)
, jsRegToInt
, intToJSReg
+ , jsReg
, maxReg
, minReg
)
@@ -107,18 +112,38 @@ jsRegToInt = (+1) . fromEnum
intToJSReg :: Int -> StgReg
intToJSReg r = toEnum (r - 1)
+jsReg :: Int -> JExpr
+jsReg r = toJExpr (intToJSReg r)
+
maxReg :: Int
maxReg = jsRegToInt maxBound
minReg :: Int
minReg = jsRegToInt minBound
+
+-- | List of registers, starting from R1
+regsFromR1 :: [StgReg]
+regsFromR1 = enumFrom R1
+
+-- | List of registers, starting from R2
+regsFromR2 :: [StgReg]
+regsFromR2 = tail regsFromR1
+
+-- | List of registers, starting from R1 as JExpr
+jsRegsFromR1 :: [JExpr]
+jsRegsFromR1 = fmap toJExpr regsFromR1
+
+-- | List of registers, starting from R2 as JExpr
+jsRegsFromR2 :: [JExpr]
+jsRegsFromR2 = tail jsRegsFromR1
+
---------------------------------------------------
-- caches
---------------------------------------------------
-- cache JExpr representing StgReg
registers :: Array StgReg JExpr
-registers = listArray (minBound, maxBound) (map regN (enumFrom R1))
+registers = listArray (minBound, maxBound) (map regN regsFromR1)
where
regN r
| fromEnum r < 32 = var . mkFastString . ("h$"++) . map toLower . show $ r
=====================================
compiler/GHC/StgToJS/Rts/Rts.hs
=====================================
@@ -51,7 +51,6 @@ import Data.Array
import Data.Monoid
import Data.Char (toLower, toUpper)
import qualified Data.Bits as Bits
-import qualified Data.Map as M
-----------------------------------------------------------------------------
@@ -313,9 +312,9 @@ regGettersSetters =
]
where
getRegCases =
- map (\r -> (toJExpr (jsRegToInt r) , returnS (toJExpr r))) (enumFrom R1)
+ map (\r -> (toJExpr (jsRegToInt r) , returnS (toJExpr r))) regsFromR1
setRegCases v =
- map (\r -> (toJExpr (jsRegToInt r), (toJExpr r |= toJExpr v) <> returnS undefined_)) (enumFrom R1)
+ map (\r -> (toJExpr (jsRegToInt r), (toJExpr r |= toJExpr v) <> returnS undefined_)) regsFromR1
loadRegs :: JStat
loadRegs = mconcat $ map mkLoad [1..32]
@@ -329,8 +328,8 @@ loadRegs = mconcat $ map mkLoad [1..32]
-- structure to hold the regs. Or perhaps we
-- steal the indices from the registers array?
-- Either way we can avoid allocating this
- -- intermediate `enumFrom R1` list
- args (reverse $ take n (enumFrom R1))
+ -- intermediate `regsFromR1` list
+ args (reverse $ take n regsFromR1)
fname = TxtI $ mkFastString ("h$l" ++ show n)
fun = JFunc args (mconcat assign)
in fname ||= toJExpr fun
@@ -343,7 +342,7 @@ assignRegs s xs
| l <= 32 && not (csInlineLoadRegs s)
= ApplStat (ValExpr (JVar $ assignRegs'!l)) (reverse xs)
| otherwise = mconcat . reverse $
- zipWith (\r ex -> toJExpr r |= ex) (take l $ enumFrom R1) xs
+ zipWith (\r ex -> toJExpr r |= ex) (take l regsFromR1) xs
where
l = length xs
=====================================
compiler/GHC/StgToJS/Types.hs
=====================================
@@ -76,11 +76,11 @@ data StgToJSConfig = StgToJSConfig
data ClosureInfo = ClosureInfo
{ ciVar :: FastString -- ^ object being infod
- , ciRegs :: CIRegs -- ^ things in registers when this is the next closure to enter
+ , ciRegs :: CIRegs -- ^ things in registers when this is the next closure to enter
, ciName :: FastString -- ^ friendly name for printing
- , ciLayout :: CILayout -- ^ heap/stack layout of the object
- , ciType :: CIType -- ^ type of the object, with extra info where required
- , ciStatic :: CIStatic -- ^ static references of this object
+ , ciLayout :: CILayout -- ^ heap/stack layout of the object
+ , ciType :: CIType -- ^ type of the object, with extra info where required
+ , ciStatic :: CIStatic -- ^ static references of this object
}
deriving stock (Eq, Show, Generic)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/649f0fea423cd5d52316b9b16d5015093250f63f
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/649f0fea423cd5d52316b9b16d5015093250f63f
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/20220808/ebf55dc8/attachment-0001.html>
More information about the ghc-commits
mailing list