[Git][ghc/ghc][wip/T24359] Better now
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Sat Nov 23 23:41:03 UTC 2024
Simon Peyton Jones pushed to branch wip/T24359 at Glasgow Haskell Compiler / GHC
Commits:
dea62ed9 by Simon Peyton Jones at 2024-11-23T23:40:43+00:00
Better now
- - - - -
5 changed files:
- compiler/GHC/HsToCore/Binds.hs
- compiler/GHC/Tc/Gen/Sig.hs
- compiler/GHC/Tc/Solver.hs
- compiler/GHC/Tc/Zonk/Type.hs
- testsuite/tests/typecheck/should_compile/tc212.hs
Changes:
=====================================
compiler/GHC/HsToCore/Binds.hs
=====================================
@@ -795,14 +795,14 @@ dsSpecs :: CoreExpr -- Its rhs
-- See Note [Overview of SPECIALISE pragmas] in GHC.Tc.Gen.Sig
dsSpecs _ IsDefaultMethod = return (nilOL, [])
dsSpecs poly_rhs (SpecPrags sps)
- = do { pairs <- mapMaybeM (dsLSpec (Just poly_rhs)) sps
+ = do { pairs <- mapMaybeM (dsLSpec poly_rhs) sps
; let (spec_binds_s, rules) = unzip pairs
; return (concatOL spec_binds_s, rules) }
-dsLSpec :: Maybe CoreExpr -> Located TcSpecPrag
+dsLSpec :: CoreExpr -> Located TcSpecPrag
-> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule))
-dsLSpec mb_poly_rhs (L loc prag)
- = putSrcSpanDs loc $ dsSpec mb_poly_rhs prag
+dsLSpec poly_rhs (L loc prag)
+ = putSrcSpanDs loc $ dsSpec (Just poly_rhs) prag
dsSpec :: Maybe CoreExpr -- Just rhs => RULE is for a local binding
-- Nothing => RULE is for an imported Id
@@ -821,14 +821,13 @@ dsSpec mb_poly_rhs (SpecPrag poly_id spec_co spec_inl)
-- E.g. /\a \(d:Eq a). let d2 = $df d in [] (Maybe a) d2
= dsHsWrapper spec_app $ \core_app ->
do { dflags <- getDynFlags
+ ; let poly_rhs = specFunBody poly_id mb_poly_rhs
; case decomposeRuleLhs dflags spec_bndrs (core_app (Var poly_id))
(mkVarSet spec_bndrs) of {
Left msg -> do { diagnosticDs msg; return Nothing } ;
Right (rule_bndrs, poly_id, rule_lhs_args) ->
-
- ; let poly_rhs = specFunBody poly_id mb_poly_rhs
- ; finishSpecPrag rule_bndrs poly_id rule_lhs_args
- rule_bndrs (core_app poly_rhs) spec_inl
+ finishSpecPrag rule_bndrs poly_id rule_lhs_args
+ rule_bndrs (core_app poly_rhs) spec_inl } }
{-
dsSpec mb_poly_rhs (SpecPragE { spe_poly_id = poly_id
@@ -878,8 +877,8 @@ dsSpec mb_poly_rhs (SpecPragE { spe_poly_id = poly_id
-}
dsSpec mb_poly_rhs (SpecPragE { spe_poly_id = poly_id
- , spe_tv_bndrs = tv_bndrs
, spe_id_bndrs = id_bndrs
+ , spe_tv_bndrs = tv_bndrs
, spe_lhs_ev_bndrs = lhs_evs
, spe_lhs_binds = lhs_binds
, spe_lhs_call = the_call
@@ -896,6 +895,7 @@ dsSpec mb_poly_rhs (SpecPragE { spe_poly_id = poly_id
dsLExpr the_call
; tracePm "dsSpec1" (vcat
[ ppr poly_id
+ , text "tv_bndrs" <+> ppr tv_bndrs
, text "lhs_binds" <+> ppr lhs_binds
, text "ds_lhs_binds" <+> ppr ds_lhs_binds
, text "ds_call" <+> ppr ds_call ])
@@ -905,28 +905,65 @@ dsSpec mb_poly_rhs (SpecPragE { spe_poly_id = poly_id
simpleOptExpr simpl_opts $
ds_call
- lhs_id_bndrs = filterOut (`elemVarSet` exprFreeVars core_call) $
- id_bndrs ++ bindersOfBinds ds_lhs_binds
- -- All the vars in core_call that should be quantified
+ lhs_id_bndrs = id_bndrs ++ lhs_evs ++ bindersOfBinds ds_lhs_binds
+ id_bndr_set = mkVarSet lhs_id_bndrs
+ -- lhs_id_bndrs: all the Ids in core_call that should be quantified
+ -- These are the ones free in core_call that are local
+ -- to this specialisation, not global
+
+ rule_bndrs = scopedSort (exprSomeFreeVarsList quantify_me core_call)
+ quantify_me v = isTyVar v || v `elemVarSet` id_bndr_set
+ -- Quantify over all tyvars; but only over Ids boundx explicitly
+ -- this is a terrible hack. What about local SPECIALISE pragmas
+ -- that mention some in-scope TyVar?
rhs_const_binds :: [CoreBind]
rhs_const_binds = get_const_ev_binds lhs_evs ds_lhs_binds
+ const_bndrs = mkVarSet (bindersOfBinds rhs_const_binds)
- spec_id_bndrs = filterOut (`elemVarSet` const_bndrs) lhs_id_bndrs
+ spec_bndrs = filterOut (`elemVarSet` const_bndrs) rule_bndrs
fn_body = specFunBody poly_id mb_poly_rhs
- spec_body = mkLets rhs_const_binds $
- mkCoreApps fn_body lhs_args
-
- ; tracePm "dsSpec1" (vcat [ ppr poly_id $$ ppr ds_call $$ ppr core_call])
- ; finishSpecPrag mb_poly_rhs
- (tv_bndrs ++ lhs_id_bndrs) core_call
- (tv_bndrs ++ spec_id_bndrs) spec_body inl }
+ ; tracePm "dsSpec2" (vcat [ text "poly_id" <+> ppr poly_id
+ , text "ds_call" <+> ppr ds_call
+ , text "core_call" <+> ppr core_call
+ , text "core_call fvs" <+> ppr (exprFreeVars core_call)
+ , text "lhs_evs" <+> ppr lhs_evs
+ , text "id_bndrs" <+> ppr id_bndrs
+ , text "lhs_id_bndrs" <+> ppr lhs_id_bndrs
+ , text "rhs_const_binds" <+> ppr rhs_const_binds
+ ])
+
+ ; case collectArgs core_call of
+ (Var fn_id, lhs_args)
+ -> assertPpr (fn_id == poly_id) (ppr fn_id $$ ppr poly_id) $
+ finishSpecPrag
+ rule_bndrs poly_id lhs_args
+ spec_bndrs spec_body inl
+ where
+ spec_body = mkLets rhs_const_binds $
+ mkCoreApps fn_body lhs_args
+
+ _other -> do { diagnosticDs (DsRuleLhsTooComplicated ds_call core_call)
+ ; return Nothing } }
where
drop_cast (Cast e _) = drop_cast e
drop_cast e = e
+get_const_ev_binds :: [EvVar] -> [CoreBind] -> [CoreBind]
+get_const_ev_binds evs ev_binds
+ = go (mkVarSet evs) ev_binds
+ where
+ go :: VarSet -> [CoreBind] -> [CoreBind]
+ go _ [] = []
+ go qevs (bind : binds)
+ | all (isEmptyVarSet . exprSomeFreeVars (`elemVarSet` qevs)) $
+ rhssOfBind bind
+ = bind : go qevs binds
+ | otherwise
+ = go (qevs `extendVarSetList` bindersOf bind) binds
+
failBecauseOfClassOp :: Id -> DsM (Maybe a)
-- There is no point in trying to specialise a class op
-- Moreover, classops don't (currently) have an inl_sat arity set
@@ -938,16 +975,16 @@ failBecauseOfClassOp poly_id
finishSpecPrag :: [Var] -> Id -> [CoreExpr] -- LHS pattern
-> [Var] -> CoreExpr -> InlinePragma -- Specialised form
-> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule))
-finishSpecPrag rule_bndrs poly_id rule_bndrs rhs_lhs_args
+finishSpecPrag rule_bndrs poly_id rule_lhs_args
spec_bndrs spec_body spec_inl
- do { this_mod <- getModule
+ = 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)
- poly_rhs = specFunBody poly_id mb_poly_rhs
id_inl = idInlinePragma poly_id
- inl_prag = specFunInlinePrag mb_poly_rhs poly_id id_inl spec_inl
+ inl_prag = specFunInlinePrag poly_id id_inl spec_inl
rule_act = specRuleActivation id_inl spec_inl
simpl_opts = initSimpleOpts dflags
@@ -963,7 +1000,7 @@ finishSpecPrag rule_bndrs poly_id rule_bndrs rhs_lhs_args
poly_id rule_bndrs rule_lhs_args
(mkVarApps (Var spec_id) spec_bndrs)
- rule_lhs_ty = exprType (mkVarApps poly_id rule_lhs_args)
+ rule_lhs_ty = exprType (mkApps (Var poly_id) rule_lhs_args)
spec_ty = mkLamTypes spec_bndrs rule_lhs_ty
spec_rhs = mkLams spec_bndrs spec_body
@@ -972,13 +1009,13 @@ finishSpecPrag rule_bndrs poly_id rule_bndrs rhs_lhs_args
; tracePm "dsSpec" (vcat
[ text "fun:" <+> ppr poly_id
, text "spec_bndrs:" <+> ppr spec_bndrs
+ , text "spec_body:" <+> ppr spec_body
, text "args:" <+> ppr rule_lhs_args ])
; return (Just (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
+ }
specFunBody :: Id -> Maybe CoreExpr -> CoreExpr
specFunBody _ (Just rhs)
@@ -992,19 +1029,17 @@ specFunBody poly_id Nothing
| otherwise = pprPanic "dsImpSpecs" (ppr poly_id)
-- The type checker has checked that it *has* an unfolding
-specFunInlinePrag :: Maybe CoreExpr -> Id -> InlinePragma
+specFunInlinePrag :: Id -> InlinePragma
-> InlinePragma -> InlinePragma
-- See Note [Activation pragmas for SPECIALISE]
-specFunInlinePrag mb_poly_rhs poly_id id_inl spec_inl
+specFunInlinePrag poly_id id_inl spec_inl
| not (isDefaultInlinePragma spec_inl) = spec_inl
- | not is_local_id -- See Note [Specialising imported functions]
- -- in OccurAnal
+ | isGlobalId poly_id -- See Note [Specialising imported functions]
+ -- in OccurAnal
, isStrongLoopBreaker (idOccInfo poly_id) = neverInlinePragma
| otherwise = id_inl
-- Get the INLINE pragma from SPECIALISE declaration, or,
-- failing that, from the original Id
- where
- is_local_id = isJust mb_poly_rhs
specRuleActivation :: InlinePragma -> InlinePragma -> Activation
specRuleActivation id_inl spec_inl
=====================================
compiler/GHC/Tc/Gen/Sig.hs
=====================================
@@ -37,9 +37,9 @@ import {-# SOURCE #-} GHC.Tc.Gen.Expr ( tcInferRho, tcCheckMonoExpr )
import GHC.Tc.Errors.Types ( FixedRuntimeRepProvenance(..), TcRnMessage(..) )
import GHC.Tc.Gen.HsType
import GHC.Tc.Solver( reportUnsolvedEqualities, pushLevelAndSolveEqualitiesX
- , growThetaTyVars )
+ , emitResidualConstraints )
import GHC.Tc.Solver.Solve( solveWanteds )
-import GHC.Tc.Solver.Monad( runTcS )
+import GHC.Tc.Solver.Monad( runTcS, runTcSWithEvBinds )
import GHC.Tc.Validity ( checkValidType )
import GHC.Tc.Utils.Monad
@@ -50,7 +50,7 @@ import GHC.Tc.Utils.Instantiate( topInstantiate, tcInstTypeBndrs )
import GHC.Tc.Utils.Env
import GHC.Tc.Types.Origin
-import GHC.Tc.Types.Evidence( HsWrapper, (<.>) )
+import GHC.Tc.Types.Evidence( HsWrapper, (<.>), emptyTcEvBinds, TcEvBinds(..) )
import GHC.Tc.Types.Constraint
import GHC.Tc.Zonk.TcType
@@ -921,22 +921,31 @@ tcSpecPrag poly_id (SpecSigE nm bndrs spec_e inl)
let skol_info_anon = SpecESkol nm
; traceTc "tcSpecPrag: specSigE1" (ppr nm $$ ppr spec_e)
; skol_info <- mkSkolemInfo skol_info_anon
- ; (tc_lvl, wanted, (id_bndrs, spec_e', rho))
+ ; (rhs_tclvl, wanted, (tv_bndrs, id_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 (id_bndrs, L loc spec_e', rho) } }
+ do { (L loc spec_e', _rho) <- tcInferRho spec_e
+ ; return (tv_bndrs, id_bndrs, L loc spec_e') } }
- ; (qtkvs, qevs, ev_binds, insol) <- simplifyInfer TopLevel tc_lvl NoRestrictions
- [] [(nm,rho)] wanted
+ ; ev_binds_var <- newTcEvBinds
+ ; wanted <- setTcLevel rhs_tclvl $
+ runTcSWithEvBinds ev_binds_var $
+ solveWanteds wanted
+
+ ; let quant_cts = approximateWC False wanted
+ ; qevs <- mk_quant_evs quant_cts
+
+ ; emitResidualConstraints rhs_tclvl skol_info_anon ev_binds_var
+ emptyVarSet tv_bndrs qevs
+ wanted
; return [SpecPragE { spe_poly_id = poly_id
- , spe_tv_bndrs = qtkvs
+ , spe_tv_bndrs = tv_bndrs
, spe_id_bndrs = id_bndrs
, spe_lhs_ev_bndrs = qevs
- , spe_lhs_binds = ev_binds
+ , spe_lhs_binds = TcEvBinds ev_binds_var
, spe_lhs_call = spec_e'
, spe_rhs_ev_bndrs = []
, spe_rhs_binds = emptyTcEvBinds
=====================================
compiler/GHC/Tc/Solver.hs
=====================================
@@ -16,7 +16,7 @@ module GHC.Tc.Solver(
tcNormalise,
approximateWC, -- Exported for plugins to use
- captureTopConstraints,
+ captureTopConstraints, emitResidualConstraints,
simplifyTopWanteds,
@@ -968,14 +968,17 @@ simplifyInfer top_lvl rhs_tclvl infer_mode sigs name_taus wanteds
; bound_theta_vars <- mapM TcM.newEvVar bound_theta
; let full_theta = map idType bound_theta_vars
- ; skol_info <- mkSkolemInfo (InferSkol [ (name, mkPhiTy full_theta ty)
- | (name, ty) <- name_taus ])
+ skol_info = InferSkol [ (name, mkPhiTy full_theta ty)
+ | (name, ty) <- name_taus ]
+ -- mkPhiTy: we don't add the quantified variables here, because
+ -- they are also bound in ic_skols and we want them to be tidied
+ -- uniformly.
}
-- Now emit the residual constraint
- ; emitResidualConstraints rhs_tclvl ev_binds_var
- name_taus co_vars qtvs bound_theta_vars
+ ; emitResidualConstraints rhs_tclvl skol_info ev_binds_var
+ co_vars qtvs bound_theta_vars
wanted_transformed
-- All done!
@@ -992,13 +995,12 @@ simplifyInfer top_lvl rhs_tclvl infer_mode sigs name_taus wanteds
partial_sigs = filter isPartialSig sigs
--------------------
-emitResidualConstraints :: TcLevel -> EvBindsVar
- -> [(Name, TcTauType)]
+emitResidualConstraints :: TcLevel -> SkolemInfoAnon -> EvBindsVar
-> CoVarSet -> [TcTyVar] -> [EvVar]
-> WantedConstraints -> TcM ()
-- Emit the remaining constraints from the RHS.
-emitResidualConstraints rhs_tclvl ev_binds_var
- name_taus co_vars qtvs full_theta_vars wanteds
+emitResidualConstraints rhs_tclvl skol_info ev_binds_var
+ co_vars qtvs full_theta_vars wanteds
| isEmptyWC wanteds
= return ()
@@ -1031,13 +1033,6 @@ emitResidualConstraints rhs_tclvl ev_binds_var
; emitConstraints (emptyWC { wc_simple = outer_simple
, wc_impl = implics }) }
- where
- full_theta = map idType full_theta_vars
- skol_info = InferSkol [ (name, mkPhiTy full_theta ty)
- | (name, ty) <- name_taus ]
- -- We don't add the quantified variables here, because they are
- -- also bound in ic_skols and we want them to be tidied
- -- uniformly.
--------------------
findInferredDiff :: TcThetaType -> TcThetaType -> TcM TcThetaType
@@ -1286,7 +1281,7 @@ decideQuantification
:: TopLevelFlag
-> TcLevel
-> InferMode
- -> SkolemInfo
+ -> SkolemInfoAnon
-> [(Name, TcTauType)] -- Variables to be generalised
-> [TcIdSigInst] -- Partial type signatures (if any)
-> WantedConstraints -- Candidate theta; already zonked
@@ -1818,13 +1813,13 @@ defaultTyVarsAndSimplify rhs_tclvl candidates
------------------
decideQuantifiedTyVars
- :: SkolemInfo
+ :: SkolemInfoAnon
-> [(Name,TcType)] -- Annotated theta and (name,tau) pairs
-> [TcIdSigInst] -- Partial signatures
-> [PredType] -- Candidates, zonked
-> TcM [TyVar]
-- Fix what tyvars we are going to quantify over, and quantify them
-decideQuantifiedTyVars skol_info name_taus psigs candidates
+decideQuantifiedTyVars skol_info_anon name_taus psigs candidates
= do { -- Why psig_tys? We try to quantify over everything free in here
-- See Note [Quantification and partial signatures]
-- Wrinkles 2 and 3
@@ -1855,6 +1850,7 @@ decideQuantifiedTyVars skol_info name_taus psigs candidates
, text "grown_tcvs =" <+> ppr grown_tcvs
, text "dvs =" <+> ppr dvs_plus])
+ ; skol_info <- mkSkolemInfo skol_info_anon
; quantifyTyVars skol_info DefaultNonStandardTyVars dvs_plus }
------------------
=====================================
compiler/GHC/Tc/Zonk/Type.hs
=====================================
@@ -863,7 +863,8 @@ zonkLTcSpecPrags ps
, spe_lhs_binds = lhs_binds, spe_rhs_binds = rhs_binds
, spe_lhs_call = spec_e
, spe_inl = inl }))
- = runZonkBndrT (zonkCoreBndrsX tv_bndrs) $ \tv_bndrs' ->
+ = setZonkType SkolemiseFlexi $
+ runZonkBndrT (zonkCoreBndrsX tv_bndrs) $ \tv_bndrs' ->
runZonkBndrT (zonkCoreBndrsX id_bndrs) $ \id_bndrs' ->
runZonkBndrT (zonkCoreBndrsX lhs_evs) $ \lhs_evs' ->
runZonkBndrT (zonkTcEvBinds lhs_binds) $ \lhs_binds' ->
=====================================
testsuite/tests/typecheck/should_compile/tc212.hs
=====================================
@@ -5,5 +5,5 @@ module ShouldCompile where
-- A specialise pragma with no type signature
-- fac :: Num a => a -> a
-fac n = n -- fac (n + 1)
+fac n = fac (n + 1)
{-# SPECIALISE fac :: Int -> Int #-}
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/dea62ed9184a5c0fa24d6496a87711a762827c3f
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/dea62ed9184a5c0fa24d6496a87711a762827c3f
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/20241123/4598e082/attachment-0001.html>
More information about the ghc-commits
mailing list