[Git][ghc/ghc][master] JavaScript codegen: Use GHC's tag inference where JS backend-specific...

Marge Bot (@marge-bot) gitlab at gitlab.haskell.org
Sat Feb 10 19:28:54 UTC 2024



Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC


Commits:
151770ca by Josh Meredith at 2024-02-10T14:28:15-05:00
JavaScript codegen: Use GHC's tag inference where JS backend-specific evaluation inference was previously used (#24309)

- - - - -


7 changed files:

- compiler/GHC/JS/JStg/Syntax.hs
- compiler/GHC/Stg/InferTags/Rewrite.hs
- compiler/GHC/StgToJS/Apply.hs
- compiler/GHC/StgToJS/Expr.hs
- compiler/GHC/StgToJS/ExprCtx.hs
- compiler/GHC/StgToJS/Types.hs
- compiler/GHC/StgToJS/Utils.hs


Changes:

=====================================
compiler/GHC/JS/JStg/Syntax.hs
=====================================
@@ -70,6 +70,7 @@ module GHC.JS.JStg.Syntax
   ) where
 
 import GHC.Prelude
+import GHC.Utils.Outputable
 
 import GHC.JS.Ident
 
@@ -148,6 +149,16 @@ data JStgExpr
   | ApplExpr   JStgExpr [JStgExpr]         -- ^ Application
   deriving (Eq, Typeable, Generic)
 
+instance Outputable JStgExpr where
+  ppr x = case x of
+    ValExpr _ -> text ("ValExpr" :: String)
+    SelExpr x' _ -> text ("SelExpr" :: String) <+> ppr x'
+    IdxExpr x' y' -> text ("IdxExpr" :: String) <+> ppr (x', y')
+    InfixExpr _ x' y' -> text ("InfixExpr" :: String) <+> ppr (x', y')
+    UOpExpr _ x' -> text ("UOpExpr" :: String) <+> ppr x'
+    IfExpr p t e -> text ("IfExpr" :: String) <+> ppr (p, t, e)
+    ApplExpr x' xs -> text ("ApplExpr" :: String) <+> ppr (x', xs)
+
 -- * Useful pattern synonyms to ease programming with the deeply embedded JS
 --   AST. Each pattern wraps @UOp@ and @Op@ into a @JStgExpr at s to save typing and
 --   for convienience. In addition we include a string wrapper for JS string


