[Git][ghc/ghc][ghc-9.8] 2 commits: exprIsTrivial: Factor out shared implementation
Zubin (@wz1000)
gitlab at gitlab.haskell.org
Tue Jun 25 11:58:19 UTC 2024
Zubin pushed to branch ghc-9.8 at Glasgow Haskell Compiler / GHC
Commits:
9cb7e73a by Sebastian Graf at 2024-05-06T15:11:25+02:00
exprIsTrivial: Factor out shared implementation
The duplication between `exprIsTrivial` and `getIdFromTrivialExpr_maybe` has
been bugging me for a long time.
This patch introduces an inlinable worker function `trivial_expr_fold` acting
as the single, shared decision procedure of triviality. It "returns" a
Church-encoded `Maybe (Maybe Id)`, so when it is inlined, it fuses to similar
code as before.
(Better code, even, in the case of `getIdFromTrivialExpr` which presently
allocates a `Just` constructor that cancels away after this patch.)
- - - - -
78a25354 by Sebastian Graf at 2024-05-07T09:25:04+02:00
Some cherry-picked bits of 59202c8 to fix #24718
As noted in f3225ed4b3f3c4, the test below is flaky on Darwin.
Metric Decrease:
MultiLayerModulesTH_Make
- - - - -
4 changed files:
- compiler/GHC/Core/Utils.hs
- compiler/GHC/CoreToStg.hs
- + testsuite/tests/core-to-stg/T24718.hs
- testsuite/tests/core-to-stg/all.T
Changes:
=====================================
compiler/GHC/Core/Utils.hs
=====================================
@@ -23,9 +23,9 @@ module GHC.Core.Utils (
-- * Properties of expressions
exprType, coreAltType, coreAltsType, mkLamType, mkLamTypes,
mkFunctionType,
- exprIsDupable, exprIsTrivial, getIdFromTrivialExpr,
- getIdFromTrivialExpr_maybe,
- exprIsCheap, exprIsExpandable, exprIsCheapX, CheapAppFun,
+ exprIsTrivial, getIdFromTrivialExpr, getIdFromTrivialExpr_maybe,
+ trivial_expr_fold,
+ exprIsDupable, exprIsCheap, exprIsExpandable, exprIsCheapX, CheapAppFun,
exprIsHNF, exprOkForSpeculation, exprOkForSideEffects, exprOkForSpecEval,
exprIsWorkFree, exprIsConLike,
isCheapApp, isExpandableApp, isSaturatedConApp,
@@ -1046,20 +1046,37 @@ and that confuses the code generator (#11155). So best to kill
it off at source.
-}
+{-# INLINE trivial_expr_fold #-}
+trivial_expr_fold :: (Id -> r) -> (Literal -> r) -> r -> r -> CoreExpr -> r
+-- ^ The worker function for Note [exprIsTrivial] and Note [getIdFromTrivialExpr]
+-- This is meant to have the code of both functions in one place and make it
+-- easy to derive custom predicates.
+--
+-- (trivial_expr_fold k_id k_triv k_not_triv e)
+-- * returns (k_id x) if `e` is a variable `x` (with trivial wrapping)
+-- * returns (k_lit x) if `e` is a trivial literal `l` (with trivial wrapping)
+-- * returns k_triv if `e` is a literal, type, or coercion (with trivial wrapping)
+-- * returns k_not_triv otherwise
+--
+-- where "trivial wrapping" is
+-- * Type application or abstraction
+-- * Ticks other than `tickishIsCode`
+-- * `case e of {}` an empty case
+trivial_expr_fold k_id k_lit k_triv k_not_triv = go
+ where
+ go (Var v) = k_id v -- See Note [Variables are trivial]
+ go (Lit l) | litIsTrivial l = k_lit l
+ go (Type _) = k_triv
+ go (Coercion _) = k_triv
+ go (App f t) | not (isRuntimeArg t) = go f
+ go (Lam b e) | not (isRuntimeVar b) = go e
+ go (Tick t e) | not (tickishIsCode t) = go e -- See Note [Tick trivial]
+ go (Cast e _) = go e
+ go (Case e _ _ []) = go e -- See Note [Empty case is trivial]
+ go _ = k_not_triv
+
exprIsTrivial :: CoreExpr -> Bool
--- If you modify this function, you may also
--- need to modify getIdFromTrivialExpr
-exprIsTrivial (Var _) = True -- See Note [Variables are trivial]
-exprIsTrivial (Type _) = True
-exprIsTrivial (Coercion _) = True
-exprIsTrivial (Lit lit) = litIsTrivial lit
-exprIsTrivial (App e arg) = not (isRuntimeArg arg) && exprIsTrivial e
-exprIsTrivial (Lam b e) = not (isRuntimeVar b) && exprIsTrivial e
-exprIsTrivial (Tick t e) = not (tickishIsCode t) && exprIsTrivial e
- -- See Note [Tick trivial]
-exprIsTrivial (Cast e _) = exprIsTrivial e
-exprIsTrivial (Case e _ _ []) = exprIsTrivial e -- See Note [Empty case is trivial]
-exprIsTrivial _ = False
+exprIsTrivial e = trivial_expr_fold (const True) (const True) True False e
{-
Note [getIdFromTrivialExpr]
@@ -1079,24 +1096,13 @@ T12076lit for an example where this matters.
-}
getIdFromTrivialExpr :: HasDebugCallStack => CoreExpr -> Id
-getIdFromTrivialExpr e
- = fromMaybe (pprPanic "getIdFromTrivialExpr" (ppr e))
- (getIdFromTrivialExpr_maybe e)
-
-getIdFromTrivialExpr_maybe :: CoreExpr -> Maybe Id
-- See Note [getIdFromTrivialExpr]
--- Th equations for this should line up with those for exprIsTrivial
-getIdFromTrivialExpr_maybe e
- = go e
+getIdFromTrivialExpr e = trivial_expr_fold id (const panic) panic panic e
where
- go (App f t) | not (isRuntimeArg t) = go f
- go (Tick t e) | not (tickishIsCode t) = go e
- go (Cast e _) = go e
- go (Lam b e) | not (isRuntimeVar b) = go e
- go (Case e _ _ []) = go e
- go (Var v) = Just v
- go _ = Nothing
+ panic = pprPanic "getIdFromTrivialExpr" (ppr e)
+getIdFromTrivialExpr_maybe :: CoreExpr -> Maybe Id
+getIdFromTrivialExpr_maybe e = trivial_expr_fold Just (const Nothing) Nothing Nothing e
{- *********************************************************************
* *
=====================================
compiler/GHC/CoreToStg.hs
=====================================
@@ -19,8 +19,7 @@ module GHC.CoreToStg ( CoreToStgOpts (..), coreToStg ) where
import GHC.Prelude
import GHC.Core
-import GHC.Core.Utils ( exprType, findDefault, isJoinBind
- , exprIsTickedString_maybe )
+import GHC.Core.Utils
import GHC.Core.Opt.Arity ( manifestArity )
import GHC.Core.Type
import GHC.Core.TyCon
@@ -49,7 +48,7 @@ import GHC.Unit.Module
import GHC.Data.FastString
import GHC.Platform ( Platform )
import GHC.Platform.Ways
-import GHC.Builtin.PrimOps ( PrimCall(..), primOpWrapperId )
+import GHC.Builtin.PrimOps
import GHC.Utils.Outputable
import GHC.Utils.Monad
@@ -574,6 +573,19 @@ coreToStgApp f args ticks = do
-- This is the guy that turns applications into A-normal form
-- ---------------------------------------------------------------------------
+getStgArgFromTrivialArg :: HasDebugCallStack => CoreArg -> StgArg
+-- A (non-erased) trivial CoreArg corresponds to an atomic StgArg.
+-- CoreArgs may not immediately look trivial, e.g., `case e of {}` or
+-- `case unsafeequalityProof of UnsafeRefl -> e` might intervene.
+-- Good thing we can just call `trivial_expr_fold` here.
+getStgArgFromTrivialArg e
+ | Just s <- exprIsTickedString_maybe e -- This case is just for backport to GHC 9.8,
+ = StgLitArg (LitString s) -- where we used to treat strings as valid StgArgs
+ | otherwise
+ = trivial_expr_fold StgVarArg StgLitArg panic panic e
+ where
+ panic = pprPanic "getStgArgFromTrivialArg" (ppr e)
+
coreToStgArgs :: [CoreArg] -> CtsM ([StgArg], [StgTickish])
coreToStgArgs []
= return ([], [])
@@ -586,42 +598,29 @@ coreToStgArgs (Coercion _ : args) -- Coercion argument; See Note [Coercion token
= do { (args', ts) <- coreToStgArgs args
; return (StgVarArg coercionTokenId : args', ts) }
-coreToStgArgs (Tick t e : args)
- = assert (not (tickishIsCode t)) $
- do { (args', ts) <- coreToStgArgs (e : args)
- ; let !t' = coreToStgTick (exprType e) t
- ; return (args', t':ts) }
-
coreToStgArgs (arg : args) = do -- Non-type argument
(stg_args, ticks) <- coreToStgArgs args
- arg' <- coreToStgExpr arg
- let
- (aticks, arg'') = stripStgTicksTop tickishFloatable arg'
- stg_arg = case arg'' of
- StgApp v [] -> StgVarArg v
- StgConApp con _ [] _ -> StgVarArg (dataConWorkId con)
- StgOpApp (StgPrimOp op) [] _ -> StgVarArg (primOpWrapperId op)
- StgLit lit -> StgLitArg lit
- _ -> pprPanic "coreToStgArgs" (ppr arg $$ pprStgExpr panicStgPprOpts arg' $$ pprStgExpr panicStgPprOpts arg'')
-
- -- WARNING: what if we have an argument like (v `cast` co)
- -- where 'co' changes the representation type?
- -- (This really only happens if co is unsafe.)
- -- Then all the getArgAmode stuff in CgBindery will set the
- -- cg_rep of the CgIdInfo based on the type of v, rather
- -- than the type of 'co'.
- -- This matters particularly when the function is a primop
- -- or foreign call.
- -- Wanted: a better solution than this hacky warning
-
+ -- We know that `arg` must be trivial, but it may contain Ticks.
+ -- Example from test case `decodeMyStack`:
+ -- $ @... ((src<decodeMyStack.hs:18:26-28> Data.Tuple.snd) @Int @[..])
+ -- Note that unfortunately the Tick is not at the top.
+ -- So we'll traverse the expression twice:
+ -- * Once with `stripTicksT` (which collects *all* ticks from the expression)
+ -- * and another time with `getStgArgFromTrivialArg`.
+ -- Since the argument is trivial, the only place the Tick can occur is
+ -- somehow wrapping a variable (give or take type args, as above).
platform <- getPlatform
- let
- arg_rep = typePrimRep (exprType arg)
- stg_arg_rep = typePrimRep (stgArgType stg_arg)
+ let arg_ty = exprType arg
+ ticks' = map (coreToStgTick arg_ty) (stripTicksT (not . tickishIsCode) arg)
+ arg' = getStgArgFromTrivialArg arg
+ arg_rep = typePrimRep arg_ty
+ stg_arg_rep = typePrimRep (stgArgType arg')
bad_args = not (primRepsCompatible platform arg_rep stg_arg_rep)
- warnPprTrace bad_args "Dangerous-looking argument. Probable cause: bad unsafeCoerce#" (ppr arg) $
- return (stg_arg : stg_args, ticks ++ aticks)
+ massertPpr (length ticks' <= 1) (text "More than one Tick in trivial arg:" <+> ppr arg)
+ warnPprTrace bad_args "Dangerous-looking argument. Probable cause: bad unsafeCoerce#" (ppr arg) (return ())
+
+ return (arg' : stg_args, ticks' ++ ticks)
coreToStgTick :: Type -- type of the ticked expression
-> CoreTickish
=====================================
testsuite/tests/core-to-stg/T24718.hs
=====================================
@@ -0,0 +1,12 @@
+module T24718 where
+
+import GHC.Exts ( Any )
+import Unsafe.Coerce ( unsafeCoerce )
+
+data T = MkT (Any -> Any)
+
+g :: () -> ()
+g x = x
+
+f :: T
+f = unsafeCoerce MkT g
=====================================
testsuite/tests/core-to-stg/all.T
=====================================
@@ -2,3 +2,4 @@
test('T19700', normal, compile, ['-O'])
test('T23914', normal, compile, ['-O'])
+test('T24718', normal, compile, ['-O'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1c08e24581358f3ba067b6b2ea96eb2674b1ac23...78a253543d466ac511a1664a3e6aff032ca684d5
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1c08e24581358f3ba067b6b2ea96eb2674b1ac23...78a253543d466ac511a1664a3e6aff032ca684d5
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/20240625/514556bf/attachment-0001.html>
More information about the ghc-commits
mailing list