[Git][ghc/ghc][wip/T23109] Run classop rule first
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Mon Jun 19 23:11:21 UTC 2023
Simon Peyton Jones pushed to branch wip/T23109 at Glasgow Haskell Compiler / GHC
Commits:
9e8b53e3 by Simon Peyton Jones at 2023-06-20T00:10:55+01:00
Run classop rule first
- - - - -
10 changed files:
- compiler/GHC/Core/Opt/Simplify/Env.hs
- compiler/GHC/Core/Opt/Simplify/Iteration.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
- compiler/GHC/Core/Utils.hs
- compiler/GHC/Tc/Gen/Splice.hs
- compiler/GHC/Tc/TyCl/Instance.hs
- compiler/GHC/Types/Id.hs
- compiler/GHC/Types/Id/Info.hs
- compiler/GHC/Types/Id/Make.hs
- compiler/GHC/Types/TyThing.hs
Changes:
=====================================
compiler/GHC/Core/Opt/Simplify/Env.hs
=====================================
@@ -12,13 +12,13 @@ module GHC.Core.Opt.Simplify.Env (
smPedanticBottoms, smPlatform,
-- * Environments
- SimplEnv(..), pprSimplEnv, -- Temp not abstract
+ SimplEnv(..), StaticEnv, pprSimplEnv, -- Temp not abstract
seArityOpts, seCaseCase, seCaseFolding, seCaseMerge, seCastSwizzle,
seDoEtaReduction, seEtaExpand, seFloatEnable, seInline, seNames,
seOptCoercionOpts, sePedanticBottoms, sePhase, sePlatform, sePreInline,
seRuleOpts, seRules, seUnfoldingOpts,
mkSimplEnv, extendIdSubst,
- extendTvSubst, extendCvSubst,
+ extendTvSubst, extendCvSubst, extendSubstForDFun,
zapSubstEnv, setSubstEnv, bumpCaseDepth,
getInScope, setInScopeFromE, setInScopeFromF,
setInScopeSet, modifyInScope, addNewInScopeIds,
@@ -153,6 +153,8 @@ following table:
-}
+type StaticEnv = SimplEnv -- Just the static part is relevant
+
data SimplEnv
= SimplEnv {
----------- Static part of the environment -----------
@@ -379,7 +381,6 @@ data SimplSR
-- and ja = Just a <=> x is a join-point of arity a
-- See Note [Join arity in SimplIdSubst]
-
| DoneId OutId
-- If x :-> DoneId v is in the SimplIdSubst
-- then replace occurrences of x by v
@@ -547,6 +548,20 @@ extendCvSubst env@(SimplEnv {seCvSubst = csubst}) var co
= assert (isCoVar var) $
env {seCvSubst = extendVarEnv csubst var co}
+extendSubstForDFun :: SimplEnv -> [OutVar] -> [(InExpr,StaticEnv)] -> SimplEnv
+extendSubstForDFun env bndrs args
+ = foldl2 extend env bndrs args
+ where
+ extend env@(SimplEnv {seIdSubst = ids, seCvSubst = cvs, seTvSubst = tvs})
+ bndr (arg,arg_se)
+ | isTyVar bndr, Type ty <- arg
+ = env { seTvSubst = extendVarEnv tvs bndr (substTy arg_se ty) }
+ | isCoVar bndr, Coercion co <- arg
+ = env { seCvSubst = extendVarEnv cvs bndr (substCo arg_se co) }
+ | otherwise
+ = assertPpr (isId bndr) (ppr bndr) $
+ env { seIdSubst = extendVarEnv ids bndr (mkContEx arg_se arg) }
+
---------------------
getInScope :: SimplEnv -> InScopeSet
getInScope env = seInScope env
=====================================
compiler/GHC/Core/Opt/Simplify/Iteration.hs
=====================================
@@ -18,6 +18,7 @@ import GHC.Platform
import GHC.Driver.Flags
import GHC.Core
+import GHC.Core.Class( Class, classArity )
import GHC.Core.Opt.Simplify.Monad
import GHC.Core.Opt.ConstantFold
import GHC.Core.Type hiding ( substTy, substTyVar, extendTvSubst, extendCvSubst )
@@ -66,6 +67,7 @@ import GHC.Builtin.Names( runRWKey )
import GHC.Data.Maybe ( isNothing, orElse )
import GHC.Data.FastString
+import GHC.Data.List.SetOps( getNth )
import GHC.Unit.Module ( moduleName )
import GHC.Utils.Outputable
import GHC.Utils.Panic
@@ -2133,25 +2135,65 @@ simplIdF env var cont
where
env' = setSubstEnv env tvs cvs ids
- DoneId var1 ->
- do { rule_base <- getSimplRules
- ; let cont' = trimJoinCont var1 (isJoinId_maybe var1) cont
- info = mkArgInfo env rule_base var1 cont'
- ; rebuildCall env info cont' }
+ DoneId var1 -> simplCall env var1 cont'
+ where
+ cont' = trimJoinCont var1 (isJoinId_maybe var1) cont
DoneEx e mb_join -> simplExprF env' e cont'
where
cont' = trimJoinCont var mb_join cont
env' = zapSubstEnv env -- See Note [zapSubstEnv]
+simplCall :: SimplEnv -> OutId -> SimplCont -> SimplM (SimplFloats, OutExpr)
+simplCall env var cont
+ | ClassOpId clas idx _ <- idDetails var
+ , Just (env', arg', cont') <- classOpDictApp_maybe env clas idx cont
+ = simplExprF env' arg' cont'
+
+ | otherwise
+ = do { rule_base <- getSimplRules
+ ; let info = mkArgInfo env rule_base var cont
+ ; rebuildCall env info cont }
+
+classOpDictApp_maybe :: SimplEnv -> Class -> Int -> SimplCont
+ -> Maybe (SimplEnv, InExpr, SimplCont)
+classOpDictApp_maybe env cls idx cont
+ = go cont
+ where
+ go (ApplyToTy { sc_cont = cont })
+ = go cont -- Discard leading type args
+ go (ApplyToVal { sc_arg = dict_arg, sc_env = dict_se, sc_cont = cont })
+ | Just (dfun, dfun_args) <- splitInApp dict_se dict_arg [] -- dfun_args :: [InExpr]
+ , DFunUnfolding { df_bndrs = bndrs, df_args = dict_args } <- idUnfolding dfun
+ , bndrs `equalLength` dfun_args -- See Note [DFun arity check]
+ , let arg_env = extendSubstForDFun (zapSubstEnv env) bndrs dfun_args
+ the_arg = getNth (drop (classArity cls) dict_args) idx -- An OutExpr
+ = Just (arg_env, the_arg, cont)
+ go _ = Nothing
+
+ splitInApp :: StaticEnv -> InExpr -> [(InExpr,StaticEnv)]
+ -> Maybe (OutVar, [(InExpr,StaticEnv)])
+ splitInApp env (App fun arg) args
+ = splitInApp env fun ((arg,env):args)
+ splitInApp env (Var v) args
+ = case substId env v of
+ DoneId v' -> Just (v', args)
+ ContEx tvs cvs ids e -> splitInApp (setSubstEnv env tvs cvs ids) e args
+ DoneEx e _ -> splitInApp (zapSubstEnv env) e args
+ splitInApp _ _ _
+ = Nothing
+
---------------------------------------------------------
-- Dealing with a call site
-rebuildCall :: SimplEnv -> ArgInfo -> SimplCont
+rebuildCall, rebuildCall' :: SimplEnv -> ArgInfo -> SimplCont
-> SimplM (SimplFloats, OutExpr)
---------- Bottoming applications --------------
-rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_dmds = [] }) cont
+rebuildCall env ai cont
+ = rebuildCall' env ai cont
+
+rebuildCall' env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_dmds = [] }) cont
-- When we run out of strictness args, it means
-- that the call is definitely bottom; see GHC.Core.Opt.Simplify.Utils.mkArgInfo
-- Then we want to discard the entire strict continuation. E.g.
@@ -2178,7 +2220,7 @@ rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_dmds = [] }) con
-- If there are rewrite rules we'll skip this case until we have
-- simplified enough args to satisfy nr_wanted==0 in the TryRules case below
-- Then we'll try the rules, and if that fails, we'll do TryInlining
-rebuildCall env info@(ArgInfo { ai_fun = fun, ai_args = rev_args
+rebuildCall' env info@(ArgInfo { ai_fun = fun, ai_args = rev_args
, ai_rewrite = TryInlining }) cont
= do { logger <- getLogger
; let full_cont = pushSimplifiedRevArgs env rev_args cont
@@ -2193,7 +2235,7 @@ rebuildCall env info@(ArgInfo { ai_fun = fun, ai_args = rev_args
---------- Try rewrite RULES, if ai_rewrite = TryRules --------------
-- See Note [Rewrite rules and inlining]
-- See also Note [Trying rewrite rules]
-rebuildCall env info@(ArgInfo { ai_fun = fun, ai_args = rev_args
+rebuildCall' env info@(ArgInfo { ai_fun = fun, ai_args = rev_args
, ai_rewrite = TryRules nr_wanted rules }) cont
| nr_wanted == 0 || no_more_args
= -- We've accumulated a simplified call in <fun,rev_args>
@@ -2213,10 +2255,10 @@ rebuildCall env info@(ArgInfo { ai_fun = fun, ai_args = rev_args
_ -> True
---------- Simplify type applications and casts --------------
-rebuildCall env info (CastIt co cont)
+rebuildCall' env info (CastIt co cont)
= rebuildCall env (addCastTo info co) cont
-rebuildCall env info (ApplyToTy { sc_arg_ty = arg_ty, sc_hole_ty = hole_ty, sc_cont = cont })
+rebuildCall' env info (ApplyToTy { sc_arg_ty = arg_ty, sc_hole_ty = hole_ty, sc_cont = cont })
= rebuildCall env (addTyArgTo info arg_ty hole_ty) cont
---------- The runRW# rule. Do this after absorbing all arguments ------
@@ -2224,7 +2266,7 @@ rebuildCall env info (ApplyToTy { sc_arg_ty = arg_ty, sc_hole_ty = hole_ty, sc_c
--
-- runRW# :: forall (r :: RuntimeRep) (o :: TYPE r). (State# RealWorld -> o) -> o
-- K[ runRW# rr ty body ] --> runRW rr' ty' (\s. K[ body s ])
-rebuildCall env (ArgInfo { ai_fun = fun_id, ai_args = rev_args })
+rebuildCall' env (ArgInfo { ai_fun = fun_id, ai_args = rev_args })
(ApplyToVal { sc_arg = arg, sc_env = arg_se
, sc_cont = cont, sc_hole_ty = fun_ty })
| fun_id `hasKey` runRWKey
@@ -2258,7 +2300,7 @@ rebuildCall env (ArgInfo { ai_fun = fun_id, ai_args = rev_args })
; return (emptyFloats env, call') }
---------- Simplify value arguments --------------------
-rebuildCall env fun_info
+rebuildCall' env fun_info
(ApplyToVal { sc_arg = arg, sc_env = arg_se
, sc_dup = dup_flag, sc_hole_ty = fun_ty
, sc_cont = cont })
@@ -2290,7 +2332,7 @@ rebuildCall env fun_info
---------- No further useful info, revert to generic rebuild ------------
-rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args }) cont
+rebuildCall' env (ArgInfo { ai_fun = fun, ai_args = rev_args }) cont
= rebuild env (argInfoExpr fun rev_args) cont
-----------------------------------
@@ -2378,7 +2420,7 @@ The simplifier arranges to do this, as follows. In effect, the ai_rewrite
field of the ArgInfo record is the state of a little state-machine:
* mkArgInfo sets the ai_rewrite field to TryRules if there are any rewrite
- rules avaialable for that function.
+ rules available for that function.
* rebuildCall simplifies arguments until enough are simplified to match the
rule with greatest arity. See Note [RULES apply to simplified arguments]
=====================================
compiler/GHC/Core/Opt/Simplify/Utils.hs
=====================================
@@ -212,8 +212,6 @@ data SimplCont
CoreTickish -- Tick tickish <hole>
SimplCont
-type StaticEnv = SimplEnv -- Just the static part is relevant
-
data FromWhat = FromLet | FromBeta OutType
-- See Note [DupFlag invariants]
@@ -732,7 +730,6 @@ which it is on the LHS of a rule (see updModeForRules), then don't
make use of the strictness info for the function.
-}
-
{-
************************************************************************
* *
=====================================
compiler/GHC/Core/Utils.hs
=====================================
@@ -1606,7 +1606,7 @@ app_ok fun_ok primop_ok fun args
-- been expressed by its "wrapper", so we don't need
-- to take the arguments into account
- ClassOpId _ is_terminating_result
+ ClassOpId _ _ is_terminating_result
| is_terminating_result -- See Note [exprOkForSpeculation and type classes]
-> assertPpr (n_val_args == 1) (ppr fun $$ ppr args) $
True
=====================================
compiler/GHC/Tc/Gen/Splice.hs
=====================================
@@ -2064,8 +2064,8 @@ reifyThing (AGlobal (AnId id))
= do { ty <- reifyType (idType id)
; let v = reifyName id
; case idDetails id of
- ClassOpId cls _ -> return (TH.ClassOpI v ty (reifyName cls))
- _ -> return (TH.VarI v ty Nothing)
+ ClassOpId cls _ _ -> return (TH.ClassOpI v ty (reifyName cls))
+ _ -> return (TH.VarI v ty Nothing)
}
reifyThing (AGlobal (ATyCon tc)) = reifyTyCon tc
=====================================
compiler/GHC/Tc/TyCl/Instance.hs
=====================================
@@ -1363,10 +1363,10 @@ addDFunPrags :: DFunId -> [Id] -> DFunId
-- the DFunId rather than from the skolem pieces that the typechecker
-- is messing with.
addDFunPrags dfun_id sc_meth_ids
--- | is_newtype
+-- xx | is_newtype
-- = dfun_id `setIdUnfolding` mkInlineUnfoldingWithArity defaultSimpleOpts StableSystemSrc 0 con_app
-- `setInlinePragma` alwaysInlinePragma { inl_sat = Just 0 }
--- | otherwise
+-- xx | otherwise
= dfun_id `setIdUnfolding` mkDFunUnfolding dfun_bndrs dict_con dict_args
`setInlinePragma` dfunInlinePragma
where
=====================================
compiler/GHC/Types/Id.hs
=====================================
@@ -495,8 +495,8 @@ isClassOpId id = case Var.idDetails id of
_other -> False
isClassOpId_maybe id = case Var.idDetails id of
- ClassOpId cls _ -> Just cls
- _other -> Nothing
+ ClassOpId cls _ _ -> Just cls
+ _other -> Nothing
isPrimOpId id = case Var.idDetails id of
PrimOpId {} -> True
=====================================
compiler/GHC/Types/Id/Info.hs
=====================================
@@ -158,6 +158,7 @@ data IdDetails
| ClassOpId -- ^ The 'Id' is a superclass selector or class operation
Class -- for this class
+ Int -- 0-indexed selector for which class method this is
Bool -- True <=> given a non-bottom dictionary, the class op will
-- definitely return a non-bottom result
-- and Note [exprOkForSpeculation and type classes]
=====================================
compiler/GHC/Types/Id/Make.hs
=====================================
@@ -470,7 +470,7 @@ mkDictSelId :: Name -- Name of one of the *value* selectors
-- (dictionary superclass or method)
-> Class -> Id
mkDictSelId name clas
- = mkGlobalId (ClassOpId clas terminating) name sel_ty info
+ = mkGlobalId (ClassOpId clas val_index terminating) name sel_ty info
where
tycon = classTyCon clas
sel_names = map idName (classAllSelIds clas)
=====================================
compiler/GHC/Types/TyThing.hs
=====================================
@@ -260,7 +260,7 @@ tyThingParent_maybe (AnId id) = case idDetails id of
Just (ATyCon tc)
RecSelId { sel_tycon = RecSelPatSyn ps } ->
Just (AConLike (PatSynCon ps))
- ClassOpId cls _ ->
+ ClassOpId cls _ _ ->
Just (ATyCon (classTyCon cls))
_other -> Nothing
tyThingParent_maybe _other = Nothing
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9e8b53e312d5570a7e74a2d7ec297816e74415d7
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9e8b53e312d5570a7e74a2d7ec297816e74415d7
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/20230619/081989cd/attachment-0001.html>
More information about the ghc-commits
mailing list