[Git][ghc/ghc][wip/T24359] Improvements
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Tue Nov 19 16:11:22 UTC 2024
Simon Peyton Jones pushed to branch wip/T24359 at Glasgow Haskell Compiler / GHC
Commits:
8692ff0e by Simon Peyton Jones at 2024-11-19T16:10:58+00:00
Improvements
- - - - -
5 changed files:
- compiler/GHC/HsToCore/Binds.hs
- compiler/GHC/Rename/Bind.hs
- compiler/GHC/Tc/Gen/Sig.hs
- compiler/GHC/Tc/TyCl/Instance.hs
- compiler/Language/Haskell/Syntax/Binds.hs
Changes:
=====================================
compiler/GHC/HsToCore/Binds.hs
=====================================
@@ -842,19 +842,26 @@ dsSpec mb_poly_rhs (SpecPragE { spe_poly_id = poly_id
| otherwise
= 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 <- do { ds_call <- dsLExpr the_call
- ; return $ \ poly_id poly_rhs ->
- mkLetNonRec (localiseId poly_id) poly_rhs $
- mkLets ds_rhs_binds $
- core_call }
+ do { dflags <- getDynFlags
+ ; ds_call <- dsLExpr the_call
+ ; let simpl_opts = initSimpleOpts dflags
+ core_call = mkLets ds_lhs_binds $
+ drop_cast $
+ simpleOptExpr simpl_opts $
+ ds_call
+
+ mk_spec_call poly_id poly_rhs
+ = mkLetNonRec (localiseId poly_id) poly_rhs $
+ mkLets ds_rhs_binds $
+ core_call
; finishSpecPrag mb_poly_rhs
(tv_bndrs ++ lhs_evs ++ id_bndrs) core_call
(tv_bndrs ++ rhs_evs ++ id_bndrs) mk_spec_call
inl }
+ where
+ drop_cast (Cast e _) = drop_cast e
+ drop_cast e = e
failBecauseOfClassOp :: Id -> DsM (Maybe a)
-- There is no point in trying to specialise a class op
=====================================
compiler/GHC/Rename/Bind.hs
=====================================
@@ -68,13 +68,9 @@ import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Types.CompleteMatch
-import GHC.Types.Unique.Set
import GHC.Data.Maybe ( orElse, mapMaybe )
import GHC.Data.List.SetOps ( findDupsEq )
-import GHC.Data.Graph.Directed ( SCC(..) )
-import GHC.Data.Bag
-import GHC.Data.Maybe ( orElse )
import GHC.Data.OrdList
=====================================
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, (<.>), hsWrapperHasNoBinders )
+import GHC.Tc.Types.Evidence( HsWrapper, (<.>) )
import GHC.Tc.Types.Constraint
import GHC.Tc.Zonk.TcType
@@ -62,7 +62,6 @@ import GHC.Core.Multiplicity
import GHC.Core.Predicate
import GHC.Core.Coercion( mkCoVarCo )
import GHC.Core.TyCo.Rep( mkNakedFunTy )
-import GHC.Core.TyCon( isTypeFamilyTyCon )
import GHC.Types.Var
import GHC.Types.Var.Set
@@ -872,7 +871,7 @@ tcSpecPrags poly_id prag_sigs
--------------
tcSpecPrag :: TcId -> Sig GhcRn -> TcM [TcSpecPrag]
tcSpecPrag poly_id prag@(SpecSig _ fun_name hs_tys inl)
--- See Note [Handling SPECIALISE pragmas]
+-- See Note [Handling old-form SPECIALISE pragmas]
--
-- The Name fun_name in the SpecSig may not be the same as that of the poly_id
-- Example: SPECIALISE for a class method: the Name in the SpecSig is
@@ -906,9 +905,7 @@ tcSpecPrag poly_id (SpecSigE nm bndrs spec_e inl)
; tcExtendNameTyVarEnv [(tyVarName tv, tv) | tv <- tv_bndrs] $
tcExtendIdEnv id_bndrs $
do { (L loc spec_e', rho) <- tcInferRho spec_e
- ; return (id_bndrs, L loc (unwrap_hs_expr spec_e'), rho) } }
- -- unwrap_hs_expr: if the expression looks like (e |> co), simply drop `co`
- -- ToDo: document this
+ ; return (id_bndrs, L loc spec_e', rho) } }
-- Solve unification constraints
-- c.f. Note [The SimplifyRule Plan] step 1
@@ -963,32 +960,20 @@ tcSpecPrag poly_id (SpecSigE nm bndrs spec_e inl)
, spe_rhs_ev_bndrs = rhs_evs
, spe_rhs_binds = rhs_binds
, spe_inl = inl }] }
- where
- unwrap_hs_expr e
-{-
- | ExprWithTySig _ (L _ inner_e) _ <- e
- = unwrap_hs_expr inner_e
- | XExpr (WrapExpr wrap inner_e) <- e
- , hsWrapperHasNoBinders wrap
- = unwrap_hs_expr inner_e
- | otherwise
--}
- = e
-
tcSpecPrag _ prag = pprPanic "tcSpecPrag" (ppr prag)
--------------
tcSpecWrapper :: UserTypeCtxt -> TcType -> TcType -> TcM HsWrapper
-- A simpler variant of tcSubType, used for SPECIALISE pragmas
--- See Note [Handling SPECIALISE pragmas], wrinkle 1
+-- See Note [Handling old-form SPECIALISE pragmas], wrinkle 1
tcSpecWrapper ctxt poly_ty spec_ty
= do { (sk_wrap, inst_wrap)
<- tcSkolemise Shallow ctxt spec_ty $ \spec_tau ->
do { (inst_wrap, tau) <- topInstantiate orig poly_ty
; _ <- unifyType Nothing spec_tau tau
-- Deliberately ignore the evidence
- -- See Note [Handling SPECIALISE pragmas],
+ -- See Note [Handling old-form SPECIALISE pragmas],
-- wrinkle (2)
; return inst_wrap }
; return (sk_wrap <.> inst_wrap) }
@@ -1520,15 +1505,14 @@ getRuleQuantCts wc
= False
| otherwise
= case classifyPredType (ctPred ct) of
- EqPred _ t1 t2
- | not (ok_eq t1 t2)
+ EqPred {}
-> False -- Note [RULE quantification over equalities]
_ -> tyCoVarsOfCt ct `disjointVarSet` skol_tvs
- ok_eq t1 t2
- | t1 `tcEqType` t2 = False -- Our solving step may have turned it into Refl
- | otherwise = True
-
+-- ok_eq t1 t2
+-- | t1 `tcEqType` t2 = False -- Our solving step may have turned it into Refl
+-- | otherwise = True
+--
-- is_fun_app t1 || is_fun_app t2
--
-- is_fun_app ty -- ty is of form (F tys) where F is a type function
=====================================
compiler/GHC/Tc/TyCl/Instance.hs
=====================================
@@ -2178,7 +2178,7 @@ mk_meth_spec_prags :: Id -> [LTcSpecPrag] -> [LTcSpecPrag] -> TcSpecPrags
-- * spec_prags_from_inst: derived from {-# SPECIALISE instance :: <blah> #-}
-- These ones have the dfun inside, but [perhaps surprisingly]
-- the correct wrapper.
- -- See Note [Handling SPECIALISE pragmas] in GHC.Tc.Gen.Bind
+ -- See Note [Handling old-form SPECIALISE pragmas] in GHC.Tc.Gen.Bind
mk_meth_spec_prags meth_id spec_inst_prags spec_prags_for_me
= SpecPrags (spec_prags_for_me ++ spec_prags_from_inst)
where
=====================================
compiler/Language/Haskell/Syntax/Binds.hs
=====================================
@@ -370,7 +370,7 @@ data Sig pass
-- | A new-form specialisation pragma (see GHC Proposal #493)
-- e.g. {-# SPECIALISE f @Int 1 :: Int -> Int #-}
- -- See Note [Overview of SPECIALISE pramgas]
+ -- See Note [Overview of SPECIALISE pragmas]
| SpecSigE (XSpecSigE pass)
(RuleBndrs pass)
(LHsExpr pass) -- Expression to specialise
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8692ff0e19e564a8fb1956670c584bec4637164e
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8692ff0e19e564a8fb1956670c584bec4637164e
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/20241119/446d0d7b/attachment-0001.html>
More information about the ghc-commits
mailing list