[Git][ghc/ghc][wip/T24359] Further improvements
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Fri Nov 29 17:43:28 UTC 2024
Simon Peyton Jones pushed to branch wip/T24359 at Glasgow Haskell Compiler / GHC
Commits:
91d508f1 by Simon Peyton Jones at 2024-11-29T17:38:55+00:00
Further improvements
...mainly documentation
- - - - -
6 changed files:
- compiler/GHC/Core/Opt/Simplify/Iteration.hs
- compiler/GHC/HsToCore.hs
- compiler/GHC/HsToCore/Binds.hs
- compiler/GHC/Tc/Gen/Sig.hs
- compiler/GHC/Tc/Zonk/Type.hs
- testsuite/tests/simplCore/should_fail/T25117b.stderr
Changes:
=====================================
compiler/GHC/Core/Opt/Simplify/Iteration.hs
=====================================
@@ -1159,15 +1159,15 @@ simplExprF :: SimplEnv
-> SimplM (SimplFloats, OutExpr)
simplExprF !env e !cont -- See Note [Bangs in the Simplifier]
- = {- pprTrace "simplExprF" (vcat
- [ ppr e
- , text "cont =" <+> ppr cont
- , text "inscope =" <+> ppr (seInScope env)
- , text "tvsubst =" <+> ppr (seTvSubst env)
- , text "idsubst =" <+> ppr (seIdSubst env)
- , text "cvsubst =" <+> ppr (seCvSubst env)
- ]) $ -}
- simplExprF1 env e cont
+-- = pprTrace "simplExprF" (vcat
+-- [ ppr e
+-- , text "cont =" <+> ppr cont
+-- , text "inscope =" <+> ppr (seInScope env)
+-- , text "tvsubst =" <+> ppr (seTvSubst env)
+-- , text "idsubst =" <+> ppr (seIdSubst env)
+-- , text "cvsubst =" <+> ppr (seCvSubst env)
+-- ]) $
+ = simplExprF1 env e cont
simplExprF1 :: HasDebugCallStack
=> SimplEnv -> InExpr -> SimplCont
@@ -2514,7 +2514,7 @@ field of the ArgInfo record is the state of a little state-machine:
If we inline `f` before simplifying `BIG` well use preInlineUnconditionally,
and we'll simplify BIG once, at x's occurrence, rather than twice.
-* GHC.Core.Opt.Simplify.Utils. mkRewriteCall: if there are no rules, and no
+* GHC.Core.Opt.Simplify.Utils.mkRewriteCall: if there are no rules, and no
unfolding, we can skip both TryRules and TryInlining, which saves work.
Note [Avoid redundant simplification]
=====================================
compiler/GHC/HsToCore.hs
=====================================
@@ -54,7 +54,7 @@ import GHC.Core.SimpleOpt ( simpleOptPgm, simpleOptExpr )
import GHC.Core.Utils
import GHC.Core.Unfold.Make
import GHC.Core.Coercion
-import GHC.Core.Predicate( mkNomEqPred )
+import GHC.Core.Predicate( scopedSort, mkNomEqPred )
import GHC.Core.DataCon ( dataConWrapId )
import GHC.Core.Make
import GHC.Core.Rules
@@ -461,7 +461,10 @@ dsRule (L loc (HsRule { rd_name = name
, rd_lhs = lhs
, rd_rhs = rhs }))
= putSrcSpanDs (locA loc) $
- do { let bndrs' = [var | L _ (RuleBndr _ (L _ var)) <- vars]
+ do { let bndrs' = scopedSort [var | L _ (RuleBndr _ (L _ var)) <- vars]
+ -- The scopedSort is because the binders may not
+ -- be in dependency order; see wrinkle (FTV1) in
+ -- Note [Free tyvars on rule LHS] in GHC.Tc.Zonk.Type
; lhs' <- unsetGOptM Opt_EnableRewriteRules $
unsetWOptM Opt_WarnIdentities $
=====================================
compiler/GHC/HsToCore/Binds.hs
=====================================
@@ -884,16 +884,16 @@ dsSpec poly_rhs (SpecPragE { spe_poly_id = poly_id
Nothing -> do { diagnosticDs (DsRuleLhsTooComplicated ds_call core_call)
; return Nothing } ;
- Just (bndr_set, rhs_const_binds, lhs_args) ->
+ Just (bndr_set, spec_const_binds, lhs_args) ->
- do { let const_bndrs = mkVarSet (bindersOfBinds rhs_const_binds)
+ do { let const_bndrs = mkVarSet (bindersOfBinds spec_const_binds)
all_bndrs = bndr_set `unionVarSet` const_bndrs
-- all_bndrs: all binders in core_call that should be quantified
rule_bndrs = scopedSort (exprsSomeFreeVarsList (`elemVarSet` all_bndrs) lhs_args)
- spec_bndrs = filterOut (`elemVarSet` const_bndrs) rule_bndrs
+ spec_bndrs = filterOut (`elemVarSet` const_bndrs) rule_bndrs
- mk_spec_body fn_body = mkLets rhs_const_binds $
+ mk_spec_body fn_body = mkLets spec_const_binds $
mkCoreApps fn_body lhs_args
; tracePm "dsSpec" (vcat [ text "poly_id" <+> ppr poly_id
@@ -901,7 +901,7 @@ dsSpec poly_rhs (SpecPragE { spe_poly_id = poly_id
, text "ds_call" <+> ppr ds_call
, text "core_call" <+> ppr core_call
, text "core_call fvs" <+> ppr (exprFreeVars core_call)
- , text "rhs_const_binds" <+> ppr rhs_const_binds ])
+ , text "spec_const_binds" <+> ppr spec_const_binds ])
; finishSpecPrag poly_rhs
rule_bndrs poly_id lhs_args
@@ -922,7 +922,7 @@ prepareSpecLHS poly_id evs the_call
go qevs acc (Let bind e)
| not (all isDictId bndrs) -- A normal 'let' is too complicated
= Nothing
- | all (isEmptyVarSet . exprSomeFreeVars (is_quant_id qevs)) $
+ | all (transfer_to_spec_rhs qevs) $
rhssOfBind bind
= go qevs (bind:acc) e
| otherwise
@@ -937,7 +937,11 @@ prepareSpecLHS poly_id evs the_call
| otherwise
= Nothing
- is_quant_id qevs v = isId v && v `elemVarSet` qevs
+ transfer_to_spec_rhs qevs rhs
+ = exprIsTrivial rhs
+ || isEmptyVarSet (exprSomeFreeVars is_quant_id rhs)
+ where
+ is_quant_id v = isId v && v `elemVarSet` qevs
-- See Note [Desugaring SPECIALISE pragmas] wrinkle (DS1)
finishSpecPrag :: CoreExpr -- RHS to specialise
=====================================
compiler/GHC/Tc/Gen/Sig.hs
=====================================
@@ -700,11 +700,10 @@ Note [Handling new-form SPECIALISE pragmas]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
New-form SPECIALISE pragmas are described by GHC Proposal #493.
-The thing in the SpecPragE is very, very like the LHS of a RULE
+The pragma takes the form of a function application, possibly with intervening
+parens and type signatures, with a variable at the head. It may have rule
+for-alls at the top. e.g.
-In particular, the pragma takes the form of a function application,
-possibly with intervening parens and type signatures, with a variable
-at the head. It may have rule for-alls at the top. e.g.
{-# SPECIALISE f1 @Int 3 #-}
{-# SPECIALISE forall x xs. f2 (x:xs) #-}
{-# SPECIALISE f3 :: Int -> Int #-}
@@ -714,41 +713,65 @@ See `GHC.Rename.Bind.checkSpecESigShape` for the shape-check.
Example:
- f :: forall a b. (Eq a, Eq b, Ord c) => a -> b -> c -> Bool -> blah
+ f :: forall a b. (Eq a, Eq b, Eq c) => a -> b -> c -> Bool -> blah
{-# SPECIALISE forall x y. f (x::Int) y y True #-}
-- y::p
We want to generate:
- RULE forall @p (d1::Eq Int) (d2::Eq p) (d3::Ord p) (x::Int) (y::p).
+ RULE forall @p (d1::Eq Int) (d2::Eq p) (d3::Eq p) (x::Int) (y::p).
f @Int @p @p d1 d2 d3 x y y True
- = $sf @p d1 d2 d3 x y
- $sf @p (d1a::Eq Int) (d2a::Eq p) (d3a::Ord p) (x::Int) (y::p)
+ = $sf @p d2 x y
+ $sf @p (d2::Eq p) (x::Int) (y::p)
= let d1 = $fEqInt
- d2 = d2a
- d3 = d3a
- in let f = <f-rhs>
- in f @p @p @Int (d1::Eq p) (d2::Eq p) (d3::Ord Int) x y y True
-
-In terms of the code:
- spe_tv_bndrs = @p
- spe_id_bndrs = x:Int y y:p
- spe_lhs_ev_bndrs = (e1:Eq p) (d2:Eq p) (d3:Ord Int)
- spe_lhs_call = f @p @p @Int (d1::Eq p) (d2::Eq p) (d3::Ord Int) x y y True
- -- We can't meddle with this; it's a perhaps-big expression
- spe_rhs_ev_bndrs = @d1a @d2a @d3a
- spe_rhs_binds = { d1=$fEqInt; d2=d2a; d3=d3a }
+ d3 = d2
+ in <f-rhs> @p @p @Int (d1::Eq p) (d2::Eq p) (d3::Eq p) x y y True
Note that
-* In the RULE we have separate binders for `d1` and `d2` even though they are
+* The `rule_bndrs`, over which the RULE is quantified, are all the varaibles
+ free in the call to `f`, /ignoring/ all dictionary simplification. Why?
+ Because we want to make the rule maximimally applicable; provided the types
+ match, the dicionaries should match.
+
+ rule_bndrs = @p (d1::Eq Int) (d2::Eq p) (d3::Eq p) (x::Int) (y::p).
+
+ Note that we have separate binders for `d1` and `d2` even though they are
the same (Eq p) dictionary. Reason: we don't want to force them to be visibly
equal at the call site.
-* The specialised function $sf takes all three dictionaries as arguments; but
- the constraint solver does not use d1 (short-cut solved). We rely on the
- Simplifier to drop the dead arguments. It isn't strictly necessary to pass d2
- either, but it does no harm.
+* The `spec_bnrs`, which are lambda-bound in the specialised function `$sf`,
+ are a subset of `rul_bndrs`.
+
+ spec_bndrs = @p (d2::Eq p) (x::Int) (y::p)
+
+* The `spec_const_binds` make up the difference between `rule_bndrs` and
+ `spec_bndrs`. They communicate the specialisation!
+ If `spec_bndrs` = `rule_bndrs`, no specialisation has happended.
+
+ spec_const_binds = let d1 = $fEqInt
+ d3 = d2
+
+How it works:
+
+* `GHC.Tc.Gen.Sig.tcSpecPrag` just typechecks the expresion, putting the results
+ into a `SpecPragE` record. Nothing very exciting happens here.
+
+* `GHC.Tc.Zonk.Type.zonkLTcSpecPrags` does a little extra work to collect any
+ free type variables of the LHS. See Note [Free tyvars on rule LHS] in
+ GHC.Tc.Zonk.Type. These weren't conveniently available earlier.
+
+* `GHC.HsToCore.Binds.dsSpec` does the clever stuff:
+
+ * Simplifies the expression. This is important becuase a type signature in the
+ expression will have led to type/dictionary abstractions/applications. Now
+ it should look like
+ let <dict-binds> in f e1 e1 e3
+
+ * `prepareSpecLHS` identifies the `spec_const_binds` (see above), discards
+ the other ditionary bindigns, and decomposes the call.
+
+ * Then it can build the RULE and specialised function.
Note [Handling old-form SPECIALISE pragmas]
=====================================
compiler/GHC/Tc/Zonk/Type.hs
=====================================
@@ -1745,9 +1745,17 @@ over it. Here is how:
- make a fresh ref-cell to collect the skolemised type variables,
- zonk the binders and LHS with ze_flexi = SkolemiseFlexi ref
- read the ref-cell to get all the skolemised TyVars
- - add them to the bineders
+ - add them to the binders
All this applies for SPECIALISE pragmas too.
+
+Wrinkles:
+
+(FTV1) We just add the new tyvars to the front of the binder-list, but
+ that make make the list not be in dependency order. Example (T12925):
+ the existing list is [k:Type, b:k], and we add (a:k) to the front.
+ Also we just collect the new skolemised type variables in any old order,
+ so they may not be ordered with respect to each other.
-}
{-
=====================================
testsuite/tests/simplCore/should_fail/T25117b.stderr
=====================================
@@ -1,2 +1,2 @@
-T25117b.hs:6:1: error: [GHC-62037]
+T25117b.hs:7:1: error: [GHC-62037]
SPECIALIZE expression doesn't support multiple specialize type ascriptions
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/91d508f118177cf1fde3d73416dfb5b82d5d100b
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/91d508f118177cf1fde3d73416dfb5b82d5d100b
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/20241129/f02c21ab/attachment-0001.html>
More information about the ghc-commits
mailing list