[Git][ghc/ghc][wip/T24359] 2 commits: Don't warn about useless SPECIALISE pragmas if they are INLINE
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Tue Dec 3 00:44:46 UTC 2024
Simon Peyton Jones pushed to branch wip/T24359 at Glasgow Haskell Compiler / GHC
Commits:
0b695406 by Simon Peyton Jones at 2024-12-02T22:42:39+00:00
Don't warn about useless SPECIALISE pragmas if they are INLINE
- - - - -
79cddff8 by Simon Peyton Jones at 2024-12-02T23:27:10+00:00
More tidying up
Fixes a badness that led to a loop; test in T24359a
Acked-by: Simon Peyton Jones <simon.peytonjones at gmail.com>
- - - - -
6 changed files:
- compiler/GHC/HsToCore/Binds.hs
- compiler/GHC/HsToCore/Errors/Types.hs
- compiler/GHC/Tc/Gen/Sig.hs
- + testsuite/tests/simplCore/should_compile/T24359a.hs
- + testsuite/tests/simplCore/should_compile/T24359a.stderr
- testsuite/tests/simplCore/should_compile/all.T
Changes:
=====================================
compiler/GHC/HsToCore/Binds.hs
=====================================
@@ -812,6 +812,18 @@ We want to get
in <f-rhs> @[a] @[Int] d2 d3 x 3
Notice that
+* If the expression had a type signature, such as
+ SPECIALISE f :: Eq b => Int -> b -> b
+ then the desugared expression may have type abstractions and applications
+ "in the way", like this:
+ (/\b. (\d:Eq b). let d1 = $dfOrdInt in f @Int @b d1 d) @b (d2:Eq b)
+ We use the simple optimiser to simplify this to
+ let { d = d2; d1 = $dfOrdInt } in f @Int @b (d2:Eq b)
+ Do no inlining in this "simple optimiser" phase: use `simpleOptExprNoInline`.
+ E.g. we don't want to turn
+ let { d1=d; d2=d } in f d d --> f d d
+ because the latter is harder to match.
+
* We want to quantify the RULE over the free vars of the /call/ inside all
those dictionary bindings.
@@ -924,6 +936,8 @@ dsSpec poly_rhs (SpecPragE { spe_fn_nm = poly_nm
; tracePm "dsSpec" (vcat [ text "poly_id" <+> ppr poly_id
, text "bndrs" <+> ppr bndrs
+ , text "all_bndrs" <+> ppr all_bndrs
+ , text "const_bndrs" <+> ppr const_bndrs
, text "ds_call" <+> ppr ds_call
, text "core_call" <+> ppr core_call
, text "core_call fvs" <+> ppr (exprFreeVars core_call)
@@ -948,9 +962,11 @@ prepareSpecLHS poly_id evs the_call
go qevs acc (Let bind e)
| not (all isDictId bndrs) -- A normal 'let' is too complicated
= Nothing
+
| all (transfer_to_spec_rhs qevs) $
- rhssOfBind bind
+ rhssOfBind bind -- One of the `const_binds`
= go qevs (bind:acc) e
+
| otherwise
= go (qevs `extendVarSetList` bndrs) acc e
where
@@ -964,8 +980,7 @@ prepareSpecLHS poly_id evs the_call
= Nothing
transfer_to_spec_rhs qevs rhs
- = exprIsTrivial rhs
- || isEmptyVarSet (exprSomeFreeVars is_quant_id rhs)
+ = isEmptyVarSet (exprSomeFreeVars is_quant_id rhs)
where
is_quant_id v = isId v && v `elemVarSet` qevs
-- See Note [Desugaring SPECIALISE pragmas] wrinkle (DS1)
@@ -976,72 +991,78 @@ finishSpecPrag :: Name -> CoreExpr -- RHS to specialise
-> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule))
finishSpecPrag poly_nm poly_rhs rule_bndrs poly_id rule_args
spec_bndrs mk_spec_body spec_inl
- = do { want_spec <-
- case mb_useless of
- Just useless ->
- do { diagnosticDs $ DsUselessSpecialisePragma poly_nm useless
- ; return $ uselessSpecialisePragmaKeepAnyway useless }
- Nothing -> return True
- ; if not want_spec
- then return Nothing
- else Just <$>
+ | Just reason <- mb_useless
+ = do { diagnosticDs $ DsUselessSpecialisePragma poly_nm reason
+ ; if uselessSpecialisePragmaKeepAnyway reason
+ then Just <$> finish_prag
+ else return Nothing }
+
+ | otherwise
+ = Just <$> finish_prag
+
+ where
-- The RULE looks like
-- RULE "USPEC" forall rule_bndrs. f rule_args = $sf spec_bndrs
-- The specialised function looks like
-- $sf spec_bndrs = mk_spec_body <f's original rhs>
-- We also use mk_spec_body to specialise the methods in f's stable unfolding
-- NB: spec_bindrs is a subset of rule_bndrs
- do { this_mod <- getModule
- ; uniq <- newUnique
- ; dflags <- getDynFlags
- ; let poly_name = idName poly_id
- spec_occ = mkSpecOcc (getOccName poly_name)
- spec_name = mkInternalName uniq spec_occ (getSrcSpan poly_name)
-
- simpl_opts = initSimpleOpts dflags
- fn_unf = realIdUnfolding poly_id
- spec_unf = specUnfolding simpl_opts spec_bndrs mk_spec_body rule_args fn_unf
- spec_id = mkLocalId spec_name ManyTy spec_ty
- -- Specialised binding is toplevel, hence Many.
- `setInlinePragma` specFunInlinePrag poly_id id_inl spec_inl
- `setIdUnfolding` spec_unf
-
- rule = mkSpecRule dflags this_mod False rule_act (text "USPEC")
- poly_id rule_bndrs rule_args
- (mkVarApps (Var spec_id) spec_bndrs)
-
- rule_ty = exprType (mkApps (Var poly_id) rule_args)
- spec_ty = mkLamTypes spec_bndrs rule_ty
- spec_rhs = mkLams spec_bndrs (mk_spec_body poly_rhs)
-
- ; dsWarnOrphanRule rule
-
- ; tracePm "dsSpec" (vcat
- [ text "fun:" <+> ppr poly_id
- , text "spec_bndrs:" <+> ppr spec_bndrs
- , text "args:" <+> ppr rule_args ])
- ; return (unitOL (spec_id, spec_rhs), rule)
- -- NB: do *not* use makeCorePair on (spec_id,spec_rhs), because
- -- makeCorePair overwrites the unfolding, which we have
- -- just created using specUnfolding
- } }
- where
+ finish_prag
+ = do { this_mod <- getModule
+ ; uniq <- newUnique
+ ; dflags <- getDynFlags
+ ; let poly_name = idName poly_id
+ spec_occ = mkSpecOcc (getOccName poly_name)
+ spec_name = mkInternalName uniq spec_occ (getSrcSpan poly_name)
+
+ simpl_opts = initSimpleOpts dflags
+ fn_unf = realIdUnfolding poly_id
+ spec_unf = specUnfolding simpl_opts spec_bndrs mk_spec_body rule_args fn_unf
+ spec_id = mkLocalId spec_name ManyTy spec_ty
+ -- Specialised binding is toplevel, hence Many.
+ `setInlinePragma` specFunInlinePrag poly_id id_inl spec_inl
+ `setIdUnfolding` spec_unf
+
+ rule = mkSpecRule dflags this_mod False rule_act (text "USPEC")
+ poly_id rule_bndrs rule_args
+ (mkVarApps (Var spec_id) spec_bndrs)
+
+ rule_ty = exprType (mkApps (Var poly_id) rule_args)
+ spec_ty = mkLamTypes spec_bndrs rule_ty
+ spec_rhs = mkLams spec_bndrs (mk_spec_body poly_rhs)
+
+ ; dsWarnOrphanRule rule
+
+ ; tracePm "dsSpec" (vcat
+ [ text "fun:" <+> ppr poly_id
+ , text "spec_bndrs:" <+> ppr spec_bndrs
+ , text "args:" <+> ppr rule_args ])
+ ; return (unitOL (spec_id, spec_rhs), rule) }
+ -- NB: do *not* use makeCorePair on (spec_id,spec_rhs), because
+ -- makeCorePair overwrites the unfolding, which we have
+ -- just created using specUnfolding
+
-- Is this SPECIALISE pragma useless?
- mb_useless =
- if | isJust (isClassOpId_maybe poly_id)
- -- There is no point in trying to specialise a class op
- -- Moreover, classops don't (currently) have an inl_sat arity set
- -- (it would be Just 0) and that in turn makes makeCorePair bleat
- -> Just UselessSpecialiseForClassMethodSelector
- | no_act_spec && isNeverActive rule_act
- -- Function is NOINLINE, and the specialisation inherits that
- -- See Note [Activation pragmas for SPECIALISE]
- -> Just UselessSpecialiseForNoInlineFunction
- | all is_nop_arg rule_args
- -- The specialisation does nothing.
- -> Just UselessSpecialiseNoSpecialisation
- | otherwise
- -> Nothing
+ mb_useless :: Maybe UselessSpecialisePragmaReason
+ mb_useless
+ | isJust (isClassOpId_maybe poly_id)
+ -- There is no point in trying to specialise a class op
+ -- Moreover, classops don't (currently) have an inl_sat arity set
+ -- (it would be Just 0) and that in turn makes makeCorePair bleat
+ = Just UselessSpecialiseForClassMethodSelector
+
+ | no_act_spec, isNeverActive rule_act
+ -- Function is NOINLINE, and the specialisation inherits that
+ -- See Note [Activation pragmas for SPECIALISE]
+ = Just UselessSpecialiseForNoInlineFunction
+
+ | all is_nop_arg rule_args, not (isInlinePragma spec_inl)
+ -- The specialisation does nothing.
+ -- But don't compliain if it is SPECIALISE INLINE (#4444)
+ = Just UselessSpecialiseNoSpecialisation
+
+ | otherwise
+ = Nothing
-- See Note [Activation pragmas for SPECIALISE]
-- no_act_spec is True if the user didn't write an explicit
=====================================
compiler/GHC/HsToCore/Errors/Types.hs
=====================================
@@ -218,12 +218,11 @@ data UselessSpecialisePragmaReason
uselessSpecialisePragmaKeepAnyway :: UselessSpecialisePragmaReason -> Bool
uselessSpecialisePragmaKeepAnyway = \case
UselessSpecialiseForClassMethodSelector -> False
- UselessSpecialiseForNoInlineFunction -> False
- UselessSpecialiseNoSpecialisation -> True
+ UselessSpecialiseForNoInlineFunction -> False
+ UselessSpecialiseNoSpecialisation -> True
-- See #25389/T25389 for why we might want to keep this specialisation
-- around even if it seemingly does nothing.
-
data NegLiteralExtEnabled
= YesUsingNegLiterals
| NotUsingNegLiterals
=====================================
compiler/GHC/Tc/Gen/Sig.hs
=====================================
@@ -959,7 +959,9 @@ tcSpecPrag poly_id (SpecSigE nm bndrs spec_e inl)
solveWanteds wanted
-- Quantifiy over the the constraints
- ; qevs <- mk_quant_evs (approximateWC False wanted)
+ ; qevs <- mapM newEvVar $
+ ctsPreds $
+ approximateWC False wanted
; emitResidualConstraints rhs_tclvl skol_info_anon ev_binds_var
emptyVarSet tv_bndrs qevs
@@ -1460,55 +1462,41 @@ simplifyRule name tc_lvl lhs_wanted rhs_wanted
; lhs_wanted <- liftZonkM $ zonkWC lhs_wanted
-- Note [The SimplifyRule Plan] step 3
- ; let (quant_cts, residual_lhs_wanted) = getRuleQuantCts lhs_wanted
- ; quant_evs <- mk_quant_evs quant_cts
+ ; (quant_evs, residual_lhs_wanted) <-getRuleQuantCts lhs_wanted
; traceTc "simplifyRule" $
vcat [ text "LHS of rule" <+> doubleQuotes (ftext name)
, text "lhs_wanted" <+> ppr lhs_wanted
, text "rhs_wanted" <+> ppr rhs_wanted
- , text "quant_cts" <+> ppr quant_cts
+ , text "quant_cts" <+> ppr quant_evs
, text "residual_lhs_wanted" <+> ppr residual_lhs_wanted
, text "dont_default" <+> ppr dont_default
]
; return (quant_evs, residual_lhs_wanted, dont_default) }
-mk_quant_evs :: Cts -> TcM [EvVar]
-mk_quant_evs cts
- = mapM mk_one (bagToList cts)
- where
- mk_one ct
- | CtWanted { ctev_dest = dest, ctev_pred = pred } <- ctEvidence ct
- = case dest of
- EvVarDest ev_id -> return ev_id
- HoleDest hole -> -- See Note [Quantifying over coercion holes]
- do { ev_id <- newEvVar pred
- ; fillCoercionHole hole (mkCoVarCo ev_id)
- ; return ev_id }
- mk_one ct = pprPanic "mk_quant_ev" (ppr ct)
-
-getRuleQuantCts :: WantedConstraints -> (Cts, WantedConstraints)
+getRuleQuantCts :: WantedConstraints -> TcM ([EvVar], WantedConstraints)
-- Extract all the constraints that we can quantify over,
-- also returning the depleted WantedConstraints
--
+-- Unlike simplifyInfer, we don't leave the WantedConstraints unchanged,
+-- and attempt to solve them from the quantified constraints. Instead
+-- we /partition/ the WantedConstraints into ones to quantify and ones
+-- we can't quantify. We could use approximateWC instead, and leave
+-- `wanted` unchanged; but then we'd have clone fresh binders and
+-- generate silly identity bindings. Seems more direct to do this.
+-- Probably not a big eal wither way.
+--
-- NB: we must look inside implications, because with
-- -fdefer-type-errors we generate implications rather eagerly;
-- see GHC.Tc.Utils.Unify.implicationNeeded. Not doing so caused #14732.
---
--- Unlike simplifyInfer, we don't leave the WantedConstraints unchanged,
--- and attempt to solve them from the quantified constraints. That
--- nearly works, but fails for a constraint like (d :: Eq Int).
--- We /do/ want to quantify over it, but the short-cut solver
--- (see GHC.Tc.Solver.Dict Note [Shortcut solving]) ignores the quantified
--- and instead solves from the top level.
---
--- So we must partition the WantedConstraints ourselves
--- Not hard, but tiresome.
getRuleQuantCts wc
- = float_wc emptyVarSet wc
+ = do { quant_evs <- mapM mk_one (bagToList quant_cts)
+ ; return (quant_evs, residual_wc) }
where
+ (quant_cts, residual_wc) = float_wc emptyVarSet wc
+
float_wc :: TcTyCoVarSet -> WantedConstraints -> (Cts, WantedConstraints)
float_wc skol_tvs (WC { wc_simple = simples, wc_impl = implics, wc_errors = errs })
= ( simple_yes `andCts` implic_yes
@@ -1534,6 +1522,16 @@ getRuleQuantCts wc
-> False -- Note [RULE quantification over equalities]
_ -> tyCoVarsOfCt ct `disjointVarSet` skol_tvs
+ mk_one :: Ct -> TcM EvVar
+ mk_one ct
+ | CtWanted { ctev_dest = dest, ctev_pred = pred } <- ctEvidence ct
+ = case dest of
+ EvVarDest ev_id -> return ev_id
+ HoleDest hole -> -- See Note [Quantifying over coercion holes]
+ do { ev_id <- newEvVar pred
+ ; fillCoercionHole hole (mkCoVarCo ev_id)
+ ; return ev_id }
+ mk_one ct = pprPanic "mk_quant_ev" (ppr ct)
-- ok_eq t1 t2
-- | t1 `tcEqType` t2 = False -- Our solving step may have turned it into Refl
-- | otherwise = True
=====================================
testsuite/tests/simplCore/should_compile/T24359a.hs
=====================================
@@ -0,0 +1,18 @@
+{-# LANGUAGE TypeApplications, ExplicitForAll #-}
+
+module T24359a where
+
+data UA i = UA !i
+
+class IArray a where
+ bounds :: a i -> i
+
+showsIArray :: (IArray a, Show i) => a i -> String
+showsIArray a = show (bounds a)
+
+{-# SPECIALISE
+ showsIArray :: (Show i) => UA i -> String
+ #-}
+
+instance IArray UA where
+ bounds (UA u) = u
=====================================
testsuite/tests/simplCore/should_compile/T24359a.stderr
=====================================
@@ -0,0 +1,7 @@
+
+==================== Tidy Core rules ====================
+"USPEC showsIArray @UA @_"
+ forall (@i) ($dShow :: Show i) ($dIArray :: IArray UA).
+ showsIArray @UA @i $dIArray $dShow
+ = showsIArray_$sshowsIArray @i $dShow
+
=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -533,3 +533,4 @@ test('T25033', normal, compile, ['-O'])
test('T25160', normal, compile, ['-O -ddump-rules'])
test('T25197', [req_th, extra_files(["T25197_TH.hs"]), only_ways(['optasm'])], multimod_compile, ['T25197', '-O2 -v0'])
test('T25389', normal, compile, ['-O -ddump-simpl -dsuppress-uniques -dno-typeable-binds'])
+test('T24359a', normal, compile, ['-O -ddump-rules'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/146af81ed027cf4cea42bf7f8a52972c9ea971f6...79cddff8aa8ac1f602a5a402786fb97260e98551
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/146af81ed027cf4cea42bf7f8a52972c9ea971f6...79cddff8aa8ac1f602a5a402786fb97260e98551
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/20241202/d95f6b9b/attachment-0001.html>
More information about the ghc-commits
mailing list