[Git][ghc/ghc][wip/T24359] 2 commits: Respond to review
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Wed Dec 18 16:26:27 UTC 2024
Simon Peyton Jones pushed to branch wip/T24359 at Glasgow Haskell Compiler / GHC
Commits:
b9d4aab9 by Simon Peyton Jones at 2024-12-18T09:21:43+00:00
Respond to review
- - - - -
9e47b2bd by Simon Peyton Jones at 2024-12-18T16:25:06+00:00
Refactor RuleBndrs
...probably needs a bit more documentation
- - - - -
11 changed files:
- compiler/GHC/Hs/Binds.hs
- compiler/GHC/HsToCore.hs
- compiler/GHC/HsToCore/Binds.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/Rename/Bind.hs
- compiler/GHC/Tc/Gen/Bind.hs
- compiler/GHC/Tc/Gen/Sig.hs
- compiler/GHC/Tc/TyCl/Instance.hs
- compiler/GHC/Tc/Zonk/Type.hs
- compiler/Language/Haskell/Syntax/Binds.hs
- compiler/Language/Haskell/Syntax/Extension.hs
Changes:
=====================================
compiler/GHC/Hs/Binds.hs
=====================================
@@ -830,10 +830,10 @@ data TcSpecPrags
-- be macro-expanded at every call site
| SpecPrags [LTcSpecPrag]
--- | Located Type checker Specification Pragmas
+-- | Located Type checker Specialisation Pragmas
type LTcSpecPrag = Located TcSpecPrag
--- | Type checker Specification Pragma
+-- | Type checker Specialisation Pragma
-- This data type is used briefly, to communicate between the typechecker and renamer
data TcSpecPrag
= SpecPrag Id HsWrapper InlinePragma
@@ -1024,10 +1024,15 @@ instance NoAnn HsRuleBndrsAnn where
noAnn = HsRuleBndrsAnn Nothing Nothing
-type instance XCRuleBndr (GhcPass _) = AnnTyVarBndr
-type instance XCRuleBndrs (GhcPass _) = HsRuleBndrsAnn
+
type instance XXRuleBndrs (GhcPass _) = DataConCantHappen
+type instance XCRuleBndrs GhcPs = HsRuleBndrsAnn
+type instance XCRuleBndrs GhcRn = NoExtField
+type instance XCRuleBndrs GhcTc = [Var] -- Binders of the rule, not
+ -- necessarily in dependency order
+
type instance XRuleBndrSig (GhcPass _) = AnnTyVarBndr
+type instance XCRuleBndr (GhcPass _) = AnnTyVarBndr
type instance XXRuleBndr (GhcPass _) = DataConCantHappen
instance (OutputableBndrId p) => Outputable (RuleBndrs (GhcPass p)) where
=====================================
compiler/GHC/HsToCore.hs
=====================================
@@ -436,11 +436,11 @@ Reason
dsRule :: LRuleDecl GhcTc -> DsM (Maybe CoreRule)
dsRule (L loc (HsRule { rd_name = name
, rd_act = rule_act
- , rd_bndrs = RuleBndrs { rb_tmvs = vars }
+ , rd_bndrs = RuleBndrs { rb_ext = bndrs }
, rd_lhs = lhs
, rd_rhs = rhs }))
= putSrcSpanDs (locA loc) $
- do { let bndrs' = scopedSort [var | L _ (RuleBndr _ (L _ var)) <- vars]
+ do { let bndrs' = scopedSort bndrs
-- 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
=====================================
compiler/GHC/HsToCore/Binds.hs
=====================================
@@ -793,24 +793,24 @@ Note [Desugaring SPECIALISE pragmas]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Suppose we have f :: forall a b. (Ord a, Eq b) => a -> b -> b, and a pragma
- {-# SPECIALISE forall x. f @[a] @[Int] x 3 #-}
+ {-# SPECIALISE forall x. f @[a] @[Int] x [3,4] #-}
The SPECIALISE pragma has an expression that desugars to something like
forall @a (d:Ord a) (x:[a]).
let d2:Ord [a] = $dfOrdList d
d3:Eq [Int] = $dfEqList $dfEqInt
- in f @[a] @[Int] d2 d3 x 3
+ in f @[a] @[Int] d2 d3 x [3,4]
We want to get
RULE forall a (d2:Ord a) (d3:Eq [Int]) (x:[a]).
- f @[a] @[Int] d2 d3 x 3 = $sf d2 x
+ f @[a] @[Int] d2 d3 x [3,4] = $sf d2 x
$sf :: forall a. Ord [a] => a -> Int
- $sf = /\a. d2 x.
+ $sf = /\a. \d2 x.
let d3 = $dfEqList $dfEqInt
- in <f-rhs> @[a] @[Int] d2 d3 x 3
+ in <f-rhs> @[a] @[Int] d2 d3 x [3,4]
Notice that
* If the expression had a type signature, such as
@@ -835,17 +835,17 @@ Notice that
function body. That is crucial -- it makes those specialised methods available in the
specialised body. This are the `const_dict_binds`.
-* Where the dicionary binding depends on locally-quanitified dictionries, we just discard
+* Where the dicionary binding depends on locally-quantified dictionries, we just discard
the binding, and pass the dictionary to the specialised function directly. No type-class
specialisation arises thereby.
Some wrinkles:
-(DS1) The `const-dict_binds` /can/ depend on locally-quantifed type vaiables.
+(DS1) The `const_dict_binds` /can/ depend on locally-quantifed type vaiables.
For example, if we have
instance Monad (ST s) where ...
- the the dictionary for (Monad (ST s)) is effectlvely a constant dictionary. This
- is important to get specialisation for such types. Emxample in test T8331.
+ the dictionary for (Monad (ST s)) is effectively a constant dictionary. This
+ is important to get specialisation for such types. Example in test T8331.
-}
=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -919,8 +919,8 @@ Note [Desugaring non-canonical evidence]
When constructing an application
f @ty1 ty2 .. dict1 dict2 .. arg1 arg2 ..
if the evidence `dict_i` is canonical, we simply build that application.
-But if any of the `dict_i` are /non-canonical/, we wrap the appication in `nospec`,
-thus
+But if any of the `dict_i` are /non-canonical/, we wrap the application
+in `nospec`, thus
nospec @fty f @ty1 @ty2 .. dict1 dict2 .. arg1 arg2 ..
where nospec :: forall a. a -> a ensures that the typeclass specialiser
doesn't attempt to common up this evidence term with other evidence terms
@@ -945,7 +945,7 @@ How do we decide if the arguments are non-canonical dictionaries?
Wrinkle:
-(NC1) We don't do this in the LHS of a RULE. In paritcular, if we have
+(NC1) We don't do this in the LHS of a RULE. In particular, if we have
f :: (Num a, HasCallStack) => a -> a
{-# SPECIALISE f :: Int -> Int #-}
then making a rule like
@@ -958,7 +958,7 @@ Wrinkle:
nospec (f @Int d1) d2
This is done by zapping the unspecables in `dsRule` to Nothing. That `Nothing`
- says not to collet unspecables at all.
+ says not to collect unspecables at all.
Note [Desugaring explicit lists]
=====================================
compiler/GHC/Rename/Bind.hs
=====================================
@@ -1323,7 +1323,7 @@ bindRuleBndrs doc (RuleBndrs { rb_tyvs = tyvs, rb_tmvs = tmvs }) thing_inside
; names <- newLocalBndrsRn rdr_names_w_loc
; bindRuleTyVars doc tyvs $ \ tyvs' ->
bindRuleTmVars doc tyvs' tmvs names $ \ tmvs' ->
- thing_inside names (RuleBndrs { rb_ext = noAnn
+ thing_inside names (RuleBndrs { rb_ext = noExtField
, rb_tyvs = tyvs', rb_tmvs = tmvs' }) }
where
get_var :: RuleBndr GhcPs -> LocatedN RdrName
=====================================
compiler/GHC/Tc/Gen/Bind.hs
=====================================
@@ -918,7 +918,7 @@ mkExport prag_fn residual insoluble qtvs theta
; spec_prags <- tcExtendIdEnv1 poly_name poly_id $
tcSpecPrags poly_id prag_sigs
-- tcSpecPrags requires a zonked poly_id. It also needs poly_id to
- -- be in the type env (so we can typecheck the SPECIALISE expression
+ -- be in the type env (so we can typecheck the SPECIALISE expression)
-- See Note [Impedance matching]
-- NB: we have already done checkValidType, including an ambiguity check,
=====================================
compiler/GHC/Tc/Gen/Sig.hs
=====================================
@@ -689,10 +689,11 @@ There are two major routes:
- Deals with SPECIALISE pragmas have multiple signatures
{-# SPECIALISE f :: Int -> Int, Float -> Float #-}
- See Note [Handling old-form SPECIALISE pragmas]
+ - Deprecated, to be removed in GHC 9.18 as per #25540.
* New form, described in GHC Proposal #493
- Handled by `SpecSigE` and `SpecPragE`
- - Deals with SPECIALISE pramgas which may have value arguments
+ - Deals with SPECIALISE pragmas which may have value arguments
{-# SPECIALISE f @Int 3 #-}
- See Note [Handling new-form SPECIALISE pragmas]
@@ -708,6 +709,7 @@ for-alls at the top. e.g.
{-# SPECIALISE forall x xs. f2 (x:xs) #-}
{-# SPECIALISE f3 :: Int -> Int #-}
{-# SPECIALISE (f4 :: Int -> Int) 5 #-}
+ {-# SPECIALISE forall a. forall x xs. f5 @a @a (x:xs) #-}
See `GHC.Rename.Bind.checkSpecESigShape` for the shape-check.
@@ -729,7 +731,7 @@ We want to generate:
Note that
-* The `rule_bndrs`, over which the RULE is quantified, are all the varaibles
+* The `rule_bndrs`, over which the RULE is quantified, are all the variables
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.
@@ -741,20 +743,20 @@ Note that
equal at the call site.
* The `spec_bnrs`, which are lambda-bound in the specialised function `$sf`,
- are a subset of `rul_bndrs`.
+ are a subset of `rule_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.
+ If `spec_bndrs` = `rule_bndrs`, no specialisation has happened.
spec_const_binds = let d1 = $fEqInt
d3 = d2
How it works:
-* `GHC.Tc.Gen.Sig.tcSpecPrag` just typechecks the expresion, putting the results
+* `GHC.Tc.Gen.Sig.tcSpecPrag` just typechecks the expression, 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
@@ -763,19 +765,20 @@ How it works:
* `GHC.HsToCore.Binds.dsSpec` does the clever stuff:
- * Simplifies the expression. This is important becuase a type signature in the
+ * Simplifies the expression. This is important because 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.
+ the other dictionary bindings, and decomposes the call.
* Then it can build the RULE and specialised function.
Note [Handling old-form SPECIALISE pragmas]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+NB: this code path is deprecated, and is scheduled to be removed in GHC 9.18, as per #25440.
We check that
(forall a b. Num a => a -> b -> a)
is more polymorphic than
@@ -939,18 +942,17 @@ tcSpecPrag poly_id prag@(SpecSig _ fun_name hs_tys inl)
; wrap <- tcSpecWrapper (FunSigCtxt name (lhsSigTypeContextSpan hs_ty)) poly_ty spec_ty
; return (SpecPrag poly_id wrap inl) }
-tcSpecPrag poly_id (SpecSigE nm bndrs spec_e inl)
+tcSpecPrag poly_id (SpecSigE nm rule_bndrs spec_e inl)
= do { -- Typecheck the expression, spec_e, capturing its constraints
let skol_info_anon = SpecESkol nm
; traceTc "tcSpecPrag: specSigE1" (ppr nm $$ ppr spec_e)
; skol_info <- mkSkolemInfo skol_info_anon
- ; (rhs_tclvl, wanted, (tv_bndrs, id_bndrs, spec_e'))
+ ; (rhs_tclvl, wanted, (rule_bndrs', spec_e'))
<- pushLevelAndCaptureConstraints $
- do { (tv_bndrs, id_bndrs) <- tcRuleBndrs skol_info bndrs
- ; tcExtendNameTyVarEnv [(tyVarName tv, tv) | tv <- tv_bndrs] $
- tcExtendIdEnv id_bndrs $
- do { (L loc spec_e', _rho) <- tcInferRho spec_e
- ; return (tv_bndrs, id_bndrs, L loc spec_e') } }
+ tcRuleBndrs skol_info rule_bndrs $
+ do { (spec_e', _rho) <- tcInferRho spec_e
+ ; return spec_e' }
+ ; let tv_bndrs = filter isTyVar rule_bndrs'
-- Simplify the constraints
; ev_binds_var <- newTcEvBinds
@@ -958,7 +960,7 @@ tcSpecPrag poly_id (SpecSigE nm bndrs spec_e inl)
runTcSWithEvBinds ev_binds_var $
solveWanteds wanted
- -- Quantifiy over the the constraints
+ -- Quantify over the the constraints
; qevs <- mapM newEvVar $
ctsPreds $
approximateWC False wanted
@@ -969,8 +971,7 @@ tcSpecPrag poly_id (SpecSigE nm bndrs spec_e inl)
; traceTc "tcSpecPrag:SpecSigE" $
vcat [ text "nm:" <+> ppr nm
- , text "tv_bndrs:" <+> ppr tv_bndrs
- , text "id_bndrs:" <+> ppr id_bndrs
+ , text "rule_bndrs':" <+> ppr rule_bndrs'
, text "qevs:" <+> ppr qevs
, text "spec_e:" <+> ppr spec_e'
, text "inl:" <+> ppr inl ]
@@ -978,7 +979,8 @@ tcSpecPrag poly_id (SpecSigE nm bndrs spec_e inl)
; let lhs_call = mkLHsWrap (WpLet (TcEvBinds ev_binds_var)) spec_e'
; return [SpecPragE { spe_fn_nm = nm
, spe_fn_id = poly_id
- , spe_bndrs = tv_bndrs ++ qevs ++ id_bndrs
+ , spe_bndrs = qevs ++ rule_bndrs' -- Dependency order
+ -- does not matter
, spe_call = lhs_call
, spe_inl = inl }] }
@@ -1066,7 +1068,7 @@ That seems enough for now.
Note [Typechecking rules]
~~~~~~~~~~~~~~~~~~~~~~~~~
-We *infer* the typ of the LHS, and use that type to *check* the type of
+We *infer* the type of the LHS, and use that type to *check* the type of
the RHS. That means that higher-rank rules work reasonably well. Here's
an example (test simplCore/should_compile/rule2.hs) produced by Roman:
@@ -1149,8 +1151,7 @@ tcRule (HsRule { rd_ext = ext
; (tc_lvl, stuff) <- pushTcLevelM $
generateRuleConstraints skol_info bndrs lhs rhs
- ; let (id_bndrs, lhs', lhs_wanted
- , rhs', rhs_wanted, rule_ty) = stuff
+ ; let ((bndrs', (lhs', rule_ty, rhs', rhs_wanted)), lhs_wanted) = stuff
; traceTc "tcRule 1" (vcat [ pprFullRuleName (snd ext) rname
, ppr lhs_wanted
@@ -1172,7 +1173,7 @@ tcRule (HsRule { rd_ext = ext
-- the LHS, lest they otherwise get defaulted to Any; but we do that
-- during zonking (see GHC.Tc.Zonk.Type.zonkRule)
- ; let tpl_ids = lhs_evs ++ id_bndrs
+ ; let tpl_ids = lhs_evs ++ filter isId bndrs'
-- See Note [Re-quantify type variables in rules]
; dvs <- candidateQTyVarsOfTypes (rule_ty : map idType tpl_ids)
@@ -1206,80 +1207,70 @@ tcRule (HsRule { rd_ext = ext
; return $ Just $ HsRule { rd_ext = ext
, rd_name = rname
, rd_act = act
- , rd_bndrs = mkTcRuleBndrs bndrs (qtkvs ++ tpl_ids)
+ , rd_bndrs = bndrs { rb_ext = qtkvs ++ tpl_ids }
, rd_lhs = mkHsDictLet lhs_binds lhs'
, rd_rhs = mkHsDictLet rhs_binds rhs' } }
- where
- mkTcRuleBndrs (RuleBndrs { rb_tyvs = tyvs }) vars
- = RuleBndrs { rb_ext = noAnn
- , rb_tyvs = tyvs -- preserved for ppr-ing
- , rb_tmvs = map (noLocA . RuleBndr noAnn . noLocA) vars }
- mkTcRuleBndrs (XRuleBndrs {}) _ = panic "mkTCRuleBndrs"
generateRuleConstraints :: SkolemInfo
-> RuleBndrs GhcRn
-> LHsExpr GhcRn -> LHsExpr GhcRn
- -> TcM ( [TcId]
- , LHsExpr GhcTc, WantedConstraints
- , LHsExpr GhcTc, WantedConstraints
- , TcType )
+ -> TcM ( ( [Var]
+ , ( LHsExpr GhcTc, TcType
+ , LHsExpr GhcTc, WantedConstraints) )
+ , WantedConstraints )
generateRuleConstraints skol_info bndrs lhs rhs
- = do { ((tv_bndrs, id_bndrs), bndr_wanted) <- captureConstraints $
- tcRuleBndrs skol_info bndrs
- -- bndr_wanted constraints can include wildcard hole
- -- constraints, which we should not forget about.
- -- It may mention the skolem type variables bound by
- -- the RULE. c.f. #10072
- ; tcExtendNameTyVarEnv [(tyVarName tv, tv) | tv <- tv_bndrs] $
- tcExtendIdEnv id_bndrs $
- do { -- See Note [Solve order for RULES]
- ((lhs', rule_ty), lhs_wanted) <- captureConstraints (tcInferRho lhs)
- ; (rhs', rhs_wanted) <- captureConstraints $
- tcCheckMonoExpr rhs rule_ty
- ; let all_lhs_wanted = bndr_wanted `andWC` lhs_wanted
- ; return (id_bndrs, lhs', all_lhs_wanted, rhs', rhs_wanted, rule_ty) } }
+ = captureConstraints $
+ tcRuleBndrs skol_info bndrs $
+ do { (lhs', rule_ty) <- tcInferRho lhs
+ ; (rhs', rhs_wanted) <- captureConstraints $
+ tcCheckMonoExpr rhs rule_ty
+ ; return (lhs', rule_ty, rhs', rhs_wanted) }
+
+tcRuleBndrs :: SkolemInfo -> RuleBndrs GhcRn -> TcM a -> TcM ([Var], a)
+tcRuleBndrs skol_info (RuleBndrs { rb_tyvs = mb_tv_bndrs, rb_tmvs = tm_bndrs }) thing_inside
+ | Just tv_bndrs <- mb_tv_bndrs
+ = do { (bndrs1, (bndrs2, res)) <- go_tvs tv_bndrs $
+ go_tms tm_bndrs $
+ thing_inside
+ ; return (binderVars bndrs1 ++ bndrs2, res) }
+ | otherwise
+ = go_tms tm_bndrs thing_inside
+
+ where
+ --------------
+ go_tvs tvs thing_inside = bindExplicitTKBndrs_Skol skol_info tvs thing_inside
+
+ --------------
+ go_tms [] thing_inside
+ = do { res <- thing_inside; return ([], res) }
+ go_tms (L _ (RuleBndr _ (L _ name)) : rule_bndrs) thing_inside
+ = do { ty <- newOpenFlexiTyVarTy
+ ; let bndr_id = mkLocalId name ManyTy ty
+ ; (bndrs, res) <- tcExtendIdEnv [bndr_id] $
+ go_tms rule_bndrs thing_inside
+ ; return (bndr_id : bndrs, res) }
+
+ go_tms (L _ (RuleBndrSig _ (L _ name) rn_ty) : rule_bndrs) thing_inside
+ -- e.g x :: a->a
+ -- The tyvar 'a' is brought into scope first, just as if you'd written
+ -- a::*, x :: a->a
+ -- If there's an explicit forall, the renamer would have already reported an
+ -- error for each out-of-scope type variable used
+ = do { (_ , tv_prs, id_ty) <- tcRuleBndrSig name skol_info rn_ty
+ ; let bndr_id = mkLocalId name ManyTy id_ty
+ -- See Note [Typechecking pattern signature binders] in GHC.Tc.Gen.HsType
+
+ -- The type variables scope over subsequent bindings; yuk
+ ; (bndrs, res) <- tcExtendNameTyVarEnv tv_prs $
+ tcExtendIdEnv [bndr_id] $
+ go_tms rule_bndrs thing_inside
+ ; return (map snd tv_prs ++ bndr_id : bndrs, res) }
ruleCtxt :: FastString -> SDoc
ruleCtxt name = text "When checking the rewrite rule" <+>
doubleQuotes (ftext name)
-
--- See Note [TcLevel in type checking rules]
-tcRuleBndrs :: SkolemInfo -> RuleBndrs GhcRn
- -> TcM ([TcTyVar], [Id])
-tcRuleBndrs skol_info (RuleBndrs { rb_tyvs = mb_tv_bndrs, rb_tmvs = tmvs })
- | Just tv_bndrs <- mb_tv_bndrs
- = do { (tybndrs1,(tys2,tms)) <- bindExplicitTKBndrs_Skol skol_info tv_bndrs $
- tcRuleTmBndrs skol_info tmvs
- ; let tys1 = binderVars tybndrs1
- ; return (tys1 ++ tys2, tms) }
-
- | otherwise
- = tcRuleTmBndrs skol_info tmvs
-
--- See Note [TcLevel in type checking rules]
-tcRuleTmBndrs :: SkolemInfo -> [LRuleBndr GhcRn] -> TcM ([TcTyVar],[Id])
-tcRuleTmBndrs _ [] = return ([],[])
-tcRuleTmBndrs skol_info (L _ (RuleBndr _ (L _ name)) : rule_bndrs)
- = do { ty <- newOpenFlexiTyVarTy
- ; (tyvars, tmvars) <- tcRuleTmBndrs skol_info rule_bndrs
- ; return (tyvars, mkLocalId name ManyTy ty : tmvars) }
-tcRuleTmBndrs skol_info (L _ (RuleBndrSig _ (L _ name) rn_ty) : rule_bndrs)
--- e.g x :: a->a
--- The tyvar 'a' is brought into scope first, just as if you'd written
--- a::*, x :: a->a
--- If there's an explicit forall, the renamer would have already reported an
--- error for each out-of-scope type variable used
- = do { (_ , tvs, id_ty) <- tcRuleBndrSig name skol_info rn_ty
- ; let id = mkLocalId name ManyTy id_ty
- -- See Note [Typechecking pattern signature binders] in GHC.Tc.Gen.HsType
-
- -- The type variables scope over subsequent bindings; yuk
- ; (tyvars, tmvars) <- tcExtendNameTyVarEnv tvs $
- tcRuleTmBndrs skol_info rule_bndrs
- ; return (map snd tvs ++ tyvars, id : tmvars) }
-
{-
*********************************************************************************
* *
=====================================
compiler/GHC/Tc/TyCl/Instance.hs
=====================================
@@ -2009,9 +2009,9 @@ tcMethodBody skol_info clas tyvars dfun_ev_vars inst_tys
-- Example:
-- instance C [a] where
-- op :: forall b. Ord b => b -> a -> a
- -- {-# SPECIALISE b @Int #-}
- -- The speclalisation is for the `op` for this instance decl, not
- -- for the gloabal selector-id, of course.
+ -- {-# SPECIALISE op @Int #-}
+ -- The specialisation is for the `op` for this instance decl, not
+ -- for the global selector-id, of course.
tcSpecPrags global_meth_id prags
; let specs = mk_meth_spec_prags global_meth_id spec_inst_prags spec_prags
=====================================
compiler/GHC/Tc/Zonk/Type.hs
=====================================
@@ -1696,26 +1696,19 @@ zonkRule rule@(HsRule { rd_bndrs = bndrs
, rd_rhs = new_rhs } } }
where
add_tvs :: [TyVar] -> RuleBndrs GhcTc -> RuleBndrs GhcTc
- add_tvs tvs rbs@(RuleBndrs { rb_tmvs = bndrs })
- = rbs { rb_tmvs = map (noLocA . RuleBndr noAnn . noLocA) tvs ++ bndrs }
+ add_tvs tvs rbs@(RuleBndrs { rb_ext = bndrs }) = rbs { rb_ext = tvs ++ bndrs }
zonkRuleBndrs :: RuleBndrs GhcTc -> (RuleBndrs GhcTc -> ZonkTcM a) -> ZonkTcM a
-zonkRuleBndrs (RuleBndrs { rb_tyvs = tyvs, rb_tmvs = tmvs }) thing_inside
- = runZonkBndrT (traverse zonk_tm_bndr tmvs) $ \ new_tmvs ->
- thing_inside (RuleBndrs { rb_ext = noAnn, rb_tyvs = tyvs, rb_tmvs = new_tmvs })
+zonkRuleBndrs rb@(RuleBndrs { rb_ext = bndrs }) thing_inside
+ = runZonkBndrT (traverse zonk_it bndrs) $ \ new_bndrs ->
+ thing_inside (rb { rb_ext = new_bndrs })
where
- zonk_tm_bndr :: LRuleBndr GhcTc -> ZonkBndrTcM (LRuleBndr GhcTc)
- zonk_tm_bndr (L l (RuleBndr x (L loc v)))
- = do { v' <- zonk_it v
- ; return (L l (RuleBndr x (L loc v'))) }
- zonk_tm_bndr (L _ (RuleBndrSig {})) = panic "zonk_tm_bndr RuleBndrSig"
-
- zonk_it v
- | isId v = zonkIdBndrX v
- | otherwise = assert (isImmutableTyVar v) $
- zonkTyBndrX v
- -- We may need to go inside the kind of v and zonk there!
+ zonk_it v
+ | isId v = zonkIdBndrX v
+ | otherwise = assert (isImmutableTyVar v) $
+ zonkTyBndrX v
+ -- We may need to go inside the kind of v and zonk there!
{- Note [Free tyvars on rule LHS]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1739,7 +1732,7 @@ over it. Here is how:
* Here (ref :: TcRef [TyVar]) collects the type variables thus skolemised;
again see `commitFlexi`.
-* When zonking af RULE, in `zonkRule` we
+* When zonking a RULE, in `zonkRule` we
- 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
@@ -1750,7 +1743,7 @@ 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):
+ that may 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.
=====================================
compiler/Language/Haskell/Syntax/Binds.hs
=====================================
@@ -474,12 +474,12 @@ isCompleteMatchSig _ = False
********************************************************************* -}
data RuleBndrs pass = RuleBndrs
- { rb_ext :: (XCRuleBndrs pass)
+ { rb_ext :: XCRuleBndrs pass
+ -- After typechecking rb_ext contains all the quantified tyvars
, rb_tyvs :: Maybe [LHsTyVarBndr () (NoGhcTc pass)]
- -- ^ Forall'd type vars
- , rb_tmvs :: [LRuleBndr pass]
- -- ^ Forall'd term vars, before typechecking;
- -- after typechecking this includes all forall'd vars
+ -- ^ Forall'd type vars; preserved for pretty-printing
+ , rb_tmvs :: [LRuleBndr (NoGhcTc pass)]
+ -- ^ Forall'd term vars; preserved for pretty-printing
}
| XRuleBndrs !(XXRuleBndrs pass)
=====================================
compiler/Language/Haskell/Syntax/Extension.hs
=====================================
@@ -365,7 +365,7 @@ type family XHsRule x
type family XXRuleDecl x
-- -------------------------------------
--- RuleBndsr type families
+-- RuleBndrs type families
type family XCRuleBndrs x
type family XXRuleBndrs x
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3a55a7468d01e336e5f7b69d918bd5232bc8cf7f...9e47b2bdf15b53876f467753720df901c3455864
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3a55a7468d01e336e5f7b69d918bd5232bc8cf7f...9e47b2bdf15b53876f467753720df901c3455864
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/20241218/6d94b1f4/attachment-0001.html>
More information about the ghc-commits
mailing list