[Git][ghc/ghc][wip/T24359] Tidy up a bit
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Tue Nov 26 00:03:08 UTC 2024
Simon Peyton Jones pushed to branch wip/T24359 at Glasgow Haskell Compiler / GHC
Commits:
0335a934 by Simon Peyton Jones at 2024-11-26T00:02:37+00:00
Tidy up a bit
- - - - -
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
=====================================
@@ -840,22 +840,12 @@ data TcSpecPrag
-- ^ The Id to be specialised, a wrapper that specialises the
-- polymorphic function, and inlining spec for the specialised function
- | SpecPragE { spe_poly_id :: Id -- THe Id being specialised
- , spe_tv_bndrs :: [TyVar]
- , spe_id_bndrs :: [Id]
-
- , spe_lhs_ev_bndrs :: [EvVar]
- , spe_lhs_binds :: TcEvBinds
- , spe_lhs_call :: LHsExpr GhcTc -- The LHS of the RULE: a call of f
- -- spe_lhs_binds closes spe_call using variables in
- -- spe_tv_bndrs, spe_id_bndrs, spe_lhs_ev_bndrs
-
- , spe_rhs_ev_bndrs :: [EvVar]
- , spe_rhs_binds :: TcEvBinds
- -- spe_rhs_binds closes spe_call using variables in
- -- spe_tv_bndrs, spe_id_bndrs, spe_rhs_ev_bndrs
-
- , spe_inl :: InlinePragma }
+ | SpecPragE { spe_poly_id :: Id -- THe Id being specialised
+ , spe_tv_bndrs :: [TyVar]
+ , spe_id_bndrs :: [Id]
+ , spe_ev_bndrs :: [EvVar]
+ , spe_call :: LHsExpr GhcTc -- The LHS of the RULE: a call of f
+ , spe_inl :: InlinePragma }
noSpecPrags :: TcSpecPrags
noSpecPrags = SpecPrags []
@@ -1004,7 +994,7 @@ instance Outputable TcSpecPrag where
ppr (SpecPrag var _ inl)
= text (extractSpecPragName $ inl_src inl) <+> pprSpec var (text "<type>") inl
ppr (SpecPragE { spe_tv_bndrs = tv_bndrs, spe_id_bndrs = id_bndrs
- , spe_lhs_call = spec_e, spe_inl = inl })
+ , spe_call = spec_e, spe_inl = inl })
= text (extractSpecPragName $ inl_src inl)
<+> hang (ppr (tv_bndrs ++ id_bndrs)) 2 (pprLExpr spec_e)
=====================================
compiler/GHC/HsToCore/Binds.hs
=====================================
@@ -873,33 +873,28 @@ dsSpec mb_poly_rhs (SpecPragE { spe_poly_id = poly_id
drop_cast e = e
-}
-dsSpec poly_rhs (SpecPragE { spe_poly_id = poly_id
- , 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
- , spe_inl = inl })
+dsSpec poly_rhs (SpecPragE { spe_poly_id = poly_id
+ , spe_tv_bndrs = tv_bndrs
+ , spe_id_bndrs = id_bndrs
+ , spe_ev_bndrs = lhs_evs
+ , spe_call = the_call
+ , spe_inl = inl })
-- SpecPragE case: See Note [Handling new-form SPECIALISE pragmas] in GHC.Tc.Gen.Sig
| isJust (isClassOpId_maybe poly_id)
= failBecauseOfClassOp poly_id
| otherwise
- = dsTcEvBinds lhs_binds $ \ ds_lhs_binds ->
- do { ds_call <- zapUnspecables $
+ = do { ds_call <- zapUnspecables $
-- zapUnspecables: see Note [Desugaring RULE left hand sides]
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 ])
; dflags <- getDynFlags
; let simpl_opts = initSimpleOpts dflags
- core_call = simpleOptExprNoOccAnal simpl_opts $
- mkLets ds_lhs_binds ds_call
+ core_call = simpleOptExprNoOccAnal simpl_opts ds_call
; case prepareSpecLHS lhs_evs core_call of {
Nothing -> do { diagnosticDs (DsRuleLhsTooComplicated ds_call core_call)
=====================================
compiler/GHC/Tc/Gen/Sig.hs
=====================================
@@ -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, (<.>), emptyTcEvBinds, TcEvBinds(..) )
+import GHC.Tc.Types.Evidence( HsWrapper(..), (<.>), TcEvBinds(..) )
import GHC.Tc.Types.Constraint
import GHC.Tc.Zonk.TcType
@@ -949,15 +949,13 @@ tcSpecPrag poly_id (SpecSigE nm bndrs spec_e inl)
, text "spec_e:" <+> ppr spec_e'
, text "inl:" <+> ppr inl ]
- ; return [SpecPragE { spe_poly_id = poly_id
- , spe_tv_bndrs = tv_bndrs
- , spe_id_bndrs = id_bndrs
- , spe_lhs_ev_bndrs = qevs
- , spe_lhs_binds = TcEvBinds ev_binds_var
- , spe_lhs_call = spec_e'
- , spe_rhs_ev_bndrs = []
- , spe_rhs_binds = emptyTcEvBinds
- , spe_inl = inl }] }
+ ; let lhs_call = mkLHsWrap (WpLet (TcEvBinds ev_binds_var)) spec_e'
+ ; return [SpecPragE { spe_poly_id = poly_id
+ , spe_tv_bndrs = tv_bndrs
+ , spe_id_bndrs = id_bndrs
+ , spe_ev_bndrs = qevs
+ , spe_call = lhs_call
+ , spe_inl = inl }] }
{-
-- Solve unification constraints
=====================================
compiler/GHC/Tc/Zonk/Type.hs
=====================================
@@ -859,25 +859,21 @@ zonkLTcSpecPrags ps
; return (L loc (SpecPrag id' co_fn' inl)) }
zonk_prag (L loc (SpecPragE { spe_poly_id = poly_id
, 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_lhs_call = spec_e
+ , spe_ev_bndrs = lhs_evs
+ , spe_call = spec_e
, spe_inl = inl }))
= 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' ->
- runZonkBndrT (zonkCoreBndrsX rhs_evs) $ \rhs_evs' ->
- runZonkBndrT (zonkTcEvBinds rhs_binds) $ \rhs_binds' ->
do { poly_id' <- zonkIdOcc poly_id -- Does not need to be under all these binders, but no harm
; spec_e' <- zonkLExpr spec_e
- ; return (L loc (SpecPragE { spe_poly_id = poly_id'
- , 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_lhs_call = spec_e'
- , spe_inl = inl })) }
+ ; return (L loc (SpecPragE { spe_poly_id = poly_id'
+ , spe_tv_bndrs = tv_bndrs'
+ , spe_id_bndrs = id_bndrs'
+ , spe_ev_bndrs = lhs_evs'
+ , spe_call = spec_e'
+ , spe_inl = inl })) }
{-
************************************************************************
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0335a934a66e76d89012d042cb857d35e3c01990
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0335a934a66e76d89012d042cb857d35e3c01990
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/20241125/e0ecb4a2/attachment-0001.html>
More information about the ghc-commits
mailing list