[Git][ghc/ghc][master] StgToJS: Simplify ExprInline constructor of ExprResult
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Tue Feb 27 18:28:08 UTC 2024
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
3da0a551 by Matthew Craven at 2024-02-27T13:27:22-05:00
StgToJS: Simplify ExprInline constructor of ExprResult
Its payload was used only for a small optimization in genAlts,
avoiding a few assignments for programs of this form:
case NormalDataCon arg1 arg2 of x { NormalDataCon x1 x2 -> ... ; }
But when compiling with optimizations, this sort of code is
generally eliminated by case-of-known-constructor in Core-to-Core.
So it doesn't seem worth tracking and cleaning up again in StgToJS.
- - - - -
4 changed files:
- compiler/GHC/StgToJS/Apply.hs
- compiler/GHC/StgToJS/Expr.hs
- compiler/GHC/StgToJS/FFI.hs
- compiler/GHC/StgToJS/Types.hs
Changes:
=====================================
compiler/GHC/StgToJS/Apply.hs
=====================================
@@ -113,7 +113,7 @@ genApp ctx i args
let profArg = if prof then [jCafCCS] else []
a <- genArg x
return ( top |= app "h$appendToHsStringA" (toJExpr d : a ++ profArg)
- , ExprInline Nothing
+ , ExprInline
)
-- let-no-escape
@@ -131,14 +131,14 @@ genApp ctx i args
| [] <- args
, getUnique i == proxyHashKey
, [top] <- concatMap typex_expr (ctxTarget ctx)
- = return (top |= null_, ExprInline Nothing)
+ = return (top |= null_, ExprInline)
-- unboxed tuple or strict type: return fields individually
| [] <- args
, isUnboxedTupleType (idType i) || isStrictType (idType i)
= do
a <- storeIdFields i (ctxTarget ctx)
- return (a, ExprInline Nothing)
+ return (a, ExprInline)
-- 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
@@ -164,7 +164,7 @@ genApp ctx i args
case is of
[i'] ->
return ( c |= if_ (isObject i') (closureField1 i') i'
- , ExprInline Nothing
+ , ExprInline
)
_ -> panic "genApp: invalid size"
@@ -182,7 +182,7 @@ genApp ctx i args
(appS "throw" [String "unexpected thunk"]) -- yuck
mempty
_ -> mempty
- return (a `mappend` ww, ExprInline Nothing)
+ return (a `mappend` ww, ExprInline)
-- Case: "newtype" datacon wrapper
@@ -200,7 +200,7 @@ genApp ctx i args
[StgVarArg a'] -> a'
_ -> panic "genApp: unexpected arg"
if isStrictId a' || ctxIsEvaluated a'
- then return (t |= ai, ExprInline Nothing)
+ then return (t |= ai, ExprInline)
else return (returnS (app "h$e" [ai]), ExprCont)
_ -> panic "genApp: invalid size"
=====================================
compiler/GHC/StgToJS/Expr.hs
=====================================
@@ -98,11 +98,11 @@ genExpr ctx stg = case stg of
StgLit l -> do
ls <- genLit l
let r = assignToExprCtx ctx ls
- pure (r,ExprInline Nothing)
+ pure (r,ExprInline)
StgConApp con _n args _ -> do
as <- concatMapM genArg args
c <- genCon ctx con as
- return (c, ExprInline (Just as))
+ return (c, ExprInline)
StgOpApp (StgFCallOp f _) args t
-> genForeignCall ctx f t (concatMap typex_expr $ ctxTarget ctx) args
StgOpApp (StgPrimOp op) args t
@@ -561,12 +561,9 @@ genCase ctx bnd e at alts l
$ ctxSetTarget (assocIdExprs bnd (map toJExpr bndi))
$ ctx
(ej, r) <- genExpr ctx' e
- let d = case r of
- ExprInline d0 -> d0
- ExprCont -> pprPanic "genCase: expression was not inline"
- (pprStgExpr panicStgPprOpts e)
+ massert (r == ExprInline)
- (aj, ar) <- genAlts ctx bnd at d alts
+ (aj, ar) <- genAlts ctx bnd at alts
(saveCCS,restoreCCS) <- ifProfilingM $ do
ccsVar <- freshIdent
pure ( ccsVar ||= toJExpr jCurrentCCS
@@ -655,7 +652,7 @@ genRet ctx e at as l = freshIdent >>= f
restoreCCS <- ifProfilingM . pop_handle_CCS $ pure (jCurrentCCS, SlotUnknown)
rlne <- popLneFrame False lneLive ctx'
rlnev <- verifyRuntimeReps lneVars
- (alts, _altr) <- genAlts ctx' e at Nothing as
+ (alts, _altr) <- genAlts ctx' e at as
return $ decs <> load <> loadv <> ras <> rasv <> restoreCCS <> rlne <> rlnev <> alts <>
returnStack
@@ -666,10 +663,9 @@ genAlts :: HasDebugCallStack
=> ExprCtx -- ^ lhs to assign expression result to
-> Id -- ^ id being matched
-> AltType -- ^ type
- -> Maybe [JStgExpr] -- ^ if known, fields in datacon from earlier expression
-> [CgStgAlt] -- ^ the alternatives
-> G (JStgStat, ExprResult)
-genAlts ctx e at me alts = do
+genAlts ctx e at alts = do
(st, er) <- case at of
PolyAlt -> case alts of
@@ -706,15 +702,6 @@ genAlts ctx e at me alts = do
, isUnboxedTupleTyCon tc
-> panic "genAlts: unexpected unboxed tuple"
- AlgAlt _tc
- | Just es <- me
- , [GenStgAlt (DataAlt dc) bs expr] <- alts
- , not (isUnboxableCon dc)
- -> do
- bsi <- mapM identsForId bs
- (ej, er) <- genExpr ctx expr
- return (declAssignAll (concat bsi) es <> ej, er)
-
AlgAlt _tc
| [alt] <- alts
-> do
@@ -784,13 +771,13 @@ normalizeBranches ctx brs
| branchResult (fmap branch_result brs) == ExprCont =
(ExprCont, map mkCont brs)
| otherwise =
- (ExprInline Nothing, brs)
+ (ExprInline, brs)
where
mkCont b = case branch_result b of
- ExprInline{} -> b { branch_stat = branch_stat b <> assignAll jsRegsFromR1
- (concatMap typex_expr $ ctxTarget ctx)
- , branch_result = ExprCont
- }
+ ExprInline -> b { branch_stat = branch_stat b <> assignAll jsRegsFromR1
+ (concatMap typex_expr $ ctxTarget ctx)
+ , branch_result = ExprCont
+ }
_ -> b
-- | Load an unboxed tuple. "Loading" means getting all 'Idents' from the input
@@ -935,7 +922,7 @@ branchResult = \case
(ExprCont:_) -> ExprCont
(_:es)
| elem ExprCont es -> ExprCont
- | otherwise -> ExprInline Nothing
+ | otherwise -> ExprInline
-- | Push return arguments onto the stack. The 'Bool' tracks whether the value
-- is already on the stack or not, used in 'StgToJS.Stack.pushOptimized'.
@@ -1052,5 +1039,5 @@ genPrimOp ctx op args t = do
-- fixme: should we preserve/check the primreps?
jsm <- liftIO initJSM
return $ case runJSM jsm prim_gen of
- PrimInline s -> (s, ExprInline Nothing)
+ PrimInline s -> (s, ExprInline)
PRPrimCall s -> (s, ExprCont)
=====================================
compiler/GHC/StgToJS/FFI.hs
=====================================
@@ -45,7 +45,7 @@ import qualified Data.List as L
genPrimCall :: ExprCtx -> PrimCall -> [StgArg] -> Type -> G (JStgStat, ExprResult)
genPrimCall ctx (PrimCall lbl _) args t = do
j <- parseFFIPattern False False False ("h$" ++ unpackFS lbl) t (concatMap typex_expr $ ctxTarget ctx) args
- return (j, ExprInline Nothing)
+ return (j, ExprInline)
-- | generate the actual call
{-
@@ -193,7 +193,7 @@ genForeignCall _ctx
, Just pairs <- getObjectKeyValuePairs args = do
pairs' <- mapM (\(k,v) -> genArg v >>= \vs -> return (k, head vs)) pairs
return ( (|=) obj (ValExpr (JHash $ listToUniqMap pairs'))
- , ExprInline Nothing
+ , ExprInline
)
genForeignCall ctx (CCall (CCallSpec ccTarget cconv safety)) t tgt args = do
@@ -211,7 +211,7 @@ genForeignCall ctx (CCall (CCallSpec ccTarget cconv safety)) t tgt args = do
| otherwise = "h$callDynamic"
exprResult | async = ExprCont
- | otherwise = ExprInline Nothing
+ | otherwise = ExprInline
catchExcep = (cconv == JavaScriptCallConv) &&
playSafe safety || playInterruptible safety
=====================================
compiler/GHC/StgToJS/Types.hs
=====================================
@@ -357,7 +357,7 @@ data PrimRes
data ExprResult
= ExprCont
- | ExprInline (Maybe [JStgExpr])
+ | ExprInline
deriving (Eq)
newtype ExprValData = ExprValData [JStgExpr]
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3da0a55111774007959dfe5124af5a3f316ee1d1
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3da0a55111774007959dfe5124af5a3f316ee1d1
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/20240227/9c69c6f4/attachment-0001.html>
More information about the ghc-commits
mailing list