[Git][ghc/ghc][wip/T23209] Better specConstr
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Wed Nov 29 09:17:33 UTC 2023
Simon Peyton Jones pushed to branch wip/T23209 at Glasgow Haskell Compiler / GHC
Commits:
0eb105db by Simon Peyton Jones at 2023-11-29T09:16:47+00:00
Better specConstr
- - - - -
9 changed files:
- compiler/GHC/Core/Opt/Simplify/Env.hs
- compiler/GHC/Core/Opt/SpecConstr.hs
- compiler/GHC/Core/Rules.hs
- compiler/GHC/Core/Subst.hs
- compiler/GHC/Core/TyCo/Subst.hs
- compiler/GHC/Core/Type.hs
- compiler/GHC/Core/Unify.hs
- compiler/GHC/Tc/Utils/TcType.hs
- testsuite/tests/simplCore/should_compile/all.T
Changes:
=====================================
compiler/GHC/Core/Opt/Simplify/Env.hs
=====================================
@@ -1237,9 +1237,8 @@ See also Note [Return type for join points] and Note [Join points and case-of-ca
-}
getSubst :: SimplEnv -> Subst
-getSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env
- , seCvSubst = cv_env })
- = mkSubst in_scope tv_env cv_env emptyIdSubstEnv
+getSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seCvSubst = cv_env })
+ = mkTCvSubst in_scope tv_env cv_env
substTy :: HasDebugCallStack => SimplEnv -> Type -> Type
substTy env ty = Type.substTy (getSubst env) ty
=====================================
compiler/GHC/Core/Opt/SpecConstr.hs
=====================================
@@ -67,7 +67,6 @@ import GHC.Types.Unique.FM
import GHC.Types.Unique( hasKey )
import GHC.Data.Maybe ( orElse, catMaybes, isJust, isNothing )
-import GHC.Data.Pair
import GHC.Data.FastString
import GHC.Utils.Misc
@@ -81,8 +80,8 @@ import GHC.Builtin.Names ( specTyConKey )
import GHC.Exts( SpecConstrAnnotation(..) )
import GHC.Serialized ( deserializeWithData )
-import Control.Monad ( zipWithM )
-import Data.List (nubBy, sortBy, partition, dropWhileEnd, mapAccumL )
+import Control.Monad
+import Data.List ( sortBy, partition, dropWhileEnd, mapAccumL )
import Data.Maybe( mapMaybe )
import Data.Ord( comparing )
import Data.Tuple
@@ -2388,12 +2387,16 @@ callsToNewPats env fn spec_info@(SI { si_specs = done_specs }) bndr_occs calls
good_pats :: [CallPat]
good_pats = catMaybes mb_pats
+ in_scope = getSubstInScope (sc_subst env)
+
-- Remove patterns we have already done
new_pats = filterOut is_done good_pats
- is_done p = any (samePat p . os_pat) done_specs
+ is_done p = any is_better done_specs
+ where
+ is_better done = betterPat in_scope (os_pat done) p
-- Remove duplicates
- non_dups = nubBy samePat new_pats
+ non_dups = subsumePats in_scope new_pats
-- Remove ones that have too many worker variables
small_pats = filterOut too_many_worker_args non_dups
@@ -2410,6 +2413,10 @@ callsToNewPats env fn spec_info@(SI { si_specs = done_specs }) bndr_occs calls
(pats_were_discarded, trimmed_pats) = trim_pats env fn spec_info small_pats
-- ; pprTraceM "callsToPats" (vcat [ text "calls to" <+> ppr fn <> colon <+> ppr calls
+-- , text "good_pats:" <+> ppr good_pats
+-- , text "new_pats:" <+> ppr new_pats
+-- , text "non_dups:" <+> ppr non_dups
+-- , text "small_pats:" <+> ppr small_pats
-- , text "done_specs:" <+> ppr (map os_pat done_specs)
-- , text "trimmed_pats:" <+> ppr trimmed_pats ])
@@ -2513,35 +2520,37 @@ callToPats env bndr_occs call@(Call fn args con_env)
-- See Note [Free type variables of the qvar types]
-- See Note [Shadowing] at the top
- (ktvs, ids) = partition isTyVar qvars
- qvars' = scopedSort ktvs ++ map sanitise ids
+ (qktvs, qids) = partition isTyVar qvars
+ qvars' = scopedSort qktvs ++ map sanitise qids
-- Order into kind variables, type variables, term variables
-- The kind of a type variable may mention a kind variable
-- and the type of a term variable may mention a type variable
- sanitise id = updateIdTypeAndMult expandTypeSynonyms id
+ sanitise id = updateIdTypeAndMult expandTypeSynonyms id
-- See Note [Free type variables of the qvar types]
-
-- Check for bad coercion variables: see Note [SpecConstr and casts]
+{-
; let bad_covars :: CoVarSet
bad_covars = mapUnionVarSet get_bad_covars pats
get_bad_covars :: CoreArg -> CoVarSet
get_bad_covars (Type ty) = filterVarSet bad_covar (tyCoVarsOfType ty)
get_bad_covars _ = emptyVarSet
bad_covar v = isId v && not (is_in_scope v)
+-}
+ ; let bad_covars = filter isCoVar qids
- ; warnPprTrace (not (isEmptyVarSet bad_covars))
+ ; warnPprTrace (not (null bad_covars))
"SpecConstr: bad covars"
(ppr bad_covars $$ ppr call) $
- if interesting && isEmptyVarSet bad_covars
+ if interesting && null bad_covars
then do { let cp_res = CP { cp_qvars = qvars', cp_args = pats
, cp_strict_args = concat cbv_ids }
-- ; pprTraceM "callToPatsOut" $
-- vcat [ text "fn:" <+> ppr fn
-- , text "args:" <+> ppr args
--- , text "bndr_occs:" <+> ppr bndr_occs
+-- , text "bndr_occs:" <+> ppr bndr_occs
-- , text "pat_fvs:" <+> ppr pat_fvs
-- , text "cp_res:" <+> ppr cp_res ]
; return (Just cp_res) }
@@ -2574,9 +2583,9 @@ argToPat :: ScEnv
argToPat env in_scope val_env arg arg_occ arg_str
= do
- -- pprTraceM "argToPatIn" (ppr arg)
+-- pprTraceM "argToPatIn" (ppr arg)
!res <- argToPat1 env in_scope val_env arg arg_occ arg_str
- -- pprTraceM "argToPatOut" (ppr res)
+-- pprTraceM "argToPatOut" (ppr res)
return res
argToPat1 :: ScEnv
@@ -2614,6 +2623,13 @@ argToPat env in_scope val_env (Case scrut _ _ [(_, _, rhs)]) arg_occ
argToPat1 env in_scope val_env (Cast arg co) arg_occ arg_str
| not (ignoreType env ty2)
+ = do { (interesting, arg', strict_args) <- argToPat env in_scope val_env arg arg_occ arg_str
+ ; if not interesting then
+ wildCardPat ty2 arg_str
+ else
+ return (interesting, Cast arg' co, strict_args) }
+
+{-
= do { (interesting, arg', strict_args) <- argToPat env in_scope val_env arg arg_occ arg_str
; if not interesting then
wildCardPat ty2 arg_str
@@ -2623,8 +2639,9 @@ argToPat1 env in_scope val_env (Cast arg co) arg_occ arg_str
; let co_name = mkSysTvName uniq (fsLit "sg")
co_var = mkCoVar co_name (mkCoercionType Representational ty1 ty2)
; return (interesting, Cast arg' (mkCoVarCo co_var), strict_args) } }
+-}
where
- Pair ty1 ty2 = coercionKind co
+ ty2 = coercionRKind co
@@ -2790,10 +2807,30 @@ valueIsWorkFree :: Value -> Bool
valueIsWorkFree LambdaVal = True
valueIsWorkFree (ConVal _ args) = all exprIsWorkFree args
-samePat :: CallPat -> CallPat -> Bool
-samePat (CP { cp_qvars = vs1, cp_args = as1 })
- (CP { cp_qvars = vs2, cp_args = as2 })
- = all2 same as1 as2
+betterPat :: InScopeSet -> CallPat -> CallPat -> Bool
+-- pat1 f @a (Just @a (x::a))
+-- is better than
+-- pat2 f @Int (Just @Int (x::Int))
+-- That is, we can instantiate
+betterPat is (CP { cp_qvars = vs1, cp_args = as1 })
+ (CP { cp_qvars = vs2, cp_args = as2 })
+ = case matchExprs ise vs1 as1 as2 of
+ Just (_, ms) -> all exprIsTrivial ms
+ Nothing -> False
+ where
+ ise = ISE (is `extendInScopeSetList` vs2) (const noUnfolding)
+
+subsumePats :: InScopeSet -> [CallPat] -> [CallPat]
+-- Remove any patterns subsumed by others
+subsumePats is pats = foldr add [] pats
+ where
+ add :: CallPat -> [CallPat] -> [CallPat]
+ add ci [] = [ci]
+ add ci1 (ci2:cis) | betterPat is ci2 ci1 = ci2:cis
+ | betterPat is ci1 ci2 = ci1:cis
+ | otherwise = ci2 : add ci1 cis
+
+{-
where
-- If the args are the same, their strictness marks will be too so we don't compare those.
same (Var v1) (Var v2)
@@ -2817,6 +2854,8 @@ samePat (CP { cp_qvars = vs1, cp_args = as1 })
bad (Let {}) = True
bad (Lam {}) = True
bad _other = False
+-}
+
{-
Note [Ignore type differences]
=====================================
compiler/GHC/Core/Rules.hs
=====================================
@@ -9,7 +9,7 @@
-- The 'CoreRule' datatype itself is declared elsewhere.
module GHC.Core.Rules (
-- ** Looking up rules
- lookupRule,
+ lookupRule, matchExprs,
-- ** RuleBase, RuleEnv
RuleBase, RuleEnv(..), mkRuleEnv, emptyRuleEnv,
@@ -86,6 +86,7 @@ import GHC.Data.Maybe
import GHC.Data.Bag
import GHC.Data.List.SetOps( hasNoDups )
+import GHC.Utils.FV( filterFV, fvVarSet )
import GHC.Utils.Misc as Utils
import GHC.Utils.Outputable
import GHC.Utils.Panic
@@ -720,15 +721,23 @@ matchN :: InScopeEnv
-- trailing ones, returning the result of applying the rule to a prefix
-- of the actual arguments.
-matchN (ISE in_scope id_unf) rule_name tmpl_vars tmpl_es target_es rhs
+matchN ise _rule_name tmpl_vars tmpl_es target_es rhs
+ = do { (bind_wrapper, matched_es) <- matchExprs ise tmpl_vars tmpl_es target_es
+ ; return (bind_wrapper $
+ mkLams tmpl_vars rhs `mkApps` matched_es) }
+
+matchExprs :: InScopeEnv -> [Var] -> [CoreExpr] -> [CoreExpr]
+ -> Maybe (BindWrapper, [CoreExpr]) -- 1-1 with the [Var]
+matchExprs (ISE in_scope id_unf) tmpl_vars tmpl_es target_es
= do { rule_subst <- match_exprs init_menv emptyRuleSubst tmpl_es target_es
; let (_, matched_es) = mapAccumL (lookup_tmpl rule_subst)
(mkEmptySubst in_scope) $
tmpl_vars `zip` tmpl_vars1
- bind_wrapper = rs_binds rule_subst
+
+ ; let bind_wrapper = rs_binds rule_subst
-- Floated bindings; see Note [Matching lets]
- ; return (bind_wrapper $
- mkLams tmpl_vars rhs `mkApps` matched_es) }
+
+ ; return (bind_wrapper, matched_es) }
where
(init_rn_env, tmpl_vars1) = mapAccumL rnBndrL (mkRnEnv2 in_scope) tmpl_vars
-- See Note [Cloning the template binders]
@@ -739,7 +748,7 @@ matchN (ISE in_scope id_unf) rule_name tmpl_vars tmpl_es target_es rhs
, rv_unf = id_unf }
lookup_tmpl :: RuleSubst -> Subst -> (InVar,OutVar) -> (Subst, CoreExpr)
- -- Need to return a RuleSubst solely for the benefit of mk_fake_ty
+ -- Need to return a RuleSubst solely for the benefit of fake_ty
lookup_tmpl (RS { rs_tv_subst = tv_subst, rs_id_subst = id_subst })
tcv_subst (tmpl_var, tmpl_var1)
| isId tmpl_var1
@@ -768,7 +777,6 @@ matchN (ISE in_scope id_unf) rule_name tmpl_vars tmpl_es target_es rhs
unbound tmpl_var
= pprPanic "Template variable unbound in rewrite rule" $
vcat [ text "Variable:" <+> ppr tmpl_var <+> dcolon <+> ppr (varType tmpl_var)
- , text "Rule" <+> pprRuleName rule_name
, text "Rule bndrs:" <+> ppr tmpl_vars
, text "LHS args:" <+> ppr tmpl_es
, text "Actual args:" <+> ppr target_es ]
@@ -1060,7 +1068,15 @@ match renv subst e1 (Cast e2 co2) mco
-- This is important: see Note [Cancel reflexive casts]
match renv subst (Cast e1 co1) e2 mco
- = -- See Note [Casts in the template]
+ | isEmptyVarSet $ fvVarSet $
+ filterFV (`elemVarSet` rv_tmpls renv) $
+ tyCoFVsOfCo substed_co
+ = -- This is the good path
+ -- See Note [Casts in the template]
+ match renv subst e1 e2 (checkReflexiveMCo (mkTransMCoL mco (mkSymCo substed_co)))
+
+ | otherwise
+ = -- This is the Deeply Suspicious Path
do { let co2 = case mco of
MRefl -> mkRepReflCo (exprType e2)
MCo co2 -> co2
@@ -1068,6 +1084,17 @@ match renv subst (Cast e1 co1) e2 mco
-- If match_co succeeds, then (exprType e1) = (exprType e2)
-- Hence the MRefl in the next line
; match renv subst1 e1 e2 MRefl }
+ where
+ substed_co = substCo current_subst co1
+
+ current_subst :: Subst
+ current_subst = mkTCvSubst (rnInScopeSet (rv_lcl renv))
+ (rs_tv_subst subst)
+ emptyCvSubstEnv
+ -- emptyCvSubstEnv: ugh!
+ -- If there were any CoVar substitutions they would be in
+ -- rs_id_subst; but we don't expect there to be any; see
+ -- Note [Casts in the template]
------------------------ Literals ---------------------
match _ subst (Lit lit1) (Lit lit2) mco
@@ -1290,7 +1317,7 @@ match renv subst (Lam x1 e1) e2 mco
in_scope_env = ISE in_scope (rv_unf renv)
-- extendInScopeSetSet: The InScopeSet of rn_env is not necessarily
-- a superset of the free vars of e2; it is only guaranteed a superset of
- -- applyng the (rnEnvR rn_env) substitution to e2. But exprIsLambda_maybe
+ -- applying the (rnEnvR rn_env) substitution to e2. But exprIsLambda_maybe
-- wants an in-scope set that includes all the free vars of its argument.
-- Hence adding adding (exprFreeVars casted_e2) to the in-scope set (#23630)
, Just (x2, e2', ts) <- exprIsLambda_maybe in_scope_env casted_e2
=====================================
compiler/GHC/Core/Subst.hs
=====================================
@@ -19,7 +19,7 @@ module GHC.Core.Subst (
substTickish, substDVarSet, substIdInfo,
-- ** Operations on substitutions
- emptySubst, mkEmptySubst, mkSubst, mkOpenSubst, isEmptySubst,
+ emptySubst, mkEmptySubst, mkTCvSubst, mkOpenSubst, isEmptySubst,
extendIdSubst, extendIdSubstList, extendTCvSubst, extendTvSubstList,
extendIdSubstWithClone,
extendSubst, extendSubstList, extendSubstWithVar,
=====================================
compiler/GHC/Core/TyCo/Subst.hs
=====================================
@@ -14,7 +14,7 @@ module GHC.Core.TyCo.Subst
Subst(..), TvSubstEnv, CvSubstEnv, IdSubstEnv,
emptyIdSubstEnv, emptyTvSubstEnv, emptyCvSubstEnv, composeTCvSubst,
emptySubst, mkEmptySubst, isEmptyTCvSubst, isEmptySubst,
- mkSubst, mkTvSubst, mkCvSubst, mkIdSubst,
+ mkTCvSubst, mkTvSubst, mkCvSubst, mkIdSubst,
getTvSubstEnv, getIdSubstEnv,
getCvSubstEnv, getSubstInScope, setInScope, getSubstRangeTyCoFVs,
isInScope, elemSubst, notElemSubst, zapSubst,
@@ -271,8 +271,8 @@ isEmptyTCvSubst :: Subst -> Bool
isEmptyTCvSubst (Subst _ _ tv_env cv_env)
= isEmptyVarEnv tv_env && isEmptyVarEnv cv_env
-mkSubst :: InScopeSet -> TvSubstEnv -> CvSubstEnv -> IdSubstEnv -> Subst
-mkSubst in_scope tvs cvs ids = Subst in_scope ids tvs cvs
+mkTCvSubst :: InScopeSet -> TvSubstEnv -> CvSubstEnv -> Subst
+mkTCvSubst in_scope tvs cvs = Subst in_scope emptyIdSubstEnv tvs cvs
mkIdSubst :: InScopeSet -> IdSubstEnv -> Subst
mkIdSubst in_scope ids = Subst in_scope ids emptyTvSubstEnv emptyCvSubstEnv
=====================================
compiler/GHC/Core/Type.hs
=====================================
@@ -198,7 +198,7 @@ module GHC.Core.Type (
-- ** Manipulating type substitutions
emptyTvSubstEnv, emptySubst, mkEmptySubst,
- mkSubst, zipTvSubst, mkTvSubstPrs,
+ mkTCvSubst, zipTvSubst, mkTvSubstPrs,
zipTCvSubst,
notElemSubst,
getTvSubstEnv,
=====================================
compiler/GHC/Core/Unify.hs
=====================================
@@ -1481,7 +1481,7 @@ getSubst :: UMEnv -> UM Subst
getSubst env = do { tv_env <- getTvSubstEnv
; cv_env <- getCvSubstEnv
; let in_scope = rnInScopeSet (um_rn_env env)
- ; return (mkSubst in_scope tv_env cv_env emptyIdSubstEnv) }
+ ; return (mkTCvSubst in_scope tv_env cv_env) }
extendTvEnv :: TyVar -> Type -> UM ()
extendTvEnv tv ty = UM $ \state ->
=====================================
compiler/GHC/Tc/Utils/TcType.hs
=====================================
@@ -166,7 +166,7 @@ module GHC.Tc.Utils.TcType (
extendSubstInScopeList, extendSubstInScopeSet, extendTvSubstAndInScope,
Type.lookupTyVar, Type.extendTCvSubst, Type.substTyVarBndr,
Type.extendTvSubst,
- isInScope, mkSubst, mkTvSubst, zipTyEnv, zipCoEnv,
+ isInScope, mkTCvSubst, mkTvSubst, zipTyEnv, zipCoEnv,
Type.substTy, substTys, substScaledTys, substTyWith, substTyWithCoVars,
substTyAddInScope,
substTyUnchecked, substTysUnchecked, substScaledTyUnchecked,
=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -508,4 +508,6 @@ test('T24014', normal, compile, ['-dcore-lint'])
test('T24029', normal, compile, [''])
test('T21348', normal, compile, ['-O'])
test('T21917', normal, compile, ['-O -fkeep-auto-rules -ddump-rules'])
-
+test('T23209', [extra_files(['T23209_Aux.hs'])], multimod_compile, ['T23209', '-v0 -O'])
+test('T23209a', [ grep_errmsg(r'wfoo') ], compile, ['-O2 -ddump-simpl -dno-typeable-binds -dsuppress-all -dsuppress-uniques -dppr-cols=99999'])
+test('T23209b', [ grep_errmsg(r'wfoo') ], compile, ['-O2 -ddump-simpl -dno-typeable-binds -dsuppress-all -dsuppress-uniques -dppr-cols=99999'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0eb105dbcbef9b9840f8f04aa0e02b945445c98b
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0eb105dbcbef9b9840f8f04aa0e02b945445c98b
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/20231129/81d301c5/attachment-0001.html>
More information about the ghc-commits
mailing list