[Git][ghc/ghc][wip/T24359] Working I think
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Wed Mar 27 08:31:03 UTC 2024
Simon Peyton Jones pushed to branch wip/T24359 at Glasgow Haskell Compiler / GHC
Commits:
84958f48 by Simon Peyton Jones at 2024-03-27T08:30:44+00:00
Working I think
- - - - -
4 changed files:
- compiler/GHC/Hs/Binds.hs
- compiler/GHC/HsToCore/Binds.hs
- compiler/GHC/Tc/Gen/Sig.hs
- compiler/GHC/Tc/Zonk/Type.hs
Changes:
=====================================
compiler/GHC/Hs/Binds.hs
=====================================
@@ -963,7 +963,7 @@ instance Outputable TcSpecPrag where
ppr (SpecPragE { spe_tv_bndrs = tv_bndrs, spe_id_bndrs = id_bndrs
, spe_call = spec_e, spe_inl = inl })
= text (extractSpecPragName $ inl_src inl)
- <+> hang (ppr (tv_bndrs ++ id_bndrs) 2 (pprLExpr spec_e)
+ <+> hang (ppr (tv_bndrs ++ id_bndrs)) 2 (pprLExpr spec_e)
pprMinimalSig :: (OutputableBndr name)
=> LBooleanFormula (GenLocated l name) -> SDoc
=====================================
compiler/GHC/HsToCore/Binds.hs
=====================================
@@ -827,42 +827,49 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
-- E.g. /\a \(d:Eq a). let d2 = $df d in [] (Maybe a) d2
= putSrcSpanDs loc $
dsHsWrapper spec_app $ \core_app ->
- finishSpecPrag mb_poly_rhs spec_bndrs
- (core_app (Var poly_id))
- (\_ poly_rhs -> core_app poly_rhs)
+ finishSpecPrag mb_poly_rhs
+ spec_bndrs (core_app (Var poly_id))
+ spec_bndrs (\_ poly_rhs -> core_app poly_rhs)
spec_inl
-dsSpec mb_poly_rhs (L loc (SpecPragE { spe_bndrs = bndrs
+dsSpec mb_poly_rhs (L loc (SpecPragE { spe_tv_bndrs = tv_bndrs
+ , spe_id_bndrs = id_bndrs
+ , spe_lhs_ev_bndrs = lhs_evs
, spe_lhs_binds = lhs_binds
, spe_call = the_call
+ , spe_rhs_ev_bndrs = rhs_evs
, spe_rhs_binds = rhs_binds
, spe_inl = inl }))
= putSrcSpanDs loc $
- do { core_call <- dsTcEvBinds lhs_binds $ \ ds_binds ->
- do { ds_call <- dsLExpr the_call
- ; return (mkLets ds_binds ds_call) }
+ dsTcEvBinds lhs_binds $ \ ds_lhs_binds ->
+ dsTcEvBinds rhs_binds $ \ ds_rhs_binds ->
+ do { ds_call <- dsLExpr the_call
+ ; let core_call = mkLets ds_lhs_binds ds_call
- ; mk_spec_call <- dsTcEvBinds rhs_binds $ \ ds_binds ->
- do { ds_call <- dsLExpr the_call
+ ; mk_spec_call <- do { ds_call <- dsLExpr the_call
; return $ \ poly_id poly_rhs ->
- mkLetNonRec poly_id poly_rhs $
- mkLets ds_binds ds_call }
+ mkLetNonRec (localiseId poly_id) poly_rhs $
+ mkLets ds_lhs_binds $
+ mkLets ds_rhs_binds ds_call }
- ; finishSpecPrag mb_poly_rhs bndrs core_call mk_spec_call inl }
+ ; finishSpecPrag mb_poly_rhs
+ (tv_bndrs ++ lhs_evs ++ id_bndrs) core_call
+ (tv_bndrs ++ rhs_evs ++ id_bndrs) mk_spec_call
+ inl }
finishSpecPrag :: Maybe CoreExpr -- See the first param of dsSpec
-> [Var] -- LHS binders
-> CoreExpr -- LHS pattern
- -> (Id -> CoreExpr -> CoreExpr) -- Make spec RHS given function body
+ -> [Var] -> (Id -> CoreExpr -> CoreExpr) -- Make spec RHS given function body
-> InlinePragma
-> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule))
-finishSpecPrag mb_poly_rhs spec_bndrs
- rule_lhs
- mk_spec_rhs
+finishSpecPrag mb_poly_rhs
+ lhs_bndrs rule_lhs
+ spec_bndrs mk_spec_rhs
spec_inl
= do { dflags <- getDynFlags
- ; case decomposeRuleLhs dflags spec_bndrs rule_lhs (mkVarSet spec_bndrs) of {
+ ; case decomposeRuleLhs dflags lhs_bndrs rule_lhs (mkVarSet lhs_bndrs) of {
Left msg -> do { diagnosticDs msg; return Nothing } ;
Right (rule_bndrs, poly_id, rule_lhs_args) ->
@@ -871,7 +878,6 @@ finishSpecPrag mb_poly_rhs spec_bndrs
; let poly_name = idName poly_id
spec_occ = mkSpecOcc (getOccName poly_name)
spec_name = mkInternalName uniq spec_occ (getSrcSpan poly_name)
- spec_ty = mkLamTypes spec_bndrs (exprType rule_lhs)
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
@@ -880,6 +886,7 @@ finishSpecPrag mb_poly_rhs spec_bndrs
simpl_opts = initSimpleOpts dflags
fn_unf = realIdUnfolding poly_id
spec_unf = specUnfolding simpl_opts spec_bndrs mk_app rule_lhs_args fn_unf
+ mk_app e = mkApps e rule_lhs_args
spec_id = mkLocalId spec_name ManyTy spec_ty
-- Specialised binding is toplevel, hence Many.
`setInlinePragma` inl_prag
@@ -887,9 +894,9 @@ finishSpecPrag mb_poly_rhs spec_bndrs
rule = mkSpecRule dflags this_mod False rule_act (text "USPEC")
poly_id rule_bndrs rule_lhs_args
- (mkVarApps (Var spec_id) spec_bndrs)
+ (mkVarApps (Var spec_id) lhs_bndrs)
- mk_app e = mkApps e rule_lhs_args
+ spec_ty = mkLamTypes spec_bndrs (exprType rule_lhs)
spec_rhs = mkLams spec_bndrs $
mk_spec_rhs poly_id poly_rhs
=====================================
compiler/GHC/Tc/Gen/Sig.hs
=====================================
@@ -877,21 +877,22 @@ tcSpecPrag _poly_id (SpecSigE nm bndrs spec_e inl)
qtkvs lhs_evs residual_wanted
-- rhs_binds uses rhs_evs to build `wanted` (NB not just `residual_wanted`)
- ; let rhs_preds = mkMinimalBySCs id quant_preds
- ; rhs_evs <- mapM newEvVar rhs_preds
+ ; let quant_wanted = emptyWC { wc_simple = quant_cts }
+ ; rhs_evs <- mapM newEvVar quant_preds
; (implic2, rhs_binds) <- buildImplicationFor tc_lvl skol_info_anon
- qtkvs rhs_evs wanted
+ qtkvs rhs_evs quant_wanted
; emitImplications (implic1 `unionBags` implic2)
- ; let all_bndrs = qtkvs ++ rule_evs ++ id_bndrs
; traceTc "tcSpecPrag:SpecSigE" $
- vcat [ text "all_bndrs:" <+> ppr all_bndrs
+ vcat [ text "tv/id bndrs:" <+> ppr qtkvs <+> ppr id_bndrs
+ , text "lhs_evs:" <+> ppr lhs_evs
+ , text "rhs_evs:" <+> ppr rhs_evs
, text "spec_e:" <+> ppr spec_e'
, text "inl:" <+> ppr inl ]
; return [SpecPragE { spe_tv_bndrs = qtkvs
, spe_id_bndrs = id_bndrs
- , spe_lhs_ev_bndrs = rule_evs
+ , spe_lhs_ev_bndrs = lhs_evs
, spe_lhs_binds = lhs_binds
, spe_rhs_ev_bndrs = rhs_evs
, spe_rhs_binds = rhs_binds
=====================================
compiler/GHC/Tc/Zonk/Type.hs
=====================================
@@ -855,15 +855,22 @@ zonkLTcSpecPrags ps
= do { co_fn' <- don'tBind $ zonkCoFn co_fn
; id' <- zonkIdOcc id
; return (L loc (SpecPrag id' co_fn' inl)) }
- zonk_prag (L loc (SpecPragE { spe_bndrs = bndrs, spe_lhs_binds = lhs_binds
- , spe_call = spec_e, spe_rhs_binds = rhs_binds
+ zonk_prag (L loc (SpecPragE { spe_tv_bndrs = tv_bndrs, spe_id_bndrs = id_bndrs
+ , spe_lhs_ev_bndrs = lhs_evs, spe_rhs_ev_bndrs = rhs_evs
+ , spe_lhs_binds = lhs_binds, spe_rhs_binds = rhs_binds
+ , spe_call = spec_e
, spe_inl = inl }))
- = runZonkBndrT (zonkCoreBndrsX bndrs) $ \bndrs' ->
- runZonkBndrT (zonkTcEvBinds lhs_binds) $ \lhs_binds' ->
- runZonkBndrT (zonkTcEvBinds rhs_binds) $ \rhs_binds' ->
+ = runZonkBndrT (zonkCoreBndrsX tv_bndrs) $ \tv_bndrs' ->
+ runZonkBndrT (zonkCoreBndrsX id_bndrs) $ \id_bndrs' ->
+ runZonkBndrT (zonkCoreBndrsX lhs_evs) $ \lhs_evs' ->
+ runZonkBndrT (zonkTcEvBinds lhs_binds) $ \lhs_binds' ->
+ runZonkBndrT (zonkCoreBndrsX rhs_evs) $ \rhs_evs' ->
+ runZonkBndrT (zonkTcEvBinds rhs_binds) $ \rhs_binds' ->
do { spec_e' <- zonkLExpr spec_e
- ; return (L loc (SpecPragE { spe_bndrs = bndrs', spe_lhs_binds = lhs_binds'
- , spe_call = spec_e', spe_rhs_binds = rhs_binds'
+ ; return (L loc (SpecPragE { spe_tv_bndrs = tv_bndrs', spe_id_bndrs = id_bndrs'
+ , spe_lhs_ev_bndrs = lhs_evs', spe_rhs_ev_bndrs = rhs_evs'
+ , spe_lhs_binds = lhs_binds', spe_rhs_binds = rhs_binds'
+ , spe_call = spec_e'
, spe_inl = inl })) }
{-
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/84958f48c4200b2861c47af802c031d042226db9
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/84958f48c4200b2861c47af802c031d042226db9
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/20240327/6cfebb68/attachment-0001.html>
More information about the ghc-commits
mailing list