[Git][ghc/ghc][wip/T24359] Progress

[Simon Peyton Jones (@simonpj)]

Simon Peyton Jones pushed to branch wip/T24359 at Glasgow Haskell Compiler / GHC


Commits:
f5e3041e by Simon Peyton Jones at 2024-03-26T14:57:30+00:00
Progress

- - - - -


2 changed files:

- compiler/GHC/Hs/Binds.hs
- compiler/GHC/Tc/Gen/Sig.hs


Changes:

=====================================
compiler/GHC/Hs/Binds.hs
=====================================
@@ -805,11 +805,19 @@ data TcSpecPrag
       -- ^ The Id to be specialised, a wrapper that specialises the
       -- polymorphic function, and inlining spec for the specialised function
 
-   | SpecPragE { spe_bndrs     :: [Var]
-               , spe_lhs_binds :: TcEvBinds
-               , spe_call      :: LHsExpr GhcTc
-               , spe_rhs_binds :: TcEvBinds
-               , spe_inl       :: InlinePragma }
+   | SpecPragE { spe_tv_bndrs     :: [TyVar]
+               , spe_id_bndrs     :: [Id]
+
+               , spe_lhs_ev_bndrs :: [EvVar]
+               , spe_lhs_binds    :: TcEvBinds  -- Closes spe_call using variables in
+                                                -- tv_bndrs, lhs_ev_bndrs, id_bndrs
+
+               , spe_rhs_ev_bndrs :: [EvVar]
+               , spe_rhs_binds    :: TcEvBinds  -- Closes spe_call using variables in
+                                                -- tv_bndrs, rhs_ev_bndrs, id_bndrs
+
+               , spe_call         :: LHsExpr GhcTc
+               , spe_inl          :: InlinePragma }
 
 noSpecPrags :: TcSpecPrags
 noSpecPrags = SpecPrags []
@@ -952,9 +960,10 @@ pprTcSpecPrags (SpecPrags ps)  = vcat (map (ppr . unLoc) ps)
 instance Outputable TcSpecPrag where
   ppr (SpecPrag var _ inl)
     = text (extractSpecPragName $ inl_src inl) <+> pprSpec var (text "<type>") inl
-  ppr (SpecPragE { spe_bndrs = bndrs, spe_call = spec_e, spe_inl = inl })
+  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 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/Tc/Gen/Sig.hs
=====================================
@@ -872,13 +872,15 @@ tcSpecPrag _poly_id (SpecSigE nm bndrs spec_e inl)
        ; qtkvs <- quantifyTyVars skol_info DefaultNonStandardTyVars weeded_dvs
 
        -- Left hand side of the RULE
-       ; rule_evs <- mk_quant_evs quant_cts
+       ; lhs_evs <- mk_quant_evs quant_cts
        ; (implic1, lhs_binds) <- buildImplicationFor tc_lvl skol_info_anon
-                                                     qtkvs rule_evs residual_wanted
+                                                     qtkvs lhs_evs residual_wanted
 
-       -- rhs_binds uses rule_evs to build `wanted` (NB not just `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
        ; (implic2, rhs_binds) <- buildImplicationFor tc_lvl skol_info_anon
-                                                     qtkvs rule_evs wanted
+                                                     qtkvs rhs_evs wanted
 
        ; emitImplications (implic1 `unionBags` implic2)
 
@@ -887,11 +889,15 @@ tcSpecPrag _poly_id (SpecSigE nm bndrs spec_e inl)
          vcat [ text "all_bndrs:" <+> ppr all_bndrs
               , text "spec_e:" <+> ppr spec_e'
               , text "inl:" <+> ppr inl ]
-       ; return [SpecPragE { spe_bndrs     = all_bndrs
-                           , spe_lhs_binds = lhs_binds
-                           , spe_call      = spec_e'
-                           , spe_rhs_binds = rhs_binds
-                           , spe_inl       = inl }] }
+       ; return [SpecPragE { spe_tv_bndrs     = qtkvs
+                           , spe_id_bndrs     = id_bndrs
+                           , spe_lhs_ev_bndrs = rule_evs
+                           , spe_lhs_binds    = lhs_binds
+                           , spe_rhs_ev_bndrs = rhs_evs
+                           , spe_rhs_binds    = rhs_binds
+
+                           , spe_call = spec_e'
+                           , spe_inl  = inl }] }
 
 tcSpecPrag _ prag = pprPanic "tcSpecPrag" (ppr prag)
 



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f5e3041ef9426801993a592bdcaf67eced9e5dbf

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f5e3041ef9426801993a592bdcaf67eced9e5dbf
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/20240326/e727723c/attachment-0001.html>