[Git][ghc/ghc][master] JS: cleanup to prepare for #24743
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Wed May 1 21:24:28 UTC 2024
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
ca13075c by Sylvain Henry at 2024-05-01T17:23:47-04:00
JS: cleanup to prepare for #24743
- - - - -
9 changed files:
- compiler/GHC/StgToJS/Apply.hs
- compiler/GHC/StgToJS/Arg.hs
- compiler/GHC/StgToJS/Closure.hs
- compiler/GHC/StgToJS/CodeGen.hs
- compiler/GHC/StgToJS/Expr.hs
- compiler/GHC/StgToJS/Heap.hs
- compiler/GHC/StgToJS/Rts/Rts.hs
- compiler/GHC/StgToJS/Stack.hs
- compiler/GHC/StgToJS/Types.hs
Changes:
=====================================
compiler/GHC/StgToJS/Apply.hs
=====================================
@@ -246,7 +246,7 @@ jumpToII i vars load_app_in_r1
return $ mconcat
[ assignAllReverseOrder jsRegsFromR2 vars
, load_app_in_r1
- , returnS (closureEntry ii)
+ , returnS (closureInfo ii)
]
| otherwise = do
ei <- varForEntryId i
@@ -449,14 +449,14 @@ genericStackApply cfg = closure info body
where
-- h$ap_gen body
body = jVar $ \cf ->
- do fun <- fun_case cf (funArity' cf)
+ do fun <- fun_case cf (infoFunArity cf)
pap <- fun_case cf (papArity r1)
return $
mconcat $
[ traceRts cfg (jString "h$ap_gen")
- , cf |= closureEntry r1
+ , cf |= closureInfo r1
-- switch on closure type
- , SwitchStat (entryClosureType cf)
+ , SwitchStat (infoClosureType cf)
[ (toJExpr Thunk , thunk_case cfg cf)
, (toJExpr Fun , fun)
, (toJExpr Pap , pap)
@@ -476,7 +476,7 @@ genericStackApply cfg = closure info body
}
default_case cf = appS "throw" [jString "h$ap_gen: unexpected closure type "
- + (entryClosureType cf)]
+ + (infoClosureType cf)]
thunk_case cfg cf = mconcat
[ profStat cfg pushRestoreCCS
@@ -596,7 +596,7 @@ genericFastApply s =
fast_fun <- jVar \farity ->
do fast_fun <- funCase c tag farity
return $ mconcat $
- [ farity |= funArity' c
+ [ farity |= infoFunArity c
, traceRts s (jString "h$ap_gen_fast: fun " + farity)
, fast_fun]
fast_pap <- jVar \parity ->
@@ -608,8 +608,8 @@ genericFastApply s =
]
return $ mconcat $
[traceRts s (jString "h$ap_gen_fast: " + tag)
- , c |= closureEntry r1
- , SwitchStat (entryClosureType c)
+ , c |= closureInfo r1
+ , SwitchStat (infoClosureType c)
[ (toJExpr Thunk, traceRts s (jString "h$ap_gen_fast: thunk")
<> push_stk_app
<> returnS c)
@@ -623,7 +623,7 @@ genericFastApply s =
<> push_stk_app
<> push' s [r1, var "h$return"]
<> returnS (app "h$blockOnBlackhole" [r1]))
- ] $ appS "throw" [jString "h$ap_gen_fast: unexpected closure type: " + entryClosureType c]
+ ] $ appS "throw" [jString "h$ap_gen_fast: unexpected closure type: " + infoClosureType c]
]
where
@@ -729,8 +729,22 @@ stackApply s fun_name nargs nvars =
then closure info0 body0
else closure info body
where
- info = ClosureInfo (global fun_name) (CIRegs 0 [PtrV]) fun_name (CILayoutUnknown nvars) CIStackFrame mempty
- info0 = ClosureInfo (global fun_name) (CIRegs 0 [PtrV]) fun_name (CILayoutFixed 0 []) CIStackFrame mempty
+ info = ClosureInfo
+ { ciVar = global fun_name
+ , ciRegs = CIRegs 0 [PtrV]
+ , ciName = fun_name
+ , ciLayout = CILayoutUnknown nvars
+ , ciType = CIStackFrame
+ , ciStatic = mempty
+ }
+ info0 = ClosureInfo
+ { ciVar = global fun_name
+ , ciRegs = CIRegs 0 [PtrV]
+ , ciName = fun_name
+ , ciLayout = CILayoutFixed 0 []
+ , ciType = CIStackFrame
+ , ciStatic = mempty
+ }
body0 = (adjSpN' 1 <>) <$> enter s r1
@@ -738,18 +752,18 @@ stackApply s fun_name nargs nvars =
do fun_case <- funCase c
pap_case <- papCase c
return $ mconcat
- [ c |= closureEntry r1
+ [ c |= closureInfo r1
, traceRts s (toJExpr fun_name
+ jString " "
+ (c .^ "n")
+ jString " sp: " + sp
+ jString " a: " + (c .^ "a"))
- , SwitchStat (entryClosureType c)
+ , SwitchStat (infoClosureType c)
[ (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: ") + (entryClosureType c)])
+ ] (appS "throw" [toJExpr ("panic: " <> fun_name <> ", unexpected closure type: ") + (infoClosureType c)])
]
funExact c = popSkip 1 (reverse $ take nvars jsRegsFromR2) <> returnS c
@@ -783,7 +797,7 @@ stackApply s fun_name nargs nvars =
do oversat_case <- oversatCase c ar0 ar
return $ mconcat $
case expr of
- ValExpr (JVar pap) -> [ ar0 |= funArity' c
+ ValExpr (JVar pap) -> [ ar0 |= infoFunArity c
, ar |= mask8 ar0
, ifS (toJExpr nargs .===. ar)
(traceRts s (toJExpr (fun_name <> ": exact")) <> funExact c)
@@ -845,18 +859,18 @@ fastApply s fun_name nargs nvars = if nargs == 0 && nvars == 0
do fun_case_fun <- funCase c farity
fun_case_pap <- funCase c arity
return $ mconcat $
- [ c |= closureEntry r1
+ [ c |= closureInfo r1
, traceRts s (toJExpr (fun_name <> ": sp ") + sp)
- , SwitchStat (entryClosureType c)
+ , SwitchStat (infoClosureType c)
[(toJExpr Fun, traceRts s (toJExpr (fun_name <> ": ")
+ clName c
+ jString " (arity: " + (c .^ "a") + jString ")")
- <> (farity |= funArity' c)
+ <> (farity |= infoFunArity c)
<> 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: ") + entryClosureType c])
+ (appS "throw" [toJExpr (fun_name <> ": unexpected closure type: ") + infoClosureType c])
]
funCase :: JStgExpr -> JStgExpr -> JSM JStgStat
@@ -913,9 +927,9 @@ enter :: StgToJSConfig -> JStgExpr -> JSM JStgStat
enter s ex = jVar \c ->
return $ mconcat $
[ jwhenS (app "typeof" [ex] .!==. jTyObject) returnStack
- , c |= closureEntry ex
+ , c |= closureInfo ex
, jwhenS (c .===. var "h$unbox_e") ((r1 |= closureField1 ex) <> returnStack)
- , SwitchStat (entryClosureType c)
+ , SwitchStat (infoClosureType c)
[ (toJExpr Con, mempty)
, (toJExpr Fun, mempty)
, (toJExpr Pap, returnStack)
@@ -930,7 +944,7 @@ updates s = do
upd_frm_lne <- update_frame_lne
return $ BlockStat [upd_frm, upd_frm_lne]
where
- unbox_closure f1 = Closure { clEntry = var "h$unbox_e"
+ unbox_closure f1 = Closure { clInfo = var "h$unbox_e"
, clField1 = f1
, clField2 = null_
, clMeta = 0
@@ -946,7 +960,14 @@ updates s = do
, postIncrS i
]
update_frame = closure
- (ClosureInfo (global "h$upd_frame") (CIRegs 0 [PtrV]) "h$upd_frame" (CILayoutFixed 1 [PtrV]) CIStackFrame mempty)
+ (ClosureInfo
+ { ciVar = global "h$upd_frame"
+ , ciRegs = CIRegs 0 [PtrV]
+ , ciName = "h$upd_frame"
+ , ciLayout = CILayoutFixed 1 [PtrV]
+ , ciType = CIStackFrame
+ , ciStatic = mempty
+ })
$ jVars \(updatee, waiters, ss, si, sir) ->
do upd_loop <- upd_loop' ss si sir
wake_thread_loop <- loop zero_ (.<. waiters .^ "length")
@@ -967,7 +988,7 @@ updates s = do
<> upd_loop)
, -- overwrite the object
ifS (app "typeof" [r1] .===. jTyObject)
- (mconcat [ traceRts s (jString "$upd_frame: boxed: " + ((closureEntry r1) .^ "n"))
+ (mconcat [ traceRts s (jString "$upd_frame: boxed: " + ((closureInfo r1) .^ "n"))
, copyClosure DontCopyCC updatee r1
])
-- the heap object is represented by another type of value
@@ -984,7 +1005,14 @@ updates s = do
]
update_frame_lne = closure
- (ClosureInfo (global "h$upd_frame_lne") (CIRegs 0 [PtrV]) "h$upd_frame_lne" (CILayoutFixed 1 [PtrV]) CIStackFrame mempty)
+ (ClosureInfo
+ { ciVar = global "h$upd_frame_lne"
+ , ciRegs = CIRegs 0 [PtrV]
+ , ciName = "h$upd_frame_lne"
+ , ciLayout = CILayoutFixed 1 [PtrV]
+ , ciType = CIStackFrame
+ , ciStatic = mempty
+ })
$ jVar \updateePos ->
return $ mconcat $
[ updateePos |= stack .! (sp - 1)
@@ -1028,7 +1056,14 @@ selectors s =
, returnS (sel r)
]
, closure
- (ClosureInfo (global entryName) (CIRegs 0 [PtrV]) ("select " <> name) (CILayoutFixed 1 [PtrV]) CIThunk mempty)
+ (ClosureInfo
+ { ciVar = global entryName
+ , ciRegs = CIRegs 0 [PtrV]
+ , ciName = "select " <> name
+ , ciLayout = CILayoutFixed 1 [PtrV]
+ , ciType = CIThunk
+ , ciStatic = mempty
+ })
(jVar $ \tgt ->
return $ mconcat $
[ tgt |= closureField1 r1
@@ -1040,7 +1075,14 @@ selectors s =
(returnS (app "h$e" [sel tgt]))
])
, closure
- (ClosureInfo (global frameName) (CIRegs 0 [PtrV]) ("select " <> name <> " frame") (CILayoutFixed 0 []) CIStackFrame mempty)
+ (ClosureInfo
+ { ciVar = global frameName
+ , ciRegs = CIRegs 0 [PtrV]
+ , ciName = "select " <> name <> " frame"
+ , ciLayout = CILayoutFixed 0 []
+ , ciType = CIStackFrame
+ , ciStatic = mempty
+ })
$ return $
mconcat [ traceRts s (toJExpr ("selector frame: " <> name))
, postDecrS sp
@@ -1093,7 +1135,14 @@ specPapIdents = listArray (0,numSpecPap) $ map (global . mkFastString . ("h$pap_
pap :: StgToJSConfig
-> Int
-> JSM JStgStat
-pap s r = closure (ClosureInfo funcIdent CIRegsUnknown funcName (CILayoutUnknown (r+2)) CIPap mempty) body
+pap s r = closure (ClosureInfo
+ { ciVar = funcIdent
+ , ciRegs = CIRegsUnknown
+ , ciName = funcName
+ , ciLayout = CILayoutUnknown (r+2)
+ , ciType = CIPap
+ , ciStatic = mempty
+ }) body
where
funcIdent = global funcName
funcName = mkFastString ("h$pap_" ++ show r)
@@ -1102,7 +1151,7 @@ pap s r = closure (ClosureInfo funcIdent CIRegsUnknown funcName (CILayoutUnknown
return $ mconcat $
[ c |= closureField1 r1
, d |= closureField2 r1
- , f |= closureEntry c
+ , f |= closureInfo c
, assertRts s (isFun' f .||. isPap' f) (funcName <> ": expected function or pap")
, profStat s (enterCostCentreFun currentCCS)
, extra |= (funOrPapArity c (Just f) .>>. 8) - toJExpr r
@@ -1122,12 +1171,19 @@ pap s r = closure (ClosureInfo funcIdent CIRegsUnknown funcName (CILayoutUnknown
-- Construct a generic PAP
papGen :: StgToJSConfig -> JSM JStgStat
papGen cfg =
- closure (ClosureInfo funcIdent CIRegsUnknown funcName CILayoutVariable CIPap mempty)
+ closure (ClosureInfo
+ { ciVar = funcIdent
+ , ciRegs = CIRegsUnknown
+ , ciName = funcName
+ , ciLayout = CILayoutVariable
+ , ciType = CIPap
+ , ciStatic = mempty
+ })
(jVars $ \(c, f, d, pr, or, r) ->
return $ mconcat
[ c |= closureField1 r1
, d |= closureField2 r1
- , f |= closureEntry c
+ , f |= closureInfo c
, pr |= funOrPapArity c (Just f) .>>. 8
, or |= papArity r1 .>>. 8
, r |= pr - or
@@ -1174,9 +1230,9 @@ moveRegs2 = jFunction (global "h$moveRegs2") moveSwitch
-- Initalize a variable sized object from an array of values
initClosure :: StgToJSConfig -> JStgExpr -> JStgExpr -> JStgExpr -> JStgExpr
-initClosure cfg entry values ccs = app "h$init_closure"
+initClosure cfg info values ccs = app "h$init_closure"
[ newClosure $ Closure
- { clEntry = entry
+ { clInfo = info
, clField1 = null_
, clField2 = null_
, clMeta = 0
=====================================
compiler/GHC/StgToJS/Arg.hs
=====================================
@@ -69,7 +69,7 @@ of generating a wrapper object with a field for the value's payload, such as:
// a JS object for an Int8
var anInt8 = { d1 = <Int8# payload>
- , f : entry function which would scrutinize the payload
+ , f : info table / entry function which would scrutinize the payload
}
we instead generate:
=====================================
compiler/GHC/StgToJS/Closure.hs
=====================================
@@ -28,7 +28,6 @@ import GHC.Data.FastString
import GHC.StgToJS.Heap
import GHC.StgToJS.Types
import GHC.StgToJS.Utils
-import GHC.StgToJS.Regs (stack,sp)
import GHC.JS.Make
import GHC.JS.JStg.Syntax
@@ -41,18 +40,23 @@ import Data.Array
import Data.Monoid
import qualified Data.Bits as Bits
+-- | Generate statements to set infotable field values for the given ClosureInfo
+--
+-- Depending on debug flag, it generates h$setObjInfo(...) or h$o(...). The
+-- latter form doesn't store the pretty-printed name in the closure to save
+-- space.
closureInfoStat :: Bool -> ClosureInfo -> JStgStat
-closureInfoStat debug (ClosureInfo obj rs name layout ctype srefs)
- = setObjInfoL debug obj rs layout ty name tag srefs
+closureInfoStat debug ci
+ = setObjInfoL debug (ciVar ci) (ciRegs ci) (ciLayout ci) ty (ciName ci) tag (ciStatic ci)
where
- !ty = case ctype of
+ !ty = case ciType ci of
CIThunk -> Thunk
CIFun {} -> Fun
CICon {} -> Con
CIBlackhole -> Blackhole
CIPap -> Pap
CIStackFrame -> StackFrame
- !tag = case ctype of
+ !tag = case ciType ci of
CIThunk -> 0
CIFun arity nregs -> mkArityTag arity nregs
CICon con -> con
@@ -118,29 +122,37 @@ setObjInfo debug obj t name fields a size regs static
-- | Special case of closures that do not need to generate any @fresh@ names
closure :: ClosureInfo -- ^ object being info'd see @ciVar@
- -> (JSM JStgStat) -- ^ rhs
+ -> JSM JStgStat -- ^ rhs
-> JSM JStgStat
-closure ci body = do f <- (jFunction' (ciVar ci) body)
- return $ f `mappend` closureInfoStat False ci
+closure ci body = do
+ f <- jFunction' (ciVar ci) body
+ return $ f `mappend` closureInfoStat False ci
conClosure :: Ident -> FastString -> CILayout -> Int -> JSM JStgStat
conClosure symbol name layout constr = closure ci body
where
- ci = (ClosureInfo symbol (CIRegs 0 [PtrV]) name layout (CICon constr) mempty)
- body = pure . returnS $ stack .! sp
+ ci = ClosureInfo
+ { ciVar = symbol
+ , ciRegs = CIRegs 0 [PtrV]
+ , ciName = name
+ , ciLayout = layout
+ , ciType = CICon constr
+ , ciStatic = mempty
+ }
+ body = pure returnStack
-- | Used to pass arguments to newClosure with some safety
data Closure = Closure
- { clEntry :: JStgExpr
- , clField1 :: JStgExpr
- , clField2 :: JStgExpr
+ { clInfo :: JStgExpr -- ^ InfoTable object
+ , clField1 :: JStgExpr -- ^ Payload field 1
+ , clField2 :: JStgExpr -- ^ Payload field 2
, clMeta :: JStgExpr
, clCC :: Maybe JStgExpr
}
newClosure :: Closure -> JStgExpr
newClosure Closure{..} =
- let xs = [ (closureEntry_ , clEntry)
+ let xs = [ (closureInfo_ , clInfo)
, (closureField1_, clField1)
, (closureField2_, clField2)
, (closureMeta_ , clMeta)
@@ -153,7 +165,7 @@ newClosure Closure{..} =
assignClosure :: JStgExpr -> Closure -> JStgStat
assignClosure t Closure{..} = BlockStat
- [ closureEntry t |= clEntry
+ [ closureInfo t |= clInfo
, closureField1 t |= clField1
, closureField2 t |= clField2
, closureMeta t |= clMeta
@@ -165,7 +177,7 @@ data CopyCC = CopyCC | DontCopyCC
copyClosure :: CopyCC -> JStgExpr -> JStgExpr -> JStgStat
copyClosure copy_cc t s = BlockStat
- [ closureEntry t |= closureEntry s
+ [ closureInfo t |= closureInfo s
, closureField1 t |= closureField1 s
, closureField2 t |= closureField2 s
, closureMeta t |= closureMeta s
@@ -174,8 +186,8 @@ copyClosure copy_cc t s = BlockStat
CopyCC -> closureCC t |= closureCC s
mkClosure :: JStgExpr -> [JStgExpr] -> JStgExpr -> Maybe JStgExpr -> Closure
-mkClosure entry fields meta cc = Closure
- { clEntry = entry
+mkClosure info fields meta cc = Closure
+ { clInfo = info
, clField1 = x1
, clField2 = x2
, clMeta = meta
=====================================
compiler/GHC/StgToJS/CodeGen.hs
=====================================
@@ -276,11 +276,10 @@ genToplevel (StgRec bs) =
genToplevelDecl :: Id -> CgStgRhs -> G JStgStat
genToplevelDecl i rhs = do
- s1 <- resetSlots (genToplevelConEntry i rhs)
- s2 <- resetSlots (genToplevelRhs i rhs)
- return (s1 <> s2)
+ resetSlots (genToplevelConEntry i rhs)
+ resetSlots (genToplevelRhs i rhs)
-genToplevelConEntry :: Id -> CgStgRhs -> G JStgStat
+genToplevelConEntry :: Id -> CgStgRhs -> G ()
genToplevelConEntry i rhs = case rhs of
StgRhsCon _cc con _mu _ts _args _typ
| isDataConWorkId i
@@ -288,24 +287,23 @@ genToplevelConEntry i rhs = case rhs of
StgRhsClosure _ _cc _upd_flag _args _body _typ
| Just dc <- isDataConWorkId_maybe i
-> genSetConInfo i dc (stgRhsLive rhs) -- srt
- _ -> pure mempty
+ _ -> pure ()
-genSetConInfo :: HasDebugCallStack => Id -> DataCon -> LiveVars -> G JStgStat
+genSetConInfo :: HasDebugCallStack => Id -> DataCon -> LiveVars -> G ()
genSetConInfo i d l {- srt -} = do
ei <- identForDataConEntryId i
sr <- genStaticRefs l
- emitClosureInfo $ ClosureInfo ei
- (CIRegs 0 [PtrV])
- (mkFastString $ renderWithContext defaultSDocContext (ppr d))
- (fixedLayout fields)
- (CICon $ dataConTag d)
- sr
- return (mkDataEntry ei)
- where
- -- dataConRepArgTys sometimes returns unboxed tuples. is that a bug?
- fields = concatMap (typeJSRep . unwrapType . scaledThing)
+ let fields = concatMap (typeJSRep . unwrapType . scaledThing)
(dataConRepArgTys d)
- -- concatMap (map slotTyToType . repTypeSlots . repType) (dataConRepArgTys d)
+ emitClosureInfo $ ClosureInfo
+ { ciVar = ei
+ , ciRegs = CIRegs 0 [PtrV]
+ , ciName = mkFastString $ renderWithContext defaultSDocContext (ppr d)
+ , ciLayout = fixedLayout fields
+ , ciType = CICon $ dataConTag d
+ , ciStatic = sr
+ }
+ emitToplevel (mkDataEntry ei)
mkDataEntry :: Ident -> JStgStat
mkDataEntry i = FuncStat i [] returnStack
@@ -351,12 +349,14 @@ genToplevelRhs i rhs = case rhs of
if et == CIThunk
then enterCostCentreThunk
else enterCostCentreFun cc
- emitClosureInfo (ClosureInfo eid
- regs
- idt
- (fixedLayout $ map (unaryTypeJSRep . idType) lids)
- et
- sr)
+ emitClosureInfo $ ClosureInfo
+ { ciVar = eid
+ , ciRegs = regs
+ , ciName = idt
+ , ciLayout = fixedLayout $ map (unaryTypeJSRep . idType) lids
+ , ciType = et
+ , ciStatic = sr
+ }
ccId <- costCentreStackLbl cc
emitStatic idt static ccId
return $ (FuncStat eid [] (ll <> upd <> setcc <> body))
=====================================
compiler/GHC/StgToJS/Expr.hs
=====================================
@@ -243,14 +243,14 @@ genEntryLne ctx i rhs@(StgRhsClosure _ext _cc update args body typ) =
ei@(identFS -> eii) <- identForEntryId i
sr <- genStaticRefsRhs rhs
let f = (blk_hl <> locals <> body)
- emitClosureInfo $
- ClosureInfo ei
- (CIRegs 0 $ concatMap idJSRep args)
- (eii <> ", " <> mkFastString (renderWithContext defaultSDocContext (ppr i)))
- (fixedLayout . reverse $
- map (stackSlotType . fst) (ctxLneFrameVars ctx))
- CIStackFrame
- sr
+ emitClosureInfo $ ClosureInfo
+ { ciVar = ei
+ , ciRegs = CIRegs 0 $ concatMap idJSRep args
+ , ciName = eii <> ", " <> mkFastString (renderWithContext defaultSDocContext (ppr i))
+ , ciLayout = fixedLayout . reverse $ map (stackSlotType . fst) (ctxLneFrameVars ctx)
+ , ciType = CIStackFrame
+ , ciStatic = sr
+ }
emitToplevel (FuncStat ei [] f)
genEntryLne ctx i (StgRhsCon cc con _mu _ticks args _typ) = resetSlots $ do
let payloadSize = ctxLneFrameSize ctx
@@ -265,28 +265,30 @@ genEntryLne ctx i (StgRhsCon cc con _mu _ticks args _typ) = resetSlots $ do
-- | Generate the entry function for a local closure
genEntry :: HasDebugCallStack => ExprCtx -> Id -> CgStgRhs -> G ()
genEntry _ _i StgRhsCon {} = return ()
-genEntry ctx i rhs@(StgRhsClosure _ext cc {-_bi live-} upd_flag args body typ) = resetSlots $ do
- let live = stgLneLiveExpr rhs -- error "fixme" -- probably find live vars in body
+genEntry ctx i rhs@(StgRhsClosure _ext cc upd_flag args body typ) = resetSlots $ do
+ let live = stgLneLiveExpr rhs
ll <- loadLiveFun live
llv <- verifyRuntimeReps live
upd <- genUpdFrame upd_flag i
+ let entryCtx = ctxSetTarget [] (ctxClearLneFrame ctx)
body <- genBody entryCtx R2 args body typ
- ei@(identFS -> eii) <- identForEntryId i
et <- genEntryType args
setcc <- ifProfiling $
if et == CIThunk
then enterCostCentreThunk
else enterCostCentreFun cc
sr <- genStaticRefsRhs rhs
- emitClosureInfo $ ClosureInfo ei
- (CIRegs 0 $ PtrV : concatMap idJSRep args)
- (eii <> ", " <> mkFastString (renderWithContext defaultSDocContext (ppr i)))
- (fixedLayout $ map (unaryTypeJSRep . idType) live)
- et
- sr
+
+ ei <- identForEntryId i
+ emitClosureInfo $ ClosureInfo
+ { ciVar = ei
+ , ciRegs = CIRegs 0 $ PtrV : concatMap idJSRep args
+ , ciName = identFS ei <> ", " <> mkFastString (renderWithContext defaultSDocContext (ppr i))
+ , ciLayout = fixedLayout $ map (unaryTypeJSRep . idType) live
+ , ciType = et
+ , ciStatic = sr
+ }
emitToplevel (FuncStat ei [] (mconcat [ll, llv, upd, setcc, body]))
- where
- entryCtx = ctxSetTarget [] (ctxClearLneFrame ctx)
-- | Generate the entry function types for identifiers. Note that this only
-- returns either 'CIThunk' or 'CIFun'.
@@ -456,9 +458,9 @@ genUpdFrame u i
--
bhSingleEntry :: StgToJSConfig -> JStgStat
bhSingleEntry _settings = mconcat
- [ r1 .^ closureEntry_ |= var "h$blackholeTrap"
- , r1 .^ closureField1_ |= undefined_
- , r1 .^ closureField2_ |= undefined_
+ [ closureInfo r1 |= var "h$blackholeTrap"
+ , closureField1 r1 |= undefined_
+ , closureField2 r1 |= undefined_
]
genStaticRefsRhs :: CgStgRhs -> G CIStatic
@@ -646,15 +648,16 @@ genRet ctx e at as l = freshIdent >>= f
fun' <- fun free
sr <- genStaticRefs l -- srt
prof <- profiling
- emitClosureInfo $
- ClosureInfo r
- (CIRegs 0 altRegs)
- ri
- (fixedLayout . reverse $
+ emitClosureInfo $ ClosureInfo
+ { ciVar = r
+ , ciRegs = CIRegs 0 altRegs
+ , ciName = ri
+ , ciLayout = fixedLayout . reverse $
map (stackSlotType . fst3) free
- ++ if prof then [ObjV] else map stackSlotType lneVars)
- CIStackFrame
- sr
+ ++ if prof then [ObjV] else map stackSlotType lneVars
+ , ciType = CIStackFrame
+ , ciStatic = sr
+ }
emitToplevel $ FuncStat r [] fun'
return (pushLne <> saveCCS <> pushRet)
fst3 ~(x,_,_) = x
@@ -1012,7 +1015,7 @@ allocDynAll haveDecl middle cls = do
ccs <- maybeToList <$> costCentreStackLbl cc
pure $ mconcat
[ decl_maybe i $ if csInlineAlloc settings
- then ValExpr (jhFromList $ [ (closureEntry_ , f)
+ then ValExpr (jhFromList $ [ (closureInfo_ , f)
, (closureField1_, null_)
, (closureField2_, null_)
, (closureMeta_ , zero_)
@@ -1023,34 +1026,25 @@ allocDynAll haveDecl middle cls = do
fillObjs :: [JStgStat]
fillObjs = map fillObj cls
- fillObj (i,_,es,_)
- | csInlineAlloc settings || length es > 24 =
- case es of
- [] -> mempty
- [ex] -> toJExpr i .^ closureField1_ |= toJExpr ex
- [e1,e2] -> mconcat
- [ toJExpr i .^ closureField1_ |= toJExpr e1
- , toJExpr i .^ closureField2_ |= toJExpr e2
- ]
- (ex:es) -> mconcat
- [ toJExpr i .^ closureField1_ |= toJExpr ex
- , toJExpr i .^ closureField2_ |= toJExpr (jhFromList (zip (map dataFieldName [1..]) es))
- ]
- | otherwise = case es of
- [] -> mempty
- [ex] -> toJExpr i .^ closureField1_ |= ex
- [e1,e2] -> mconcat
- [ toJExpr i .^ closureField1_ |= e1
- , toJExpr i .^ closureField2_ |= e2
- ]
- (ex:es) -> mconcat
- [ toJExpr i .^ closureField1_ |= ex
- , toJExpr i .^ closureField2_ |= fillFun es
- ]
-
- fillFun :: [JStgExpr] -> JStgExpr
- fillFun [] = null_
- fillFun es = ApplExpr (allocData (length es)) es
+ fillObj (ident,_,es,_) =
+ let i = toJExpr ident
+ in case es of
+ [] -> mempty
+ [ex] -> closureField1 i |= ex
+ [e1,e2] -> mconcat
+ [ closureField1 i |= e1
+ , closureField2 i |= e2
+ ]
+ (ex:es)
+ | csInlineAlloc settings || length es > 24
+ -> mconcat [ closureField1 i |= ex
+ , closureField2 i |= ValExpr (jhFromList (zip (map dataFieldName [1..]) es))
+ ]
+
+ | otherwise
+ -> mconcat [ closureField1 i |= ex
+ , closureField2 i |= ApplExpr (allocData (length es)) es
+ ]
checkObjs :: [JStgStat]
checkObjs | csAssertRts settings =
=====================================
compiler/GHC/StgToJS/Heap.hs
=====================================
@@ -3,7 +3,8 @@
module GHC.StgToJS.Heap
( closureType
- , entryClosureType
+ , infoClosureType
+ , infoFunArity
, isObject
, isThunk
, isThunk'
@@ -16,17 +17,16 @@ module GHC.StgToJS.Heap
, isCon'
, conTag
, conTag'
- , closureEntry
+ , closureInfo
, closureMeta
, closureField1
, closureField2
, closureCC
, funArity
- , funArity'
, papArity
, funOrPapArity
-- * Field names
- , closureEntry_
+ , closureInfo_
, closureMeta_
, closureCC_
, closureField1_
@@ -43,38 +43,51 @@ import GHC.JS.Make
import GHC.StgToJS.Types
import GHC.Data.FastString
-closureEntry_ :: FastString
-closureEntry_ = "f"
+-- | Closure infotable field name
+closureInfo_ :: FastString
+closureInfo_ = "f"
+-- | Closure first payload field name
closureField1_ :: FastString
closureField1_ = "d1"
+-- | Closure second payload field name
closureField2_ :: FastString
closureField2_ = "d2"
+-- | Closure meta field name
closureMeta_ :: FastString
closureMeta_ = "m"
+-- | Closure cost-center field name
closureCC_ :: FastString
closureCC_ = "cc"
-entryClosureType_ :: FastString
-entryClosureType_ = "t"
+-- | Infotable type field name
+infoClosureType_ :: FastString
+infoClosureType_ = "t"
-entryConTag_ :: FastString
-entryConTag_ = "a"
+-- | Infotable tag field name
+infoConTag_ :: FastString
+infoConTag_ = "a"
-entryFunArity_ :: FastString
-entryFunArity_ = "a"
+-- | Infotable arity field name
+infoFunArity_ :: FastString
+infoFunArity_ = "a"
jTyObject :: JStgExpr
jTyObject = jString "object"
-closureType :: JStgExpr -> JStgExpr
-closureType = entryClosureType . closureEntry
+-- | Closure type from infotable
+infoClosureType :: JStgExpr -> JStgExpr
+infoClosureType f = f .^ infoClosureType_
+
+-- | Function arity from infotable
+infoFunArity :: JStgExpr -> JStgExpr
+infoFunArity f = f .^ infoFunArity_
-entryClosureType :: JStgExpr -> JStgExpr
-entryClosureType f = f .^ entryClosureType_
+closureType :: JStgExpr -> JStgExpr
+closureType = infoClosureType . closureInfo
isObject :: JStgExpr -> JStgExpr
isObject c = typeof c .===. String "object"
@@ -83,7 +96,7 @@ isThunk :: JStgExpr -> JStgExpr
isThunk c = closureType c .===. toJExpr Thunk
isThunk' :: JStgExpr -> JStgExpr
-isThunk' f = entryClosureType f .===. toJExpr Thunk
+isThunk' f = infoClosureType f .===. toJExpr Thunk
isBlackhole :: JStgExpr -> JStgExpr
isBlackhole c = closureType c .===. toJExpr Blackhole
@@ -92,29 +105,29 @@ isFun :: JStgExpr -> JStgExpr
isFun c = closureType c .===. toJExpr Fun
isFun' :: JStgExpr -> JStgExpr
-isFun' f = entryClosureType f .===. toJExpr Fun
+isFun' f = infoClosureType f .===. toJExpr Fun
isPap :: JStgExpr -> JStgExpr
isPap c = closureType c .===. toJExpr Pap
isPap' :: JStgExpr -> JStgExpr
-isPap' f = entryClosureType f .===. toJExpr Pap
+isPap' f = infoClosureType f .===. toJExpr Pap
isCon :: JStgExpr -> JStgExpr
isCon c = closureType c .===. toJExpr Con
isCon' :: JStgExpr -> JStgExpr
-isCon' f = entryClosureType f .===. toJExpr Con
+isCon' f = infoClosureType f .===. toJExpr Con
conTag :: JStgExpr -> JStgExpr
-conTag = conTag' . closureEntry
+conTag = conTag' . closureInfo
conTag' :: JStgExpr -> JStgExpr
-conTag' f = f .^ entryConTag_
+conTag' f = f .^ infoConTag_
--- | Get closure entry function
-closureEntry :: JStgExpr -> JStgExpr
-closureEntry p = p .^ closureEntry_
+-- | Get closure infotable
+closureInfo :: JStgExpr -> JStgExpr
+closureInfo p = p .^ closureInfo_
-- | Get closure metadata
closureMeta :: JStgExpr -> JStgExpr
@@ -132,13 +145,9 @@ closureField1 p = p .^ closureField1_
closureField2 :: JStgExpr -> JStgExpr
closureField2 p = p .^ closureField2_
--- number of arguments (arity & 0xff = arguments, arity >> 8 = number of registers)
+-- | Number of arguments (arity & 0xff = arguments, arity >> 8 = number of registers)
funArity :: JStgExpr -> JStgExpr
-funArity = funArity' . closureEntry
-
--- function arity with raw reference to the entry
-funArity' :: JStgExpr -> JStgExpr
-funArity' f = f .^ entryFunArity_
+funArity = infoFunArity . closureInfo
-- arity of a partial application
papArity :: JStgExpr -> JStgExpr
@@ -146,10 +155,10 @@ papArity cp = closureField1 (closureField2 cp)
funOrPapArity
:: JStgExpr -- ^ heap object
- -> Maybe JStgExpr -- ^ reference to entry, if you have one already (saves a c.f lookup twice)
+ -> Maybe JStgExpr -- ^ reference to infotable, if you have one already (saves a c.f lookup twice)
-> JStgExpr -- ^ arity tag (tag >> 8 = registers, tag & 0xff = arguments)
funOrPapArity c = \case
Nothing -> ((IfExpr (toJExpr (isFun c))) (toJExpr (funArity c)))
(toJExpr (papArity c))
- Just f -> ((IfExpr (toJExpr (isFun' f))) (toJExpr (funArity' f)))
+ Just f -> ((IfExpr (toJExpr (isFun' f))) (toJExpr (infoFunArity f)))
(toJExpr (papArity c))
=====================================
compiler/GHC/StgToJS/Rts/Rts.hs
=====================================
@@ -449,13 +449,13 @@ rts_gen s = do
, r4 |= d4
, returnS (app "h$ap_3_3_fast" [])
])
- , closure (ClosureInfo (TxtI "h$upd_thunk_e") (CIRegs 0 [PtrV]) "updatable thunk" (CILayoutFixed 1 [PtrV]) CIThunk mempty)
+ , closure (ClosureInfo (global "h$upd_thunk_e") (CIRegs 0 [PtrV]) "updatable thunk" (CILayoutFixed 1 [PtrV]) CIThunk mempty)
(jVar $ \t -> return $
mconcat [t |= closureField1 r1
, adjSp' 2
, stack .! (sp - 1) |= r1
, stack .! sp |= var "h$upd_frame"
- , closureEntry r1 |= var "h$blackhole"
+ , closureInfo r1 |= var "h$blackhole"
, closureField1 r1 |= var "h$currentThread"
, closureField2 r1 |= null_
, r1 |= t
@@ -470,7 +470,7 @@ rts_gen s = do
, stack .! (sp - 2) |= r1
, stack .! (sp - 1) |= var "h$upd_frame"
, stack .! sp |= var "h$select1_ret"
- , closureEntry r1 |= var "h$blackhole"
+ , closureInfo r1 |= var "h$blackhole"
, closureField1 r1 |= var "h$currentThread"
, closureField2 r1 |= null_
, r1 |= t
@@ -490,7 +490,7 @@ rts_gen s = do
, stack .! (sp - 2) |= r1
, stack .! (sp - 1) |= var "h$upd_frame"
, stack .! sp |= var "h$select2_ret"
- , closureEntry r1 |= var "h$blackhole"
+ , closureInfo r1 |= var "h$blackhole"
, closureField1 r1 |= var "h$currentThread"
, closureField2 r1 |= null_
, r1 |= t
=====================================
compiler/GHC/StgToJS/Stack.hs
=====================================
@@ -347,7 +347,7 @@ popN n = addUnknownSlots n >> adjSpN n
bhStats :: StgToJSConfig -> Bool -> JStgStat
bhStats s pushUpd = mconcat
[ if pushUpd then push' s [r1, var "h$upd_frame"] else mempty
- , toJExpr R1 .^ closureEntry_ |= var "h$blackhole"
+ , toJExpr R1 .^ closureInfo_ |= var "h$blackhole"
, toJExpr R1 .^ closureField1_ |= var "h$currentThread"
, toJExpr R1 .^ closureField2_ |= null_ -- will be filled with waiters array
]
=====================================
compiler/GHC/StgToJS/Types.hs
=====================================
@@ -98,9 +98,9 @@ data StgToJSConfig = StgToJSConfig
, csLinkerConfig :: !LinkerConfig -- ^ Emscripten linker
}
--- | Information relevenat to code generation for closures.
+-- | Closure info table
data ClosureInfo = ClosureInfo
- { ciVar :: Ident -- ^ object being infod
+ { ciVar :: Ident -- ^ entry code identifier: infotable fields are stored as properties of this function
, ciRegs :: CIRegs -- ^ size of the payload (in number of JS values)
, ciName :: FastString -- ^ friendly name for printing
, ciLayout :: CILayout -- ^ heap/stack layout of the object
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ca13075c0c23195450dfedb8c4e6a4778bb7b0bb
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ca13075c0c23195450dfedb8c4e6a4778bb7b0bb
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/20240501/9deff229/attachment-0001.html>
More information about the ghc-commits
mailing list