[Git][ghc/ghc][wip/remove-ExprResult-ExprInline-payload] StgToJS: Simplify ExprInline constructor of ExprResult

Matthew Craven (@clyring) gitlab at gitlab.haskell.org
Fri Feb 23 17:37:26 UTC 2024



Matthew Craven pushed to branch wip/remove-ExprResult-ExprInline-payload at Glasgow Haskell Compiler / GHC


Commits:
8b3f1af7 by Matthew Craven at 2024-02-23T12:37:04-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/8b3f1af7727659a18f163dfa2e62442f60c04ab0

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8b3f1af7727659a18f163dfa2e62442f60c04ab0
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/20240223/3072e7cb/attachment-0001.html>


More information about the ghc-commits mailing list