[Git][ghc/ghc][wip/js-staging] 4 commits: Remove orphan instance for StaticArg
Sylvain Henry (@hsyl20)
gitlab at gitlab.haskell.org
Mon Aug 15 20:39:02 UTC 2022
Sylvain Henry pushed to branch wip/js-staging at Glasgow Haskell Compiler / GHC
Commits:
5ee51a84 by Sylvain Henry at 2022-08-15T22:26:52+02:00
Remove orphan instance for StaticArg
- - - - -
7280af8a by Sylvain Henry at 2022-08-15T22:26:52+02:00
Minor doc/cleanup
- - - - -
09b6fc33 by Sylvain Henry at 2022-08-15T22:26:52+02:00
Remove redundant jsIdIdent' function
- - - - -
9716e7f2 by Sylvain Henry at 2022-08-15T22:26:52+02:00
Split StgToJS.Monad into StgToJS.{Monad,Ids,Stack}
- - - - -
15 changed files:
- compiler/GHC/StgToJS/Apply.hs
- compiler/GHC/StgToJS/Arg.hs
- compiler/GHC/StgToJS/CodeGen.hs
- compiler/GHC/StgToJS/DataCon.hs
- compiler/GHC/StgToJS/Deps.hs
- compiler/GHC/StgToJS/Expr.hs
- compiler/GHC/StgToJS/FFI.hs
- + compiler/GHC/StgToJS/Ids.hs
- compiler/GHC/StgToJS/Linker/Compactor.hs
- compiler/GHC/StgToJS/Literal.hs
- compiler/GHC/StgToJS/Monad.hs
- compiler/GHC/StgToJS/Rts/Rts.hs
- + compiler/GHC/StgToJS/Stack.hs
- compiler/GHC/StgToJS/StaticPtr.hs
- compiler/ghc.cabal.in
Changes:
=====================================
compiler/GHC/StgToJS/Apply.hs
=====================================
@@ -43,6 +43,8 @@ import GHC.StgToJS.Regs
import GHC.StgToJS.CoreUtils
import GHC.StgToJS.Utils
import GHC.StgToJS.Rts.Types
+import GHC.StgToJS.Stack
+import GHC.StgToJS.Ids
import GHC.Types.Literal
import GHC.Types.Id
@@ -107,7 +109,7 @@ genApp ctx i args
-- -- , Just (Lit (MachStr bs)) <- expandUnfolding_maybe (idUnfolding v)
-- -- , Just t <- decodeModifiedUTF8 bs -- unpackFS fs -- Just t <- decodeModifiedUTF8 bs
-- , matchVarName "ghcjs-prim" "GHCJS.Prim" "unsafeUnpackJSStringUtf8##" i =
--- (,ExprInline Nothing) . (|=) top . app "h$decodeUtf8z" <$> genIds v
+-- (,ExprInline Nothing) . (|=) top . app "h$decodeUtf8z" <$> varsForId v
-- Case: unpackCStringAppend# "some string"# str
--
@@ -131,7 +133,7 @@ genApp ctx i args
| Just n <- ctxLneBindingStackSize ctx i
= do
as' <- concatMapM genArg args
- ei <- jsEntryId i
+ ei <- varForEntryId i
let ra = mconcat . reverse $
zipWith (\r a -> toJExpr r |= a) [R1 ..] as'
p <- pushLneFrame n ctx
@@ -171,7 +173,7 @@ genApp ctx i args
, ctxIsEvaluated ctx i
= do
let c = head (concatMap typex_expr $ ctxTarget ctx)
- is <- genIds i
+ is <- varsForId i
case is of
[i'] ->
return ( c |= if_ (isObject i') (closureField1 i') i'
@@ -220,7 +222,7 @@ genApp ctx i args
, idFunRepArity i == 0
, not (might_be_a_function (idType i))
= do
- enter_id <- genArg (StgVarArg i) >>=
+ enter_id <- genIdArg i >>=
\case
[x] -> return x
xs -> pprPanic "genApp: unexpected multi-var argument"
@@ -237,7 +239,7 @@ genApp ctx i args
, isStrictId i
= do
as' <- concatMapM genArg args
- is <- assignAll jsRegsFromR1 <$> genIds i
+ is <- assignAll jsRegsFromR1 <$> varsForId i
jmp <- jumpToII i as' is
return (jmp, ExprCont)
@@ -252,7 +254,7 @@ genApp ctx i args
let (reg,over) = splitAt (idFunRepArity i) args
reg' <- concatMapM genArg reg
pc <- pushCont over
- is <- assignAll jsRegsFromR1 <$> genIds i
+ is <- assignAll jsRegsFromR1 <$> varsForId i
jmp <- jumpToII i reg' is
return (pc <> jmp, ExprCont)
@@ -262,7 +264,7 @@ genApp ctx i args
-- - otherwise use generic apply function h$ap_gen_fast
| otherwise
= do
- is <- assignAll jsRegsFromR1 <$> genIds i
+ is <- assignAll jsRegsFromR1 <$> varsForId i
jmp <- jumpToFast args is
return (jmp, ExprCont)
@@ -271,14 +273,14 @@ genApp ctx i args
jumpToII :: Id -> [JExpr] -> JStat -> G JStat
jumpToII i args afterLoad
| isLocalId i = do
- ii <- jsId i
+ ii <- varForId i
return $ mconcat
[ ra
, afterLoad
, returnS (closureEntry ii)
]
| otherwise = do
- ei <- jsEntryId i
+ ei <- varForEntryId i
return $ mconcat
[ ra
, afterLoad
@@ -1048,7 +1050,7 @@ initClosure cfg entry values ccs =
-- | Return an expression for every field of the given Id
getIdFields :: Id -> G [TypedExpr]
-getIdFields i = assocIdExprs i <$> genIds i
+getIdFields i = assocIdExprs i <$> varsForId i
-- | Store fields of Id into the given target expressions
storeIdFields :: Id -> [TypedExpr] -> G JStat
=====================================
compiler/GHC/StgToJS/Arg.hs
=====================================
@@ -1,15 +1,16 @@
{-# LANGUAGE LambdaCase #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-} -- For ToJExpr StaticArg, see FIXME
+-- | Code generation of application arguments
module GHC.StgToJS.Arg
( genArg
- , genStaticArg
, genIdArg
, genIdArgI
, genIdStackArgI
, allocConStatic
, allocUnboxedConStatic
, allocateStaticList
+ , jsStaticArg
+ , jsStaticArgs
)
where
@@ -24,6 +25,7 @@ import GHC.StgToJS.Monad
import GHC.StgToJS.Literal
import GHC.StgToJS.CoreUtils
import GHC.StgToJS.Profiling
+import GHC.StgToJS.Ids
import GHC.Builtin.Types
import GHC.Stg.Syntax
@@ -110,39 +112,40 @@ genStaticArg a = case a of
| i == falseDataConId =
return [StaticLitArg (BoolLit False)]
| isMultiVar r =
- map (\(TxtI t) -> StaticObjArg t) <$> mapM (jsIdIN i) [1..varSize r] -- this seems wrong, not an obj?
- | otherwise = (\(TxtI it) -> [StaticObjArg it]) <$> jsIdI i
+ map (\(TxtI t) -> StaticObjArg t) <$> mapM (identForIdN i) [1..varSize r] -- this seems wrong, not an obj?
+ | otherwise = (\(TxtI it) -> [StaticObjArg it]) <$> identForId i
unfloated :: CgStgExpr -> G [StaticArg]
unfloated (StgLit l) = map StaticLitArg <$> genStaticLit l
unfloated (StgConApp dc _n args _)
| isBoolDataCon dc || isUnboxableCon dc =
(:[]) . allocUnboxedConStatic dc . concat <$> mapM genStaticArg args -- fixme what is allocunboxedcon?
- | null args = (\(TxtI t) -> [StaticObjArg t]) <$> jsIdI (dataConWorkId dc)
+ | null args = (\(TxtI t) -> [StaticObjArg t]) <$> identForId (dataConWorkId dc)
| otherwise = do
as <- concat <$> mapM genStaticArg args
- (TxtI e) <- enterDataConI dc
+ (TxtI e) <- identForDataConWorker dc
return [StaticConArg e as]
unfloated x = pprPanic "genArg: unexpected unfloated expression" (pprStgExpr panicStgPprOpts x)
+-- | Generate JS code for an StgArg
genArg :: HasDebugCallStack => StgArg -> G [JExpr]
genArg a = case a of
StgLitArg l -> genLit l
StgVarArg i -> do
unFloat <- State.gets gsUnfloated
case lookupUFM unFloat i of
- Nothing -> reg
Just expr -> unfloated expr
+ Nothing
+ | isVoid r -> return []
+ | i == trueDataConId -> return [true_]
+ | i == falseDataConId -> return [false_]
+ | isMultiVar r -> mapM (varForIdN i) [1..varSize r]
+ | otherwise -> (:[]) <$> varForId i
+
where
-- if our argument is a joinid, it can be an unboxed tuple
r :: HasDebugCallStack => VarType
r = uTypeVt . stgArgType $ a
- reg
- | isVoid r = return []
- | i == trueDataConId = return [true_]
- | i == falseDataConId = return [false_]
- | isMultiVar r = mapM (jsIdN i) [1..varSize r]
- | otherwise = (:[]) <$> jsId i
unfloated :: HasDebugCallStack => CgStgExpr -> G [JExpr]
unfloated = \case
@@ -150,10 +153,10 @@ genArg a = case a of
StgConApp dc _n args _
| isBoolDataCon dc || isUnboxableCon dc
-> (:[]) . allocUnboxedCon dc . concat <$> mapM genArg args
- | null args -> (:[]) <$> jsId (dataConWorkId dc)
+ | null args -> (:[]) <$> varForId (dataConWorkId dc)
| otherwise -> do
as <- concat <$> mapM genArg args
- e <- enterDataCon dc
+ e <- varForDataConWorker dc
inl_alloc <- csInlineAlloc <$> getSettings
return [allocDynamicE inl_alloc e as Nothing] -- FIXME: ccs
x -> pprPanic "genArg: unexpected unfloated expression" (pprStgExpr panicStgPprOpts x)
@@ -164,8 +167,8 @@ genIdArg i = genArg (StgVarArg i)
genIdArgI :: HasDebugCallStack => Id -> G [Ident]
genIdArgI i
| isVoid r = return []
- | isMultiVar r = mapM (jsIdIN i) [1..varSize r]
- | otherwise = (:[]) <$> jsIdI i
+ | isMultiVar r = mapM (identForIdN i) [1..varSize r]
+ | otherwise = (:[]) <$> identForId i
where
r = uTypeVt . idType $ i
@@ -192,7 +195,7 @@ allocConStatic (TxtI to) cc con args = do
| isBoolDataCon con && dataConTag con == 2 =
emitStatic to (StaticUnboxed $ StaticUnboxedBool True) cc'
| otherwise = do
- (TxtI e) <- enterDataConI con
+ (TxtI e) <- identForDataConWorker con
emitStatic to (StaticData e []) cc'
allocConStatic' cc' [x]
| isUnboxableCon con =
@@ -211,7 +214,7 @@ allocConStatic (TxtI to) cc con args = do
(a0:a1:_) -> flip (emitStatic to) cc' =<< allocateStaticList [a0] a1
_ -> panic "allocConStatic: invalid args for consDataCon"
else do
- (TxtI e) <- enterDataConI con
+ (TxtI e) <- identForDataConWorker con
emitStatic to (StaticData e xs) cc'
allocUnboxedConStatic :: DataCon -> [StaticArg] -> StaticArg
@@ -249,16 +252,16 @@ allocateStaticList xs a@(StgVarArg i)
pprPanic "allocateStaticList: invalid argument (tail)" (ppr (xs, r))
allocateStaticList _ _ = panic "allocateStaticList: unexpected literal in list"
--- FIXME: Jeff (2022,03): Fix this orphan instance. It is consumed by
--- Linker.Linker but requires allocDynamicE, hence its presence in this file. If
--- we put it in StgToJS.Types (where StaticArg is defined) then we'll end up in
--- an obvious module cycle. We could put it in DataCon but then we lose cohesion
--- in that module (i.e., why should the DataCon module be exporting this
--- instance?). It seems to be that this module should be the one that defines
--- StaticArg, but I leave that for a refactor later.
-instance ToJExpr StaticArg where
- toJExpr (StaticLitArg l) = toJExpr l
- toJExpr (StaticObjArg t) = ValExpr (JVar (TxtI t))
- toJExpr (StaticConArg c args) =
+-- | Generate JS code corresponding to a static arg
+jsStaticArg :: StaticArg -> JExpr
+jsStaticArg = \case
+ StaticLitArg l -> toJExpr l
+ StaticObjArg t -> ValExpr (JVar (TxtI t))
+ StaticConArg c args ->
-- FIXME: cost-centre stack
- allocDynamicE False (ValExpr . JVar . TxtI $ c) (map toJExpr args) Nothing
+ allocDynamicE False (ValExpr . JVar . TxtI $ c) (map jsStaticArg args) Nothing
+
+-- | Generate JS code corresponding to a list of static args
+jsStaticArgs :: [StaticArg] -> JExpr
+jsStaticArgs = ValExpr . JList . map jsStaticArg
+
=====================================
compiler/GHC/StgToJS/CodeGen.hs
=====================================
@@ -30,6 +30,8 @@ import GHC.StgToJS.Profiling
import GHC.StgToJS.Regs
import GHC.StgToJS.StaticPtr
import GHC.StgToJS.UnitUtils
+import GHC.StgToJS.Stack
+import GHC.StgToJS.Ids
import GHC.Stg.Syntax
import GHC.Core.DataCon
@@ -86,7 +88,7 @@ stgToJS logger config stg_binds0 this_mod spt_entries foreign_stubs cccs output_
-- (exported symbol names, javascript statements) for each linkable unit
p <- forM lus \u -> do
- ts <- mapM (fmap (\(TxtI i) -> i) . jsIdI) (luIdExports u)
+ ts <- mapM (fmap (\(TxtI i) -> i) . identForId) (luIdExports u)
return (ts ++ luOtherExports u, luStat u)
deps <- genDependencyData this_mod lus
@@ -191,7 +193,7 @@ genUnits m ss spt_entries foreign_stubs
-> Int
-> G (Object.SymbolTable, Maybe LinkableUnit)
generateBlock st (StgTopStringLit bnd str) n = do
- bids <- genIdsI bnd
+ bids <- identsForId bnd
case bids of
[(TxtI b1t),(TxtI b2t)] -> do
-- [e1,e2] <- genLit (MachStr str)
@@ -242,7 +244,7 @@ serializeLinkableUnit _m st i ci si stat rawStat fe fi = do
!(!st', !o) <- lift $ Object.serializeStat st ci si stat rawStat fe fi
return (st', i', o) -- deepseq results?
where
- idStr i = itxt <$> jsIdI i
+ idStr i = itxt <$> identForId i
-- | variable prefix for the nth block in module
modulePrefix :: Module -> Int -> FastString
@@ -274,7 +276,7 @@ genToplevelConEntry i rhs = case rhs of
genSetConInfo :: HasDebugCallStack => Id -> DataCon -> LiveVars -> G JStat
genSetConInfo i d l {- srt -} = do
- ei@(TxtI eii) <- jsDcEntryIdI i
+ ei@(TxtI eii) <- identForDataConEntryId i
sr <- genStaticRefs l
emitClosureInfo $ ClosureInfo eii
(CIRegs 0 [PtrV])
@@ -296,12 +298,19 @@ genToplevelRhs :: Id -> CgStgRhs -> G JStat
-- general cases:
genToplevelRhs i rhs = case rhs of
StgRhsCon cc con _mu _tys args -> do
- ii <- jsIdI i
+ ii <- identForId i
allocConStatic ii cc con args
return mempty
StgRhsClosure _ext cc _upd_flag {- srt -} args body -> do
- eid@(TxtI eidt) <- jsEnIdI i
- (TxtI idt) <- jsIdI i
+ {-
+ algorithm:
+ - collect all Id refs that are in the global id cache
+ - count usage in body for each ref
+ - order by increasing use
+ - prepend loading lives var to body: body can stay the same
+ -}
+ eid@(TxtI eidt) <- identForEntryId i
+ (TxtI idt) <- identForId i
body <- genBody (initExprCtx i) i R2 args body
(lidents, lids) <- unzip <$> liftToGlobal (jsSaturate (Just "ghcjs_tmp_sat_") body)
let lidents' = map (\(TxtI t) -> t) lidents
=====================================
compiler/GHC/StgToJS/DataCon.hs
=====================================
@@ -22,6 +22,7 @@ import GHC.StgToJS.Monad
import GHC.StgToJS.CoreUtils
import GHC.StgToJS.Profiling
import GHC.StgToJS.Utils
+import GHC.StgToJS.Ids
import GHC.Core.DataCon
@@ -53,10 +54,10 @@ allocCon to con cc xs
| isBoolDataCon con || isUnboxableCon con =
return (toJExpr to |= allocUnboxedCon con xs)
{- | null xs = do
- i <- jsId (dataConWorkId con)
+ i <- varForId (dataConWorkId con)
return (assignj to i) -}
| otherwise = do
- e <- enterDataCon con
+ e <- varForDataConWorker con
cs <- getSettings
prof <- profiling
ccsJ <- if prof then ccsVarJ cc else return Nothing
=====================================
compiler/GHC/StgToJS/Deps.hs
=====================================
@@ -9,7 +9,7 @@ import GHC.Prelude
import GHC.StgToJS.Object as Object
import GHC.StgToJS.Types
-import GHC.StgToJS.Monad
+import GHC.StgToJS.Ids
import GHC.JS.Syntax
@@ -124,7 +124,7 @@ genDependencyData mod units = do
let k = getKey . getUnique $ i
addEntry :: StateT DependencyDataCache G Object.ExportedFun
addEntry = do
- (TxtI idTxt) <- lift (jsIdI i)
+ (TxtI idTxt) <- lift (identForId i)
lookupExternalFun (Just k) (OtherSymb m idTxt)
in if m == mod
then pprPanic "local id not found" (ppr m)
@@ -144,7 +144,7 @@ genDependencyData mod units = do
lookupExportedId :: Id -> StateT DependencyDataCache G Object.ExportedFun
lookupExportedId i = do
- (TxtI idTxt) <- lift (jsIdI i)
+ (TxtI idTxt) <- lift (identForId i)
lookupExternalFun (Just . getKey . getUnique $ i) (OtherSymb mod idTxt)
lookupExportedOther :: FastString -> StateT DependencyDataCache G Object.ExportedFun
=====================================
compiler/GHC/StgToJS/Expr.hs
=====================================
@@ -33,6 +33,8 @@ import GHC.StgToJS.Regs
import GHC.StgToJS.StgUtils
import GHC.StgToJS.CoreUtils
import GHC.StgToJS.Utils
+import GHC.StgToJS.Stack
+import GHC.StgToJS.Ids
import GHC.Types.Basic
import GHC.Types.CostCentre
@@ -143,16 +145,16 @@ genBind ctx bndr =
let sel_tag | the_offset == 2 = if total_size == 2 then "2a"
else "2b"
| otherwise = show the_offset
- tgts <- genIdsI b
- the_fvjs <- genIds the_fv
+ tgts <- identsForId b
+ the_fvjs <- varsForId the_fv
case (tgts, the_fvjs) of
([tgt], [the_fvj]) -> return $ Just
(tgt ||= ApplExpr (var ("h$c_sel_" <> mkFastString sel_tag)) [the_fvj])
_ -> panic "genBind.assign: invalid size"
assign b (StgRhsClosure _ext _ccs _upd [] expr)
| snd (isInlineExpr (ctxEvaluatedIds ctx) expr) = do
- d <- declIds b
- tgt <- genIds b
+ d <- declVarsForId b
+ tgt <- varsForId b
let ctx' = ctx { ctxTarget = assocIdExprs b tgt }
(j, _) <- genExpr ctx' expr
return (Just (d <> j))
@@ -175,7 +177,7 @@ genBindLne ctx bndr = do
vis <- map (\(x,y,_) -> (x,y)) <$>
optimizeFree oldFrameSize (newLvs++map fst updBinds)
-- initialize updatable bindings to null_
- declUpds <- mconcat <$> mapM (fmap (||= null_) . jsIdI . fst) updBinds
+ declUpds <- mconcat <$> mapM (fmap (||= null_) . identForId . fst) updBinds
-- update expression context to include the updated LNE frame
let ctx' = ctxUpdateLneFrame vis bound ctx
mapM_ (uncurry $ genEntryLne ctx') binds
@@ -220,7 +222,7 @@ genEntryLne ctx i rhs@(StgRhsClosure _ext _cc update args body) =
| otherwise = mempty
lvs <- popLneFrame True payloadSize ctx
body <- genBody ctx i R1 args body
- ei@(TxtI eii) <- jsEntryIdI i
+ ei@(TxtI eii) <- identForEntryId i
sr <- genStaticRefsRhs rhs
let f = JFunc [] (bh <> lvs <> body)
emitClosureInfo $
@@ -234,9 +236,9 @@ genEntryLne ctx i rhs@(StgRhsClosure _ext _cc update args body) =
emitToplevel (ei ||= toJExpr f)
genEntryLne ctx i (StgRhsCon cc con _mu _ticks args) = resetSlots $ do
let payloadSize = ctxLneFrameSize ctx
- ei@(TxtI _eii) <- jsEntryIdI i
- -- di <- enterDataCon con
- ii <- makeIdent
+ ei@(TxtI _eii) <- identForEntryId i
+ -- di <- varForDataConWorker con
+ ii <- freshIdent
p <- popLneFrame True payloadSize ctx
args' <- concatMapM genArg args
ac <- allocCon ii con cc args'
@@ -252,7 +254,7 @@ genEntry ctx i rhs@(StgRhsClosure _ext cc {-_bi live-} upd_flag args body) = res
llv <- verifyRuntimeReps live
upd <- genUpdFrame upd_flag i
body <- genBody entryCtx i R2 args body
- ei@(TxtI eii) <- jsEntryIdI i
+ ei@(TxtI eii) <- identForEntryId i
et <- genEntryType args
setcc <- ifProfiling $
if et == CIThunk
@@ -358,7 +360,7 @@ verifyRuntimeReps xs = do
else mconcat <$> mapM verifyRuntimeRep xs
where
verifyRuntimeRep i = do
- i' <- genIds i
+ i' <- varsForId i
pure $ go i' (idVt i)
go js (VoidV:vs) = go js vs
go (j1:j2:js) (LongV:vs) = v "h$verify_rep_long" [j1,j2] <> go js vs
@@ -376,7 +378,7 @@ verifyRuntimeReps xs = do
loadLiveFun :: [Id] -> G JStat
loadLiveFun l = do
- l' <- concat <$> mapM genIdsI l
+ l' <- concat <$> mapM identsForId l
case l' of
[] -> return mempty
[v] -> return (v ||= r1 .^ closureField1_)
@@ -385,7 +387,7 @@ loadLiveFun l = do
, v2 ||= r1 .^ closureField2_
]
(v:vs) -> do
- d <- makeIdent
+ d <- freshIdent
let l'' = mconcat . zipWith (loadLiveVar $ toJExpr d) [(1::Int)..] $ vs
return $ mconcat
[ v ||= r1 .^ closureField1_
@@ -400,8 +402,15 @@ popLneFrame :: Bool -> Int -> ExprCtx -> G JStat
popLneFrame inEntry size ctx = do
let ctx' = ctxLneShrinkStack ctx size
- is <- mapM (\(i,n) -> (,SlotId i n) <$> genIdsIN i n)
- (ctxLneFrameVars ctx')
+ let gen_id_slot (i,n) = do
+ -- FIXME (Sylvain 2022-08): do we really need to generate all the Idents here
+ -- to only select one? Is it because we need the side effect that consists in
+ -- filling the GlobalId cache?
+ ids <- identsForId i
+ let !id_n = ids !! (n-1)
+ pure (id_n, SlotId i n)
+
+ is <- mapM gen_id_slot (ctxLneFrameVars ctx')
let skip = if inEntry then 1 else 0 -- pop the frame header
popSkipI skip is
@@ -449,6 +458,9 @@ genStaticRefs lv
where
sv = liveStatic lv
+ getStaticRef :: Id -> G (Maybe FastString)
+ getStaticRef = fmap (fmap itxt . listToMaybe) . identsForId
+
-- reorder the things we need to push to reuse existing stack values as much as possible
-- True if already on the stack at that location
optimizeFree :: HasDebugCallStack => Int -> [Id] -> G [(Id,Int,Bool)]
@@ -486,25 +498,25 @@ allocCls dynMiddle xs = do
proper candidates for this optimization should have been floated
already
toCl (i, StgRhsCon cc con []) = do
- ii <- jsIdI i
+ ii <- identForId i
Left <$> (return (decl ii) <> allocCon ii con cc []) -}
toCl (i, StgRhsCon cc con _mui _ticjs [a]) | isUnboxableCon con = do
- ii <- jsIdI i
+ ii <- identForId i
ac <- allocCon ii con cc =<< genArg a
pure (Left (DeclStat ii <> ac))
-- dynamics
toCl (i, StgRhsCon cc con _mu _ticks ar) =
-- fixme do we need to handle unboxed?
- Right <$> ((,,,) <$> jsIdI i
- <*> enterDataCon con
+ Right <$> ((,,,) <$> identForId i
+ <*> varForDataConWorker con
<*> concatMapM genArg ar
<*> pure cc)
toCl (i, cl@(StgRhsClosure _ext cc _upd_flag _args _body)) =
let live = stgLneLiveExpr cl
- in Right <$> ((,,,) <$> jsIdI i
- <*> jsEntryId i
- <*> concatMapM genIds live
+ in Right <$> ((,,,) <$> identForId i
+ <*> varForEntryId i
+ <*> concatMapM varsForId live
<*> pure cc)
-- fixme CgCase has a reps_compatible check here
@@ -517,8 +529,8 @@ genCase :: HasDebugCallStack
-> LiveVars
-> G (JStat, ExprResult)
genCase ctx bnd e at alts l
- | snd (isInlineExpr (ctxEvaluatedIds ctx) e) = withNewIdent $ \ccsVar -> do
- bndi <- genIdsI bnd
+ | snd (isInlineExpr (ctxEvaluatedIds ctx) e) = freshIdent >>= \ccsVar -> do
+ bndi <- identsForId bnd
let ctx' = ctxSetTop bnd
$ ctxSetTarget (assocIdExprs bnd (map toJExpr bndi))
$ ctx
@@ -558,7 +570,7 @@ genRet :: HasDebugCallStack
-> [CgStgAlt]
-> LiveVars
-> G JStat
-genRet ctx e at as l = withNewIdent f
+genRet ctx e at as l = freshIdent >>= f
where
allRefs :: [Id]
allRefs = S.toList . S.unions $ fmap (exprRefs emptyUFM . alt_rhs) as
@@ -598,8 +610,8 @@ genRet ctx e at as l = withNewIdent f
_ -> [PtrV]
fun free = resetSlots $ do
- decs <- declIds e
- load <- flip assignAll (map toJExpr [R1 ..]) . map toJExpr <$> genIdsI e
+ decs <- declVarsForId e
+ load <- flip assignAll (map toJExpr [R1 ..]) . map toJExpr <$> identsForId e
loadv <- verifyRuntimeReps [e]
ras <- loadRetArgs free
rasv <- verifyRuntimeReps (map (\(x,_,_)->x) free)
@@ -627,15 +639,15 @@ genAlts ctx e at me alts = do
PrimAlt _tc
| [GenStgAlt _ bs expr] <- alts
-> do
- ie <- genIds e
- dids <- mconcat <$> mapM declIds bs
- bss <- concatMapM genIds bs
+ ie <- varsForId e
+ dids <- mconcat <$> mapM declVarsForId bs
+ bss <- concatMapM varsForId bs
(ej, er) <- genExpr ctx expr
return (dids <> assignAll bss ie <> ej, er)
PrimAlt tc
-> do
- ie <- genIds e
+ ie <- varsForId e
(r, bss) <- normalizeBranches ctx <$>
mapM (isolateSlots . mkPrimIfBranch ctx [primRepVt tc]) alts
setSlots []
@@ -644,7 +656,7 @@ genAlts ctx e at me alts = do
MultiValAlt n
| [GenStgAlt _ bs expr] <- alts
-> do
- eids <- genIds e
+ eids <- varsForId e
l <- loadUbxTup eids bs n
(ej, er) <- genExpr ctx expr
return (l <> ej, er)
@@ -659,7 +671,7 @@ genAlts ctx e at me alts = do
, [GenStgAlt (DataAlt dc) bs expr] <- alts
, not (isUnboxableCon dc)
-> do
- bsi <- mapM genIdsI bs
+ bsi <- mapM identsForId bs
(ej, er) <- genExpr ctx expr
return (declAssignAll (concat bsi) es <> ej, er)
@@ -674,7 +686,7 @@ genAlts ctx e at me alts = do
, DataAlt dc <- alt_con alt
, isBoolDataCon dc
-> do
- i <- jsId e
+ i <- varForId e
nbs <- normalizeBranches ctx <$>
mapM (isolateSlots . mkAlgBranch ctx e) alts
case nbs of
@@ -689,7 +701,7 @@ genAlts ctx e at me alts = do
-- FIXME: add all alts
AlgAlt _tc -> do
- ei <- jsId e
+ ei <- varForId e
(r, brs) <- normalizeBranches ctx <$>
mapM (isolateSlots . mkAlgBranch ctx e) alts
setSlots []
@@ -707,7 +719,7 @@ verifyMatchRep x alt = do
then pure mempty
else case alt of
AlgAlt tc -> do
- ix <- genIds x
+ ix <- varsForId x
pure $ ApplStat (var "h$verify_match_alg") (ValExpr(JStr(mkFastString (renderWithContext defaultSDocContext (ppr tc)))):ix)
_ -> pure mempty
@@ -740,7 +752,7 @@ normalizeBranches ctx brs
loadUbxTup :: [JExpr] -> [Id] -> Int -> G JStat
loadUbxTup es bs _n = do
- bs' <- concatMapM genIdsI bs
+ bs' <- concatMapM identsForId bs
return $ declAssignAll bs' es
mkSw :: [JExpr] -> [Branch (Maybe [JExpr])] -> JStat
@@ -796,8 +808,8 @@ mkAlgBranch top d alt
, isUnboxableCon dc
, [b] <- alt_bndrs alt
= do
- idd <- jsId d
- fldx <- genIdsI b
+ idd <- varForId d
+ fldx <- identsForId b
case fldx of
[fld] -> do
(ej, er) <- genExpr top (alt_rhs alt)
@@ -807,7 +819,7 @@ mkAlgBranch top d alt
| otherwise
= do
cc <- caseCond (alt_con alt)
- idd <- jsId d
+ idd <- varForId d
b <- loadParams idd (alt_bndrs alt)
(ej, er) <- genExpr top (alt_rhs alt)
return (Branch cc (b <> ej) er)
@@ -838,7 +850,7 @@ caseCond = \case
-- fixme use single tmp var for all branches
loadParams :: JExpr -> [Id] -> G JStat
loadParams from args = do
- as <- concat <$> zipWithM (\a u -> map (,u) <$> genIdsI a) args use
+ as <- concat <$> zipWithM (\a u -> map (,u) <$> identsForId a) args use
return $ case as of
[] -> mempty
[(x,u)] -> loadIfUsed (from .^ closureField1_) x u
=====================================
compiler/GHC/StgToJS/FFI.hs
=====================================
@@ -23,6 +23,7 @@ import GHC.StgToJS.Types
import GHC.StgToJS.Literal
import GHC.StgToJS.Regs
import GHC.StgToJS.CoreUtils
+import GHC.StgToJS.Ids
import GHC.Types.RepType
import GHC.Types.ForeignCall
@@ -101,9 +102,9 @@ parseFFIPatternA :: Bool -- ^ async
-- async calls get an extra callback argument
-- call it with the result
parseFFIPatternA True True pat t es as = do
- cb <- makeIdent
- x <- makeIdent
- d <- makeIdent
+ cb <- freshIdent
+ x <- freshIdent
+ d <- freshIdent
stat <- parseFFIPattern' (Just (toJExpr cb)) True pat t es as
return $ mconcat
[ x ||= (toJExpr (jhFromList [("mv", null_)]))
@@ -220,11 +221,11 @@ genFFIArg _isJavaScriptCc (StgLitArg l) = (mempty,) <$> genLit l
genFFIArg isJavaScriptCc a@(StgVarArg i)
| not isJavaScriptCc &&
(tycon == byteArrayPrimTyCon || tycon == mutableByteArrayPrimTyCon) =
- (\x -> (mempty,[x, zero_])) <$> jsId i
+ (\x -> (mempty,[x, zero_])) <$> varForId i
| isVoid r = return (mempty, [])
-- | Just x <- marshalFFIArg a = x
- | isMultiVar r = (mempty,) <$> mapM (jsIdN i) [1..varSize r]
- | otherwise = (\x -> (mempty,[x])) <$> jsId i
+ | isMultiVar r = (mempty,) <$> mapM (varForIdN i) [1..varSize r]
+ | otherwise = (\x -> (mempty,[x])) <$> varForId i
where
tycon = tyConAppTyCon (unwrapType arg_ty)
arg_ty = stgArgType a
=====================================
compiler/GHC/StgToJS/Ids.hs
=====================================
@@ -0,0 +1,216 @@
+-- | Deals with JS identifiers
+module GHC.StgToJS.Ids
+ ( freshUnique
+ , freshIdent
+ , makeIdentForId
+ , cachedIdentForId
+ -- * Helpers for Idents
+ , identForId
+ , identForIdN
+ , identsForId
+ , identForEntryId
+ , identForDataConEntryId
+ , identForDataConWorker
+ -- * Helpers for variables
+ , varForId
+ , varForIdN
+ , varsForId
+ , varForEntryId
+ , varForDataConEntryId
+ , varForDataConWorker
+ , declVarsForId
+ )
+where
+
+import GHC.Prelude
+
+import GHC.StgToJS.Types
+import GHC.StgToJS.Monad
+import GHC.StgToJS.CoreUtils
+import GHC.StgToJS.UnitUtils
+
+import GHC.JS.Syntax
+import GHC.JS.Make
+
+import GHC.Core.DataCon
+import GHC.Types.Id
+import GHC.Types.Unique
+import GHC.Types.Name
+import GHC.Unit.Module
+import GHC.Utils.Encoding (zEncodeString)
+import GHC.Data.FastString
+
+import Control.Monad
+import qualified Control.Monad.Trans.State.Strict as State
+import qualified Data.Map as M
+import Data.Maybe
+
+-- | Get fresh unique number
+freshUnique :: G Int
+freshUnique = do
+ State.modify (\s -> s { gsId = gsId s + 1})
+ State.gets gsId
+
+-- | Get fresh local Ident of the form: h$$unit:module_uniq
+freshIdent :: G Ident
+freshIdent = do
+ i <- freshUnique
+ mod <- State.gets gsModule
+ let !name = mkFastString $ mconcat
+ [ "h$$"
+ , zEncodeString (unitModuleString mod)
+ , "_"
+ , encodeUnique i
+ ]
+ return (TxtI name)
+
+
+
+-- | Encode a Unique number as a base-62 String
+encodeUnique :: Int -> String
+encodeUnique = reverse . iToBase62 -- reversed is more compressible
+
+-- | Generate unique Ident for the given ID (uncached!)
+--
+-- The ident has the following forms:
+--
+-- global Id: h$unit:module.name[_num][_type_suffix]
+-- local Id: h$$unit:module.name[_num][_type_suffix]_uniq
+--
+-- Note that the string is z-encoded except for "_" delimiters.
+--
+-- Optional "_type_suffix" can be:
+-- - "_e" for IdEntry
+-- - "_con_e" for IdConEntry
+--
+-- Optional "_num" is passed as an argument to this function. It is used for
+-- Haskell Ids that require several JS variables: e.g. 64-bit numbers (Word64#,
+-- Int64#), Addr#, StablePtr#, unboxed tuples, etc.
+--
+makeIdentForId :: Id -> Maybe Int -> IdType -> Module -> Ident
+makeIdentForId i num id_type current_module = TxtI ident
+ where
+ exported = isExportedId i
+ name = getName i
+ !ident = mkFastString $ mconcat
+ [ "h$"
+ , if exported then "" else "$"
+ , zEncodeString $ unitModuleString $ case exported of
+ True | Just m <- nameModule_maybe name -> m
+ _ -> current_module
+ , zEncodeString "."
+ , zString (zEncodeFS (occNameFS (nameOccName name)))
+ , case num of
+ Nothing -> ""
+ Just v -> "_" ++ show v
+ , case id_type of
+ IdPlain -> ""
+ IdEntry -> "_e"
+ IdConEntry -> "_con_e"
+ , if exported
+ then ""
+ else "_" ++ encodeUnique (getKey (getUnique i))
+ ]
+
+-- | Retrieve the cached Ident for the given Id if there is one. Otherwise make
+-- a new one with 'makeIdentForId' and cache it.
+cachedIdentForId :: Id -> Maybe Int -> IdType -> G Ident
+cachedIdentForId i mi id_type = do
+
+ -- compute key
+ let !key = IdKey (getKey . getUnique $ i) (fromMaybe 0 mi) id_type
+
+ -- lookup Ident in the Ident cache
+ IdCache cache <- State.gets gsIdents
+ ident <- case M.lookup key cache of
+ Just ident -> pure ident
+ Nothing -> do
+ mod <- State.gets gsModule
+ let !ident = makeIdentForId i mi id_type mod
+ let !cache' = IdCache (M.insert key ident cache)
+ State.modify (\s -> s { gsIdents = cache' })
+ pure ident
+
+ -- Now update the GlobalId cache, if required
+
+ let update_global_cache = isGlobalId i && isNothing mi && id_type == IdPlain
+ -- fixme also allow caching entries for lifting?
+
+ when (update_global_cache) $ do
+ GlobalIdCache gidc <- getGlobalIdCache
+ case M.lookup ident gidc of
+ Nothing -> setGlobalIdCache $ GlobalIdCache (M.insert ident (key, i) gidc)
+ Just _ -> pure ()
+
+ pure ident
+
+-- | Retrieve default Ident for the given Id
+identForId :: Id -> G Ident
+identForId i = cachedIdentForId i Nothing IdPlain
+
+-- | Retrieve default Ident for the given Id with sub index
+--
+-- Some types, Word64, Addr#, unboxed tuple have more than one corresponding JS
+-- var, hence we use the sub index to identify each subpart / JS variable.
+identForIdN :: Id -> Int -> G Ident
+identForIdN i n = cachedIdentForId i (Just n) IdPlain
+
+-- | Retrieve all the idents for the given Id.
+identsForId :: Id -> G [Ident]
+identsForId i = case typeSize (idType i) of
+ 0 -> pure mempty
+ 1 -> (:[]) <$> identForId i
+ s -> mapM (identForIdN i) [1..s]
+
+
+-- | Retrieve entry Ident for the given Id
+identForEntryId :: Id -> G Ident
+identForEntryId i = cachedIdentForId i Nothing IdEntry
+
+-- | Retrieve datacon entry Ident for the given Id
+--
+-- Different name than the datacon wrapper.
+identForDataConEntryId :: Id -> G Ident
+identForDataConEntryId i = cachedIdentForId i Nothing IdConEntry
+
+
+-- | Retrieve default variable name for the given Id
+varForId :: Id -> G JExpr
+varForId i = toJExpr <$> identForId i
+
+-- | Retrieve default variable name for the given Id with sub index
+varForIdN :: Id -> Int -> G JExpr
+varForIdN i n = toJExpr <$> identForIdN i n
+
+-- | Retrieve all the JS vars for the given Id
+varsForId :: Id -> G [JExpr]
+varsForId i = case typeSize (idType i) of
+ 0 -> pure mempty
+ 1 -> (:[]) <$> varForId i
+ s -> mapM (varForIdN i) [1..s]
+
+
+-- | Retrieve entry variable name for the given Id
+varForEntryId :: Id -> G JExpr
+varForEntryId i = toJExpr <$> identForEntryId i
+
+-- | Retrieve datacon entry variable name for the given Id
+varForDataConEntryId :: Id -> G JExpr
+varForDataConEntryId i = ValExpr . JVar <$> identForDataConEntryId i
+
+
+-- | Retrieve datacon worker entry variable name for the given datacon
+identForDataConWorker :: DataCon -> G Ident
+identForDataConWorker d = identForDataConEntryId (dataConWorkId d)
+
+-- | Retrieve datacon worker entry variable name for the given datacon
+varForDataConWorker :: DataCon -> G JExpr
+varForDataConWorker d = varForDataConEntryId (dataConWorkId d)
+
+-- | Declare all js vars for the id
+declVarsForId :: Id -> G JStat
+declVarsForId i = case typeSize (idType i) of
+ 0 -> return mempty
+ 1 -> DeclStat <$> identForId i
+ s -> mconcat <$> mapM (\n -> DeclStat <$> identForIdN i n) [1..s]
+
=====================================
compiler/GHC/StgToJS/Linker/Compactor.hs
=====================================
@@ -76,7 +76,7 @@ import GHC.StgToJS.Types
import GHC.StgToJS.Linker.Types
import GHC.StgToJS.CoreUtils
import GHC.StgToJS.Closure
-import GHC.StgToJS.Arg()
+import GHC.StgToJS.Arg
import Prelude
import GHC.Utils.Encoding
@@ -389,12 +389,12 @@ staticInitStat :: Bool -- ^ profiling enabled
-> JStat
staticInitStat _prof (StaticInfo i sv cc) =
case sv of
- StaticData con args -> appS "h$sti" ([var i, var con, toJExpr args] ++ ccArg)
- StaticFun f args -> appS "h$sti" ([var i, var f, toJExpr args] ++ ccArg)
+ StaticData con args -> appS "h$sti" ([var i, var con, jsStaticArgs args] ++ ccArg)
+ StaticFun f args -> appS "h$sti" ([var i, var f, jsStaticArgs args] ++ ccArg)
StaticList args mt ->
- appS "h$stl" ([var i, toJExpr args, toJExpr $ maybe null_ (toJExpr . TxtI) mt] ++ ccArg)
+ appS "h$stl" ([var i, jsStaticArgs args, toJExpr $ maybe null_ (toJExpr . TxtI) mt] ++ ccArg)
StaticThunk (Just (f,args)) ->
- appS "h$stc" ([var i, var f, toJExpr args] ++ ccArg)
+ appS "h$stc" ([var i, var f, jsStaticArgs args] ++ ccArg)
_ -> mempty
where
ccArg = maybeToList (fmap toJExpr cc)
=====================================
compiler/GHC/StgToJS/Literal.hs
=====================================
@@ -14,6 +14,7 @@ import GHC.JS.Make
import GHC.StgToJS.Types
import GHC.StgToJS.Monad
+import GHC.StgToJS.Ids
import GHC.Data.FastString
import GHC.Types.Literal
@@ -36,8 +37,8 @@ genLit :: HasDebugCallStack => Literal -> G [JExpr]
genLit = \case
LitChar c -> return [ toJExpr (ord c) ]
LitString str ->
- withNewIdent $ \strLit@(TxtI strLitT) ->
- withNewIdent $ \strOff@(TxtI strOffT) -> do
+ freshIdent >>= \strLit@(TxtI strLitT) ->
+ freshIdent >>= \strOff@(TxtI strOffT) -> do
emitStatic strLitT (StaticUnboxed (StaticUnboxedString str)) Nothing
emitStatic strOffT (StaticUnboxed (StaticUnboxedStringOffset str)) Nothing
return [ ValExpr (JVar strLit), ValExpr (JVar strOff) ]
=====================================
compiler/GHC/StgToJS/Monad.hs
=====================================
@@ -1,6 +1,8 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE BangPatterns #-}
+-- | JS codegen state monad
module GHC.StgToJS.Monad
( runG
, emitGlobal
@@ -11,111 +13,37 @@ module GHC.StgToJS.Monad
, emitForeign
, assertRtsStat
, getSettings
- , updateThunk
- , updateThunk'
, liftToGlobal
- , bhStats
- -- * IDs
- , withNewIdent
- , makeIdent
- , freshUnique
- , jsIdIdent
- , jsId
- , jsIdN
- , jsIdI
- , jsIdIN
- , jsIdIdent'
- , jsIdV
- , jsEnId
- , jsEnIdI
- , jsEntryId
- , jsEntryIdI
- , jsDcEntryId
- , jsDcEntryIdI
- , genIds
- , genIdsN
- , genIdsI
- , genIdsIN
- , getStaticRef
- , declIds
- -- * Datacon
- , enterDataCon
- , enterDataConI
+ , setGlobalIdCache
+ , getGlobalIdCache
-- * Group
, modifyGroup
, resetGroup
- -- * Stack
- , resetSlots
- , isolateSlots
- , setSlots
- , getSlots
- , addSlots
- , dropSlots
- , addUnknownSlots
- , adjPushStack
- , push
- , push'
- , adjSpN
- , adjSpN'
- , adjSp'
- , adjSp
- , pushNN
- , pushNN'
- , pushN'
- , pushN
- , pushOptimized'
- , pushOptimized
- , pushLneFrame
- , pop
- , popn
- , popUnknown
- , popSkipUnknown
- , popSkip
- , popSkip'
- , popSkipI
- , loadSkip
)
where
import GHC.Prelude
import GHC.JS.Syntax
-import GHC.JS.Make
import GHC.JS.Transform
-import GHC.StgToJS.ExprCtx
-import GHC.StgToJS.Heap
import GHC.StgToJS.Types
-import GHC.StgToJS.Regs
-import GHC.StgToJS.CoreUtils
-import GHC.StgToJS.UnitUtils
import GHC.Unit.Module
-import GHC.Core.DataCon
import GHC.Stg.Syntax
import GHC.Types.SrcLoc
import GHC.Types.Id
-import GHC.Types.Name
-import GHC.Types.Unique
import GHC.Types.Unique.FM
import GHC.Types.ForeignCall
-import GHC.Utils.Encoding (zEncodeString)
-import GHC.Utils.Outputable hiding ((<>))
-import GHC.Utils.Misc
import qualified Control.Monad.Trans.State.Strict as State
import GHC.Data.FastString
import qualified Data.Map as M
import qualified Data.Set as S
-import qualified Data.Bits as Bits
import qualified Data.List as L
import Data.Function
-import Data.Maybe
-import Data.Array
-import Data.Monoid
-import Control.Monad
runG :: StgToJSConfig -> Module -> UniqFM Id CgStgExpr -> G a -> IO a
runG config m unfloat action = State.evalStateT action (initState config m unfloat)
@@ -188,186 +116,9 @@ emitForeign mbSpan pat safety cconv arg_tys res_ty = modifyGroup mod_group
Nothing -> "<unknown>"
-withNewIdent :: (Ident -> G a) -> G a
-withNewIdent m = makeIdent >>= m
-
-makeIdent :: G Ident
-makeIdent = do
- i <- freshUnique
- mod <- State.gets gsModule
- -- TODO: Is there a better way to concatenate FastStrings?
- let !name = mkFastString $ mconcat
- [ "h$$"
- , zEncodeString (unitModuleString mod)
- , "_"
- , encodeUnique i
- ]
- return (TxtI name)
-
-encodeUnique :: Int -> String
-encodeUnique = reverse . iToBase62 -- reversed is more compressible
-
-jsId :: Id -> G JExpr
-jsId i
--- | i == trueDataConId = return $ toJExpr True
--- | i == falseDataConId = return $ toJExpr False
- | otherwise = ValExpr . JVar <$> jsIdIdent i Nothing IdPlain
-
-jsIdI :: Id -> G Ident
-jsIdI i = jsIdIdent i Nothing IdPlain
-
--- some types, Word64, Addr#, unboxed tuple have more than one javascript var
-jsIdIN :: Id -> Int -> G Ident
-jsIdIN i n = jsIdIdent i (Just n) IdPlain
-
-jsIdN :: Id -> Int -> G JExpr
-jsIdN i n = ValExpr . JVar <$> jsIdIdent i (Just n) IdPlain
-
--- uncached
-jsIdIdent' :: Id -> Maybe Int -> IdType -> G Ident
-jsIdIdent' i mn suffix0 = do
- (prefix, u) <- mkPrefixU
- let i' = (\x -> mkFastString $ "h$"++prefix++x++mns++suffix++u) . zEncodeString $ name
- i' `seq` return (TxtI i')
- where
- suffix = idTypeSuffix suffix0
- mns = maybe "" (('_':).show) mn
- name = ('.':) . nameStableString . localiseName . getName $ i
-
- mkPrefixU :: G (String, String)
- mkPrefixU
- | isExportedId i, Just x <- (nameModule_maybe . getName) i = do
- let xstr = unitModuleString x
- return (zEncodeString xstr, "")
- | otherwise = (,('_':) . encodeUnique . getKey . getUnique $ i) . ('$':)
- . zEncodeString . unitModuleString <$> State.gets gsModule
-
--- entry id
-jsEnId :: Id -> G JExpr
-jsEnId i = ValExpr . JVar <$> jsEnIdI i
-
-jsEnIdI :: Id -> G Ident
-jsEnIdI i = jsIdIdent i Nothing IdEntry
-
-jsEntryId :: Id -> G JExpr
-jsEntryId i = ValExpr . JVar <$> jsEntryIdI i
-
-jsEntryIdI :: Id -> G Ident
-jsEntryIdI i = jsIdIdent i Nothing IdEntry
-
--- datacon entry, different name than the wrapper
-jsDcEntryId :: Id -> G JExpr
-jsDcEntryId i = ValExpr . JVar <$> jsDcEntryIdI i
-
-jsDcEntryIdI :: Id -> G Ident
-jsDcEntryIdI i = jsIdIdent i Nothing IdConEntry
-
--- entry function of the worker
-enterDataCon :: DataCon -> G JExpr
-enterDataCon d = jsDcEntryId (dataConWorkId d)
-
-enterDataConI :: DataCon -> G Ident
-enterDataConI d = jsDcEntryIdI (dataConWorkId d)
-
-
-jsIdV :: Id -> G JVal
-jsIdV i = JVar <$> jsIdIdent i Nothing IdPlain
-
-
--- | generate all js vars for the ids (can be multiple per var)
-genIds :: Id -> G [JExpr]
-genIds i
- | s == 0 = return mempty
- | s == 1 = (:[]) <$> jsId i
- | otherwise = mapM (jsIdN i) [1..s]
- where
- s = typeSize (idType i)
-
-genIdsN :: Id -> Int -> G JExpr
-genIdsN i n = do
- xs <- genIds i
- return $ xs !! (n-1)
-
--- | get all idents for an id
-genIdsI :: Id -> G [Ident]
-genIdsI i
- | s == 1 = (:[]) <$> jsIdI i
- | otherwise = mapM (jsIdIN i) [1..s]
- where
- s = typeSize (idType i)
-
-genIdsIN :: Id -> Int -> G Ident
-genIdsIN i n = do
- xs <- genIdsI i
- return $ xs !! (n-1)
-
-jsIdIdent :: Id -> Maybe Int -> IdType -> G Ident
-jsIdIdent i mi suffix = do
- IdCache cache <- State.gets gsIdents
- ident <- case M.lookup key cache of
- Just ident -> pure ident
- Nothing -> do
- mod <- State.gets gsModule
- let !ident = makeIdIdent i mi suffix mod
- let !cache' = IdCache (M.insert key ident cache)
- State.modify (\s -> s { gsIdents = cache' })
- pure ident
- updateGlobalIdCache ident
- where
- !key = IdKey (getKey . getUnique $ i) (fromMaybe 0 mi) suffix
- updateGlobalIdCache :: Ident -> G Ident
- updateGlobalIdCache ji
- -- fixme also allow caching entries for lifting?
- | not (isGlobalId i) || isJust mi || suffix /= IdPlain = pure ji
- | otherwise = do
- GlobalIdCache gidc <- getGlobalIdCache
- case M.lookup ji gidc of
- Nothing -> do
- let mod_group g = g { ggsGlobalIdCache = GlobalIdCache (M.insert ji (key, i) gidc) }
- State.modify (\s -> s { gsGroup = mod_group (gsGroup s) })
- Just _ -> pure ()
- pure ji
-
-getStaticRef :: Id -> G (Maybe FastString)
-getStaticRef = fmap (fmap itxt . listToMaybe) . genIdsI
-
--- uncached
-makeIdIdent :: Id -> Maybe Int -> IdType -> Module -> Ident
-makeIdIdent i mn suffix0 mod = TxtI txt
- where
- !txt = mkFastString full_name
-
- full_name = mconcat
- ["h$"
- , prefix
- , zEncodeString ('.':name)
- , mns
- , suffix
- , u
- ]
-
- -- prefix and suffix (unique)
- (prefix,u)
- | isExportedId i
- , Just x <- (nameModule_maybe . getName) i
- = ( zEncodeString (unitModuleString x)
- , ""
- )
- | otherwise
- = ( '$':zEncodeString (unitModuleString mod)
- , '_': encodeUnique (getKey (getUnique i))
- )
-
- suffix = idTypeSuffix suffix0
- mns = maybe "" (('_':).show) mn
- name = renderWithContext defaultSDocContext . pprNameUnqualified . getName $ i
-
-
-
-idTypeSuffix :: IdType -> String
-idTypeSuffix IdPlain = ""
-idTypeSuffix IdEntry = "_e"
-idTypeSuffix IdConEntry = "_con_e"
+
+
+
-- | start with a new binding group
resetGroup :: G ()
@@ -382,225 +133,6 @@ emptyGlobalIdCache = GlobalIdCache M.empty
emptyIdCache :: IdCache
emptyIdCache = IdCache M.empty
--- | run the action with no stack info
-resetSlots :: G a -> G a
-resetSlots m = do
- s <- getSlots
- d <- getStackDepth
- setSlots []
- a <- m
- setSlots s
- setStackDepth d
- return a
-
--- | run the action with current stack info, but don't let modifications propagate
-isolateSlots :: G a -> G a
-isolateSlots m = do
- s <- getSlots
- d <- getStackDepth
- a <- m
- setSlots s
- setStackDepth d
- pure a
-
--- | Set stack depth
-setStackDepth :: Int -> G ()
-setStackDepth d = modifyGroup (\s -> s { ggsStackDepth = d})
-
--- | Get stack depth
-getStackDepth :: G Int
-getStackDepth = State.gets (ggsStackDepth . gsGroup)
-
--- | Modify stack depth
-modifyStackDepth :: (Int -> Int) -> G ()
-modifyStackDepth f = modifyGroup (\s -> s { ggsStackDepth = f (ggsStackDepth s) })
-
--- | overwrite our stack knowledge
-setSlots :: [StackSlot] -> G ()
-setSlots xs = modifyGroup (\g -> g { ggsStack = xs})
-
--- | retrieve our current stack knowledge
-getSlots :: G [StackSlot]
-getSlots = State.gets (ggsStack . gsGroup)
-
--- | Modify stack slots
-modifySlots :: ([StackSlot] -> [StackSlot]) -> G ()
-modifySlots f = modifyGroup (\g -> g { ggsStack = f (ggsStack g)})
-
--- | add `n` unknown slots to our stack knowledge
-addUnknownSlots :: Int -> G ()
-addUnknownSlots n = addSlots (replicate n SlotUnknown)
-
--- | add knowledge about the stack slots
-addSlots :: [StackSlot] -> G ()
-addSlots xs = do
- s <- getSlots
- setSlots (xs ++ s)
-
-dropSlots :: Int -> G ()
-dropSlots n = modifySlots (drop n)
-
-adjPushStack :: Int -> G ()
-adjPushStack n = do
- modifyStackDepth (+n)
- dropSlots n
-
-push :: [JExpr] -> G JStat
-push xs = do
- dropSlots (length xs)
- modifyStackDepth (+ (length xs))
- flip push' xs <$> getSettings
-
-push' :: StgToJSConfig -> [JExpr] -> JStat
-push' _ [] = mempty
-push' cs xs
- | csInlinePush cs || l > 32 || l < 2 = adjSp' l <> mconcat items
- | otherwise = ApplStat (toJExpr $ pushN ! l) xs
- where
- items = zipWith (\i e -> AssignStat ((IdxExpr stack) (toJExpr (offset i))) (toJExpr e))
- [(1::Int)..] xs
- offset i | i == l = sp
- | otherwise = InfixExpr SubOp sp (toJExpr (l - i))
- l = length xs
-
-
-adjSp' :: Int -> JStat
-adjSp' 0 = mempty
-adjSp' n = sp |= InfixExpr AddOp sp (toJExpr n)
-
-adjSpN' :: Int -> JStat
-adjSpN' 0 = mempty
-adjSpN' n = sp |= InfixExpr SubOp sp (toJExpr n)
-
-adjSp :: Int -> G JStat
-adjSp 0 = return mempty
-adjSp n = do
- modifyStackDepth (+n)
- return (adjSp' n)
-
-adjSpN :: Int -> G JStat
-adjSpN 0 = return mempty
-adjSpN n = do
- modifyStackDepth (\x -> x - n)
- return (adjSpN' n)
-
-pushN :: Array Int Ident
-pushN = listArray (1,32) $ map (TxtI . mkFastString . ("h$p"++) . show) [(1::Int)..32]
-
-pushN' :: Array Int JExpr
-pushN' = fmap (ValExpr . JVar) pushN
-
-pushNN :: Array Integer Ident
-pushNN = listArray (1,255) $ map (TxtI . mkFastString . ("h$pp"++) . show) [(1::Int)..255]
-
-pushNN' :: Array Integer JExpr
-pushNN' = fmap (ValExpr . JVar) pushNN
-
-pushOptimized' :: [(Id,Int)] -> G JStat
-pushOptimized' xs = do
- slots <- getSlots
- pushOptimized =<< (zipWithM f xs (slots++repeat SlotUnknown))
- where
- f (i1,n1) (SlotId i2 n2) = (,i1==i2&&n1==n2) <$> genIdsN i1 n1
- f (i1,n1) _ = (,False) <$> genIdsN i1 n1
-
--- | optimized push that reuses existing values on stack automatically chooses
--- an optimized partial push (h$ppN) function when possible.
-pushOptimized :: [(JExpr,Bool)] -- ^ contents of the slots, True if same value is already there
- -> G JStat
-pushOptimized [] = return mempty
-pushOptimized xs = do
- dropSlots l
- modifyStackDepth (+ length xs)
- go . csInlinePush <$> getSettings
- where
- go True = inlinePush
- go _
- | all snd xs = adjSp' l
- | all (not.snd) xs && l <= 32 =
- ApplStat (pushN' ! l) (map fst xs)
- | l <= 8 && not (snd $ last xs) =
- ApplStat (pushNN' ! sig) [ e | (e,False) <- xs ]
- | otherwise = inlinePush
- l = length xs
- sig :: Integer
- sig = L.foldl1' (Bits..|.) $ zipWith (\(_e,b) i -> if not b then Bits.bit i else 0) xs [0..]
- inlinePush = adjSp' l <> mconcat (zipWith pushSlot [1..] xs)
- pushSlot i (ex, False) = IdxExpr stack (offset i) |= ex
- pushSlot _ _ = mempty
- offset i | i == l = sp
- | otherwise = InfixExpr SubOp sp (toJExpr (l - i))
-
-pushLneFrame :: HasDebugCallStack => Int -> ExprCtx -> G JStat
-pushLneFrame size ctx =
- let ctx' = ctxLneShrinkStack ctx size
- in pushOptimized' (ctxLneFrameVars ctx')
-
-popUnknown :: [JExpr] -> G JStat
-popUnknown xs = popSkipUnknown 0 xs
-
-popSkipUnknown :: Int -> [JExpr] -> G JStat
-popSkipUnknown n xs = popSkip n (map (,SlotUnknown) xs)
-
-pop :: [(JExpr,StackSlot)] -> G JStat
-pop = popSkip 0
-
--- | pop the expressions, but ignore the top n elements of the stack
-popSkip :: Int -> [(JExpr,StackSlot)] -> G JStat
-popSkip 0 [] = pure mempty
-popSkip n [] = addUnknownSlots n >> adjSpN n
-popSkip n xs = do
- addUnknownSlots n
- addSlots (map snd xs)
- a <- adjSpN (length xs + n)
- return (loadSkip n (map fst xs) <> a)
-
--- | pop things, don't upstate stack knowledge
-popSkip' :: Int -- ^ number of slots to skip
- -> [JExpr] -- ^ assign stack slot values to these
- -> JStat
-popSkip' 0 [] = mempty
-popSkip' n [] = adjSpN' n
-popSkip' n tgt = loadSkip n tgt <> adjSpN' (length tgt + n)
-
--- | like popSkip, but without modifying the stack pointer
-loadSkip :: Int -> [JExpr] -> JStat
-loadSkip = loadSkipFrom sp
-
-loadSkipFrom :: JExpr -> Int -> [JExpr] -> JStat
-loadSkipFrom fr n xs = mconcat items
- where
- items = reverse $ zipWith (\i ex -> ex |= IdxExpr stack (toJExpr (offset (i+n))))
- [(0::Int)..]
- (reverse xs)
- offset 0 = toJExpr fr
- offset n = InfixExpr SubOp (toJExpr fr) (toJExpr n)
-
-
--- declare and pop
-popSkipI :: Int -> [(Ident,StackSlot)] -> G JStat
-popSkipI 0 [] = pure mempty
-popSkipI n [] = adjSpN n
-popSkipI n xs = do
- addUnknownSlots n
- addSlots (map snd xs)
- a <- adjSpN (length xs + n)
- return (loadSkipI n (map fst xs) <> a)
-
--- like popSkip, but without modifying sp
-loadSkipI :: Int -> [Ident] -> JStat
-loadSkipI = loadSkipIFrom sp
-
-loadSkipIFrom :: JExpr -> Int -> [Ident] -> JStat
-loadSkipIFrom fr n xs = mconcat items
- where
- items = reverse $ zipWith f [(0::Int)..] (reverse xs)
- offset 0 = fr
- offset n = InfixExpr SubOp fr (toJExpr n)
- f i ex = ex ||= IdxExpr stack (toJExpr (offset (i+n)))
-
-popn :: Int -> G JStat
-popn n = addUnknownSlots n >> adjSpN n
assertRtsStat :: G JStat -> G JStat
@@ -614,40 +146,9 @@ getSettings = State.gets gsSettings
getGlobalIdCache :: G GlobalIdCache
getGlobalIdCache = State.gets (ggsGlobalIdCache . gsGroup)
-updateThunk' :: StgToJSConfig -> JStat
-updateThunk' settings =
- if csInlineBlackhole settings
- then bhStats settings True
- else ApplStat (var "h$bh") []
-
--- | Generate statemeents to update the current node with a blackhole
-bhStats :: StgToJSConfig -> Bool -> JStat
-bhStats s pushUpd = mconcat
- [ if pushUpd then push' s [r1, var "h$upd_frame"] else mempty
- , toJExpr R1 .^ closureEntry_ |= var "h$blackhole"
- , toJExpr R1 .^ closureField1_ |= var "h$currentThread"
- , toJExpr R1 .^ closureField2_ |= null_ -- will be filled with waiters array
- ]
-
-updateThunk :: G JStat
-updateThunk = do
- settings <- getSettings
- adjPushStack 2 -- update frame size
- return $ (updateThunk' settings)
-
--- | declare all js vars for the id
-declIds :: Id -> G JStat
-declIds i
- | s == 0 = return mempty
- | s == 1 = DeclStat <$> jsIdI i
- | otherwise = mconcat <$> mapM (\n -> DeclStat <$> jsIdIN i n) [1..s]
- where
- s = typeSize (idType i)
+setGlobalIdCache :: GlobalIdCache -> G ()
+setGlobalIdCache v = State.modify (\s -> s { gsGroup = (gsGroup s) { ggsGlobalIdCache = v}})
-freshUnique :: G Int
-freshUnique = do
- State.modify (\s -> s { gsId = gsId s + 1})
- State.gets gsId
liftToGlobal :: JStat -> G [(Ident, Id)]
liftToGlobal jst = do
@@ -663,10 +164,3 @@ nub' xs = go S.empty xs
go _ [] = []
go s (x:xs) | S.member x s = go s xs
| otherwise = x : go (S.insert x s) xs
--- ids = filter M.member gidc
-{-
- algorithm:
- - collect all Id refs that are in the cache, count usage
- - order by increasing use
- - prepend loading lives var to body: body can stay the same
--}
=====================================
compiler/GHC/StgToJS/Rts/Rts.hs
=====================================
@@ -38,11 +38,11 @@ import GHC.JS.Transform
import GHC.StgToJS.Apply
import GHC.StgToJS.Closure
import GHC.StgToJS.Heap
-import GHC.StgToJS.Monad
import GHC.StgToJS.Printer
import GHC.StgToJS.Profiling
import GHC.StgToJS.Regs
import GHC.StgToJS.Types
+import GHC.StgToJS.Stack
import GHC.Data.FastString
import GHC.Types.Unique.Map
=====================================
compiler/GHC/StgToJS/Stack.hs
=====================================
@@ -0,0 +1,312 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TupleSections #-}
+
+-- | Stack manipulation
+module GHC.StgToJS.Stack
+ ( resetSlots
+ , isolateSlots
+ , setSlots
+ , getSlots
+ , addSlots
+ , dropSlots
+ , addUnknownSlots
+ , adjPushStack
+ , push
+ , push'
+ , adjSpN
+ , adjSpN'
+ , adjSp'
+ , adjSp
+ , pushNN
+ , pushNN'
+ , pushN'
+ , pushN
+ , pushOptimized'
+ , pushOptimized
+ , pushLneFrame
+ , pop
+ , popn
+ , popUnknown
+ , popSkipUnknown
+ , popSkip
+ , popSkip'
+ , popSkipI
+ , loadSkip
+ -- * Thunk update
+ , updateThunk
+ , updateThunk'
+ , bhStats
+ )
+where
+
+import GHC.Prelude
+
+import GHC.JS.Syntax
+import GHC.JS.Make
+
+import GHC.StgToJS.Types
+import GHC.StgToJS.Monad
+import GHC.StgToJS.Ids
+import GHC.StgToJS.ExprCtx
+import GHC.StgToJS.Heap
+import GHC.StgToJS.Regs
+
+import GHC.Types.Id
+import GHC.Utils.Misc
+import GHC.Data.FastString
+
+import qualified Data.Bits as Bits
+import qualified Data.List as L
+import qualified Control.Monad.Trans.State.Strict as State
+import Data.Array
+import Data.Monoid
+import Control.Monad
+
+-- | Run the action with no stack info
+resetSlots :: G a -> G a
+resetSlots m = do
+ s <- getSlots
+ d <- getStackDepth
+ setSlots []
+ a <- m
+ setSlots s
+ setStackDepth d
+ return a
+
+-- | run the action with current stack info, but don't let modifications propagate
+isolateSlots :: G a -> G a
+isolateSlots m = do
+ s <- getSlots
+ d <- getStackDepth
+ a <- m
+ setSlots s
+ setStackDepth d
+ pure a
+
+-- | Set stack depth
+setStackDepth :: Int -> G ()
+setStackDepth d = modifyGroup (\s -> s { ggsStackDepth = d})
+
+-- | Get stack depth
+getStackDepth :: G Int
+getStackDepth = State.gets (ggsStackDepth . gsGroup)
+
+-- | Modify stack depth
+modifyStackDepth :: (Int -> Int) -> G ()
+modifyStackDepth f = modifyGroup (\s -> s { ggsStackDepth = f (ggsStackDepth s) })
+
+-- | overwrite our stack knowledge
+setSlots :: [StackSlot] -> G ()
+setSlots xs = modifyGroup (\g -> g { ggsStack = xs})
+
+-- | retrieve our current stack knowledge
+getSlots :: G [StackSlot]
+getSlots = State.gets (ggsStack . gsGroup)
+
+-- | Modify stack slots
+modifySlots :: ([StackSlot] -> [StackSlot]) -> G ()
+modifySlots f = modifyGroup (\g -> g { ggsStack = f (ggsStack g)})
+
+-- | add `n` unknown slots to our stack knowledge
+addUnknownSlots :: Int -> G ()
+addUnknownSlots n = addSlots (replicate n SlotUnknown)
+
+-- | add knowledge about the stack slots
+addSlots :: [StackSlot] -> G ()
+addSlots xs = do
+ s <- getSlots
+ setSlots (xs ++ s)
+
+dropSlots :: Int -> G ()
+dropSlots n = modifySlots (drop n)
+
+adjPushStack :: Int -> G ()
+adjPushStack n = do
+ modifyStackDepth (+n)
+ dropSlots n
+
+push :: [JExpr] -> G JStat
+push xs = do
+ dropSlots (length xs)
+ modifyStackDepth (+ (length xs))
+ flip push' xs <$> getSettings
+
+push' :: StgToJSConfig -> [JExpr] -> JStat
+push' _ [] = mempty
+push' cs xs
+ | csInlinePush cs || l > 32 || l < 2 = adjSp' l <> mconcat items
+ | otherwise = ApplStat (toJExpr $ pushN ! l) xs
+ where
+ items = zipWith (\i e -> AssignStat ((IdxExpr stack) (toJExpr (offset i))) (toJExpr e))
+ [(1::Int)..] xs
+ offset i | i == l = sp
+ | otherwise = InfixExpr SubOp sp (toJExpr (l - i))
+ l = length xs
+
+
+adjSp' :: Int -> JStat
+adjSp' 0 = mempty
+adjSp' n = sp |= InfixExpr AddOp sp (toJExpr n)
+
+adjSpN' :: Int -> JStat
+adjSpN' 0 = mempty
+adjSpN' n = sp |= InfixExpr SubOp sp (toJExpr n)
+
+adjSp :: Int -> G JStat
+adjSp 0 = return mempty
+adjSp n = do
+ modifyStackDepth (+n)
+ return (adjSp' n)
+
+adjSpN :: Int -> G JStat
+adjSpN 0 = return mempty
+adjSpN n = do
+ modifyStackDepth (\x -> x - n)
+ return (adjSpN' n)
+
+pushN :: Array Int Ident
+pushN = listArray (1,32) $ map (TxtI . mkFastString . ("h$p"++) . show) [(1::Int)..32]
+
+pushN' :: Array Int JExpr
+pushN' = fmap (ValExpr . JVar) pushN
+
+pushNN :: Array Integer Ident
+pushNN = listArray (1,255) $ map (TxtI . mkFastString . ("h$pp"++) . show) [(1::Int)..255]
+
+pushNN' :: Array Integer JExpr
+pushNN' = fmap (ValExpr . JVar) pushNN
+
+pushOptimized' :: [(Id,Int)] -> G JStat
+pushOptimized' xs = do
+ slots <- getSlots
+ pushOptimized =<< (zipWithM f xs (slots++repeat SlotUnknown))
+ where
+ f (i1,n1) xs2 = do
+ -- FIXME (Sylvain 2022-08): do we really need to generate all the Idents here
+ -- to only select one? Is it because we need the side effect that consists in
+ -- filling the GlobalId cache?
+ xs <- varsForId i1
+ let !id_n1 = xs !! (n1-1)
+
+ case xs2 of
+ SlotId i2 n2 -> pure (id_n1,i1==i2&&n1==n2)
+ _ -> pure (id_n1,False)
+
+-- | optimized push that reuses existing values on stack automatically chooses
+-- an optimized partial push (h$ppN) function when possible.
+pushOptimized :: [(JExpr,Bool)] -- ^ contents of the slots, True if same value is already there
+ -> G JStat
+pushOptimized [] = return mempty
+pushOptimized xs = do
+ dropSlots l
+ modifyStackDepth (+ length xs)
+ go . csInlinePush <$> getSettings
+ where
+ go True = inlinePush
+ go _
+ | all snd xs = adjSp' l
+ | all (not.snd) xs && l <= 32 =
+ ApplStat (pushN' ! l) (map fst xs)
+ | l <= 8 && not (snd $ last xs) =
+ ApplStat (pushNN' ! sig) [ e | (e,False) <- xs ]
+ | otherwise = inlinePush
+ l = length xs
+ sig :: Integer
+ sig = L.foldl1' (Bits..|.) $ zipWith (\(_e,b) i -> if not b then Bits.bit i else 0) xs [0..]
+ inlinePush = adjSp' l <> mconcat (zipWith pushSlot [1..] xs)
+ pushSlot i (ex, False) = IdxExpr stack (offset i) |= ex
+ pushSlot _ _ = mempty
+ offset i | i == l = sp
+ | otherwise = InfixExpr SubOp sp (toJExpr (l - i))
+
+pushLneFrame :: HasDebugCallStack => Int -> ExprCtx -> G JStat
+pushLneFrame size ctx =
+ let ctx' = ctxLneShrinkStack ctx size
+ in pushOptimized' (ctxLneFrameVars ctx')
+
+popUnknown :: [JExpr] -> G JStat
+popUnknown xs = popSkipUnknown 0 xs
+
+popSkipUnknown :: Int -> [JExpr] -> G JStat
+popSkipUnknown n xs = popSkip n (map (,SlotUnknown) xs)
+
+pop :: [(JExpr,StackSlot)] -> G JStat
+pop = popSkip 0
+
+-- | pop the expressions, but ignore the top n elements of the stack
+popSkip :: Int -> [(JExpr,StackSlot)] -> G JStat
+popSkip 0 [] = pure mempty
+popSkip n [] = addUnknownSlots n >> adjSpN n
+popSkip n xs = do
+ addUnknownSlots n
+ addSlots (map snd xs)
+ a <- adjSpN (length xs + n)
+ return (loadSkip n (map fst xs) <> a)
+
+-- | pop things, don't upstate stack knowledge
+popSkip' :: Int -- ^ number of slots to skip
+ -> [JExpr] -- ^ assign stack slot values to these
+ -> JStat
+popSkip' 0 [] = mempty
+popSkip' n [] = adjSpN' n
+popSkip' n tgt = loadSkip n tgt <> adjSpN' (length tgt + n)
+
+-- | like popSkip, but without modifying the stack pointer
+loadSkip :: Int -> [JExpr] -> JStat
+loadSkip = loadSkipFrom sp
+
+loadSkipFrom :: JExpr -> Int -> [JExpr] -> JStat
+loadSkipFrom fr n xs = mconcat items
+ where
+ items = reverse $ zipWith (\i ex -> ex |= IdxExpr stack (toJExpr (offset (i+n))))
+ [(0::Int)..]
+ (reverse xs)
+ offset 0 = toJExpr fr
+ offset n = InfixExpr SubOp (toJExpr fr) (toJExpr n)
+
+
+-- declare and pop
+popSkipI :: Int -> [(Ident,StackSlot)] -> G JStat
+popSkipI 0 [] = pure mempty
+popSkipI n [] = adjSpN n
+popSkipI n xs = do
+ addUnknownSlots n
+ addSlots (map snd xs)
+ a <- adjSpN (length xs + n)
+ return (loadSkipI n (map fst xs) <> a)
+
+-- like popSkip, but without modifying sp
+loadSkipI :: Int -> [Ident] -> JStat
+loadSkipI = loadSkipIFrom sp
+
+loadSkipIFrom :: JExpr -> Int -> [Ident] -> JStat
+loadSkipIFrom fr n xs = mconcat items
+ where
+ items = reverse $ zipWith f [(0::Int)..] (reverse xs)
+ offset 0 = fr
+ offset n = InfixExpr SubOp fr (toJExpr n)
+ f i ex = ex ||= IdxExpr stack (toJExpr (offset (i+n)))
+
+popn :: Int -> G JStat
+popn n = addUnknownSlots n >> adjSpN n
+
+updateThunk' :: StgToJSConfig -> JStat
+updateThunk' settings =
+ if csInlineBlackhole settings
+ then bhStats settings True
+ else ApplStat (var "h$bh") []
+
+-- | Generate statements to update the current node with a blackhole
+bhStats :: StgToJSConfig -> Bool -> JStat
+bhStats s pushUpd = mconcat
+ [ if pushUpd then push' s [r1, var "h$upd_frame"] else mempty
+ , toJExpr R1 .^ closureEntry_ |= var "h$blackhole"
+ , toJExpr R1 .^ closureField1_ |= var "h$currentThread"
+ , toJExpr R1 .^ closureField2_ |= null_ -- will be filled with waiters array
+ ]
+
+updateThunk :: G JStat
+updateThunk = do
+ settings <- getSettings
+ adjPushStack 2 -- update frame size
+ return $ (updateThunk' settings)
=====================================
compiler/GHC/StgToJS/StaticPtr.hs
=====================================
@@ -15,15 +15,14 @@ import GHC.JS.Make
import GHC.StgToJS.Types
import GHC.StgToJS.Literal
-import GHC.StgToJS.Monad
+import GHC.StgToJS.Ids
initStaticPtrs :: [SptEntry] -> G JStat
initStaticPtrs ptrs = mconcat <$> mapM initStatic ptrs
where
initStatic (SptEntry sp_id (Fingerprint w1 w2)) = do
- i <- jsId sp_id
+ i <- varForId sp_id
fpa <- concat <$> mapM (genLit . mkLitWord64 . fromIntegral) [w1,w2]
let sptInsert = ApplExpr (var "h$hs_spt_insert") (fpa ++ [i])
- -- fixme can precedence be so that parens aren't needed?
return $ (var "h$initStatic" .^ "push") `ApplStat` [jLam sptInsert]
=====================================
compiler/ghc.cabal.in
=====================================
@@ -643,6 +643,7 @@ Library
GHC.StgToJS.ExprCtx
GHC.StgToJS.FFI
GHC.StgToJS.Heap
+ GHC.StgToJS.Ids
GHC.StgToJS.Literal
GHC.StgToJS.Monad
GHC.StgToJS.Object
@@ -653,6 +654,7 @@ Library
GHC.StgToJS.Rts.Types
GHC.StgToJS.Rts.Rts
GHC.StgToJS.Sinker
+ GHC.StgToJS.Stack
GHC.StgToJS.StaticPtr
GHC.StgToJS.StgUtils
GHC.StgToJS.Types
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9f2e853f01b16119339f4f9086bfdf802e576eda...9716e7f23f01be535a8f211010dd2c5cedb8838d
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9f2e853f01b16119339f4f9086bfdf802e576eda...9716e7f23f01be535a8f211010dd2c5cedb8838d
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/20220815/7804da17/attachment-0001.html>
More information about the ghc-commits
mailing list