=====================================
compiler/GHC/Stg/InferTags/Rewrite.hs
=====================================
@@ -7,7 +7,7 @@
 {-# LANGUAGE GADTs                      #-}
 {-# LANGUAGE TypeFamilies               #-}
 
-module GHC.Stg.InferTags.Rewrite (rewriteTopBinds)
+module GHC.Stg.InferTags.Rewrite (rewriteTopBinds, rewriteOpApp)
 where
 
 import GHC.Prelude
@@ -388,15 +388,15 @@ rewriteId v = do
     if is_tagged then return $! setIdTagSig v (TagSig TagProper)
                  else return v
 
-rewriteExpr :: InferStgExpr -> RM TgStgExpr
-rewriteExpr (e at StgCase {})          = rewriteCase e
-rewriteExpr (e at StgLet {})           = rewriteLet e
-rewriteExpr (e at StgLetNoEscape {})   = rewriteLetNoEscape e
-rewriteExpr (StgTick t e)           = StgTick t <$!> rewriteExpr e
-rewriteExpr e@(StgConApp {})        = rewriteConApp e
-rewriteExpr e@(StgOpApp {})         = rewriteOpApp e
-rewriteExpr e@(StgApp {})           = rewriteApp e
-rewriteExpr (StgLit lit)            = return $! (StgLit lit)
+rewriteExpr :: GenStgExpr 'InferTaggedBinders -> RM (GenStgExpr 'CodeGen)
+rewriteExpr (e at StgCase {})            = rewriteCase e
+rewriteExpr (e at StgLet {})             = rewriteLet e
+rewriteExpr (e at StgLetNoEscape {})     = rewriteLetNoEscape e
+rewriteExpr (StgTick t e)             = StgTick t <$!> rewriteExpr e
+rewriteExpr e@(StgConApp {})          = rewriteConApp e
+rewriteExpr e@(StgApp {})             = rewriteApp e
+rewriteExpr (StgLit lit)              = return $! (StgLit lit)
+rewriteExpr (StgOpApp op args res_ty) = (StgOpApp op) <$!> rewriteArgs args <*> pure res_ty
 
 
 rewriteCase :: InferStgExpr -> RM TgStgExpr
@@ -404,7 +404,7 @@ rewriteCase (StgCase scrut bndr alt_type alts) =
     withBinder NotTopLevel bndr $
         pure StgCase <*>
             rewriteExpr scrut <*>
-            pure (fst bndr) <*>
+            rewriteId (fst bndr) <*>
             pure alt_type <*>
             mapM rewriteAlt alts
 


=====================================
compiler/GHC/StgToJS/Apply.hs
=====================================
@@ -157,7 +157,7 @@ genApp ctx i args
     | [] <- args
     , [vt] <- idJSRep i
     , isUnboxable vt
-    , ctxIsEvaluated ctx i
+    , ctxIsEvaluated i
     = do
       let c = head (concatMap typex_expr $ ctxTarget ctx)
       is <- varsForId i
@@ -171,7 +171,7 @@ genApp ctx i args
     -- case of Id without args and known to be already evaluated: return fields
     -- individually
     | [] <- args
-    , ctxIsEvaluated ctx i || isStrictType (idType i)
+    , ctxIsEvaluated i || isStrictType (idType i)
     = do
       a <- storeIdFields i (ctxTarget ctx)
       -- optional runtime assert for detecting unexpected thunks (unevaluated)
@@ -199,7 +199,7 @@ genApp ctx i args
               a' = case args of
                 [StgVarArg a'] -> a'
                 _              -> panic "genApp: unexpected arg"
-          if isStrictId a' || ctxIsEvaluated ctx a'
+          if isStrictId a' || ctxIsEvaluated a'
             then return (t |= ai, ExprInline Nothing)
             else return (returnS (app "h$e" [ai]), ExprCont)
         _ -> panic "genApp: invalid size"


=====================================
compiler/GHC/StgToJS/Expr.hs
=====================================
@@ -137,12 +137,12 @@ genBind ctx bndr =
        j <- assign b r >>= \case
          Just ja -> return ja
          Nothing -> allocCls Nothing [(b,r)]
-       return (j, addEvalRhs ctx [(b,r)])
+       return (j, ctx)
     StgRec bs     -> do
        jas <- mapM (uncurry assign) bs -- fixme these might depend on parts initialized by allocCls
        let m = if null jas then Nothing else Just (mconcat $ catMaybes jas)
        j <- allocCls m . map snd . filter (isNothing . fst) $ zip jas bs
-       return (j, addEvalRhs ctx bs)
+       return (j, ctx)
    where
      ctx' = ctxClearLneFrame ctx
 
@@ -168,7 +168,7 @@ genBind ctx bndr =
                (tgt ||= ApplExpr (var ("h$c_sel_" <> mkFastString sel_tag)) [the_fvj])
              _ -> panic "genBind.assign: invalid size"
      assign b (StgRhsClosure _ext _ccs _upd [] expr _typ)
-       | snd (isInlineExpr (ctxEvaluatedIds ctx) expr) = do
+       | isInlineExpr expr = do
            d   <- declVarsForId b
            tgt <- varsForId b
            let ctx' = ctx { ctxTarget = assocIdExprs b tgt }
@@ -177,12 +177,6 @@ genBind ctx bndr =
      assign _b StgRhsCon{} = return Nothing
      assign  b r           = genEntry ctx' b r >> return Nothing
 
-     addEvalRhs c [] = c
-     addEvalRhs c ((b,r):xs)
-       | StgRhsCon{} <- r                         = addEvalRhs (ctxAssertEvaluated b c) xs
-       | (StgRhsClosure _ _ ReEntrant _ _ _) <- r = addEvalRhs (ctxAssertEvaluated b c) xs
-       | otherwise                                = addEvalRhs c xs
-
 genBindLne :: HasDebugCallStack
            => ExprCtx
            -> CgStgBinding
@@ -559,7 +553,7 @@ genCase :: HasDebugCallStack
         -> LiveVars
         -> G (JStgStat, ExprResult)
 genCase ctx bnd e at alts l
-  | snd (isInlineExpr (ctxEvaluatedIds ctx) e) = do
+  | isInlineExpr e = do
       bndi <- identsForId bnd
       let ctx' = ctxSetTop bnd
                   $ ctxSetTarget (assocIdExprs bnd (map toJExpr bndi))
@@ -570,7 +564,7 @@ genCase ctx bnd e at alts l
                 ExprCont -> pprPanic "genCase: expression was not inline"
                                      (pprStgExpr panicStgPprOpts e)
 
-      (aj, ar) <- genAlts (ctxAssertEvaluated bnd ctx) bnd at d alts
+      (aj, ar) <- genAlts ctx bnd at d alts
       (saveCCS,restoreCCS) <- ifProfilingM $ do
         ccsVar <- freshIdent
         pure ( ccsVar ||= toJExpr jCurrentCCS
@@ -586,7 +580,7 @@ genCase ctx bnd e at alts l
         , ar
          )
   | otherwise = do
-      rj       <- genRet (ctxAssertEvaluated bnd ctx) bnd at alts l
+      rj       <- genRet ctx bnd at alts l
       let ctx' = ctxSetTop bnd
                   $ ctxSetTarget (assocIdExprs bnd (map toJExpr [R1 ..]))
                   $ ctx


=====================================
compiler/GHC/StgToJS/ExprCtx.hs
=====================================
@@ -18,14 +18,12 @@
 module GHC.StgToJS.ExprCtx
   ( ExprCtx
   , initExprCtx
-  , ctxAssertEvaluated
   , ctxIsEvaluated
   , ctxSetSrcSpan
   , ctxSrcSpan
   , ctxSetTop
   , ctxTarget
   , ctxSetTarget
-  , ctxEvaluatedIds
   -- * Let-no-escape
   , ctxClearLneFrame
   , ctxUpdateLneFrame
@@ -43,9 +41,12 @@ import GHC.Prelude
 import GHC.StgToJS.Types
 
 import GHC.Types.Unique.FM
-import GHC.Types.Unique.Set
 import GHC.Types.Var
 import GHC.Types.SrcLoc
+import GHC.Types.Id
+import GHC.Types.Id.Info
+
+import GHC.Stg.InferTags.TagSig
 
 import GHC.Utils.Outputable
 import GHC.Utils.Panic
@@ -61,10 +62,6 @@ data ExprCtx = ExprCtx
   , ctxTarget     :: [TypedExpr]
     -- ^ Target variables for the evaluated expression
 
-  , ctxEvaluatedIds :: UniqSet Id
-    -- ^ Ids that we know to be evaluated (e.g. case binders when the expression
-    -- to evaluate is in an alternative)
-
   , ctxSrcSpan    :: Maybe RealSrcSpan
     -- ^ Source location
 
@@ -95,7 +92,6 @@ initExprCtx :: Id -> ExprCtx
 initExprCtx i = ExprCtx
   { ctxTop          = i
   , ctxTarget       = []
-  , ctxEvaluatedIds = emptyUniqSet
   , ctxLneFrameBs   = emptyUFM
   , ctxLneFrameVars = []
   , ctxLneFrameSize = 0
@@ -110,10 +106,6 @@ ctxSetTarget t ctx = ctx { ctxTarget = t }
 ctxSetTop :: Id -> ExprCtx -> ExprCtx
 ctxSetTop i ctx = ctx { ctxTop = i }
 
--- | Add an Id to the known-evaluated set
-ctxAssertEvaluated :: Id -> ExprCtx -> ExprCtx
-ctxAssertEvaluated i ctx = ctx { ctxEvaluatedIds = addOneToUniqSet (ctxEvaluatedIds ctx) i }
-
 -- | Set source location
 ctxSetSrcSpan :: RealSrcSpan -> ExprCtx -> ExprCtx
 ctxSetSrcSpan span ctx = ctx { ctxSrcSpan = Just span }
@@ -139,8 +131,39 @@ ctxClearLneFrame ctx =
     }
 
 -- | Predicate: do we know for sure that the given Id is evaluated?
-ctxIsEvaluated :: ExprCtx -> Id -> Bool
-ctxIsEvaluated ctx i = i `elementOfUniqSet` ctxEvaluatedIds ctx
+ctxIsEvaluated :: Id -> Bool
+ctxIsEvaluated i =
+  maybe False isTaggedSig (idTagSig_maybe i)
+  && go (idDetails i)
+  where
+    go JoinId{} = False
+    go _        = True
+
+
+      -- DFunId new_type -> not new_type
+      --    -- DFuns terminate, unless the dict is implemented
+      --    -- with a newtype in which case they may not
+
+      -- DataConWorkId {} -> True
+
+      -- ClassOpId {} -> False
+      --   -- suppose an argument, and we don't have one
+
+      -- PrimOpId op _ -> primop_ok op
+      --   -- probably already handled by StgOpApp
+
+      -- JoinId {} -> False
+      --   -- Don't speculate join points
+
+      -- TickBoxOpId {} -> False
+      --   -- Don't speculate box ticking
+
+      -- -- Tagged (evaluated) ids
+      -- _ | Just sig <- idTagSig_maybe i
+      --   , isTaggedSig sig
+      --   -> True
+
+      -- _ -> False
 
 -- | Does the given Id correspond to a LNE binding
 ctxIsLneBinding :: ExprCtx -> Id -> Bool


=====================================
compiler/GHC/StgToJS/Types.hs
=====================================
@@ -342,6 +342,9 @@ data TypedExpr = TypedExpr
   , typex_expr :: [JStgExpr]
   }
 
+instance Outputable TypedExpr where
+  ppr (TypedExpr typ x) = ppr (typ, x)
+
 -- | A Primop result is either an inlining of some JS payload, or a primitive
 -- call to a JS function defined in Shim files in base.
 data PrimRes


=====================================
compiler/GHC/StgToJS/Utils.hs
=====================================
@@ -69,7 +69,6 @@ import GHC.Types.Var.Set
 import GHC.Types.Id
 import GHC.Types.Id.Info
 import GHC.Types.Unique.FM
-import GHC.Types.Unique.Set
 import GHC.Types.ForeignCall
 import GHC.Types.TyThing
 import GHC.Types.Name
@@ -108,11 +107,16 @@ assignToExprCtx ctx es = assignToTypedExprs (ctxTarget ctx) es
 assignCoerce1 :: [TypedExpr] -> [TypedExpr] -> JStgStat
 assignCoerce1 [x] [y] = assignCoerce x y
 assignCoerce1 []  []  = mempty
-assignCoerce1 _x _y   = pprPanic "assignCoerce1"
+-- We silently ignore the case of an empty list on the first argument. It denotes
+-- "assign nothing to n empty slots on the right". Usually this case shouldn't come
+-- up, but rare cases where the earlier code can't correctly guess the size of type
+-- classes causes slots to be allocated when they aren't needed.
+assignCoerce1 []  _   = mempty
+assignCoerce1 x y     = pprPanic "assignCoerce1"
                           (vcat [ text "lengths do not match"
                                 -- FIXME: Outputable instance removed until JStg replaces JStat
-                                -- , ppr x
-                                -- , ppr y
+                                , ppr x
+                                , ppr y
                                 ])
 
 -- | Assign p2 to p1 with optional coercion
@@ -417,61 +421,48 @@ stgLneLiveExpr rhs = dVarSetElems (liveVars $ stgRhsLive rhs)
 -- stgLneLiveExpr StgRhsCon {}              = []
 
 -- | returns True if the expression is definitely inline
-isInlineExpr :: UniqSet Id -> CgStgExpr -> (UniqSet Id, Bool)
-isInlineExpr v = \case
+isInlineExpr :: CgStgExpr -> Bool
+isInlineExpr = \case
   StgApp i args
-    -> (emptyUniqSet, isInlineApp v i args)
+    -> isInlineApp i args
   StgLit{}
-    -> (emptyUniqSet, True)
+    -> True
   StgConApp{}
-    -> (emptyUniqSet, True)
+    -> True
   StgOpApp (StgFCallOp f _) _ _
-    -> (emptyUniqSet, isInlineForeignCall f)
+    -> isInlineForeignCall f
   StgOpApp (StgPrimOp SeqOp) [StgVarArg e] t
-    -> (emptyUniqSet, e `elementOfUniqSet` v || isStrictType t)
+    -> ctxIsEvaluated e || isStrictType t
   StgOpApp (StgPrimOp op) _ _
-    -> (emptyUniqSet, primOpIsReallyInline op)
+    -> primOpIsReallyInline op
   StgOpApp (StgPrimCallOp _c) _ _
-    -> (emptyUniqSet, True)
-  StgCase e b _ alts
-    ->let (_ve, ie)   = isInlineExpr v e
-          v'          = addOneToUniqSet v b
-          (vas, ias)  = unzip $ map (isInlineExpr v') (fmap alt_rhs alts)
-          vr          = L.foldl1' intersectUniqSets vas
-      in (vr, (ie || b `elementOfUniqSet` v) && and ias)
-  StgLet _ b e
-    -> isInlineExpr (inspectInlineBinding v b) e
-  StgLetNoEscape _ _b e
-    -> isInlineExpr v e
-  StgTick  _ e
-    -> isInlineExpr v e
-
-inspectInlineBinding :: UniqSet Id -> CgStgBinding -> UniqSet Id
-inspectInlineBinding v = \case
-  StgNonRec i r -> inspectInlineRhs v i r
-  StgRec bs     -> foldl' (\v' (i,r) -> inspectInlineRhs v' i r) v bs
-
-inspectInlineRhs :: UniqSet Id -> Id -> CgStgRhs -> UniqSet Id
-inspectInlineRhs v i = \case
-  StgRhsCon{}                       -> addOneToUniqSet v i
-  StgRhsClosure _ _ ReEntrant _ _ _ -> addOneToUniqSet v i
-  _                                 -> v
+    -> True
+  StgCase e _ _ alts
+    ->let ie   = isInlineExpr e
+          ias  = map isInlineExpr (fmap alt_rhs alts)
+      in ie && and ias
+  StgLet _ _ e
+    -> isInlineExpr e
+  StgLetNoEscape _ _ e
+    -> isInlineExpr e
+  StgTick _ e
+    -> isInlineExpr e
 
 isInlineForeignCall :: ForeignCall -> Bool
 isInlineForeignCall (CCall (CCallSpec _ cconv safety)) =
   not (playInterruptible safety) &&
   not (cconv /= JavaScriptCallConv && playSafe safety)
 
-isInlineApp :: UniqSet Id -> Id -> [StgArg] -> Bool
-isInlineApp v i = \case
+isInlineApp :: Id -> [StgArg] -> Bool
+isInlineApp i = \case
   _ | isJoinId i -> False
   [] -> isUnboxedTupleType (idType i) ||
                      isStrictType (idType i) ||
-                     i `elementOfUniqSet` v
+                     ctxIsEvaluated i
 
   [StgVarArg a]
     | DataConWrapId dc <- idDetails i
     , isNewTyCon (dataConTyCon dc)
-    , isStrictType (idType a) || a `elementOfUniqSet` v || isStrictId a
+    , isStrictType (idType a) || ctxIsEvaluated a || isStrictId a
     -> True
   _ -> False



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/151770caa709070aa8bbdbabe9d169c2f1d3633f

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/151770caa709070aa8bbdbabe9d169c2f1d3633f
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/20240210/fbdace83/attachment-0001.html>


More information about the ghc-commits mailing list