[Git][ghc/ghc][wip/T23109] More wibbbles
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Tue May 14 17:00:31 UTC 2024
Simon Peyton Jones pushed to branch wip/T23109 at Glasgow Haskell Compiler / GHC
Commits:
36bbc731 by Simon Peyton Jones at 2024-05-13T23:42:38+01:00
More wibbbles
- - - - -
10 changed files:
- compiler/GHC/Core/TyCon.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/Tc/Gen/Bind.hs
- compiler/GHC/Tc/Instance/Class.hs
- compiler/GHC/Tc/Instance/Family.hs
- compiler/GHC/Tc/Solver/Solve.hs
- compiler/GHC/Tc/Types/Evidence.hs
- compiler/GHC/Tc/Utils/TcMType.hs
- compiler/GHC/Types/Id/Make.hs
- testsuite/tests/tcplugins/CtIdPlugin.hs
Changes:
=====================================
compiler/GHC/Core/TyCon.hs
=====================================
@@ -46,8 +46,9 @@ module GHC.Core.TyCon(
noTcTyConScopedTyVars,
-- ** Predicates on TyCons
- isAlgTyCon, isVanillaAlgTyCon,
- isClassTyCon, isUnaryClassTyCon, isFamInstTyCon,
+ isAlgTyCon, isVanillaAlgTyCon, isClassTyCon,
+ isUnaryClassTyCon, isUnaryClassTyCon_maybe,
+ isFamInstTyCon,
isPrimTyCon,
isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon,
isUnboxedSumTyCon, isPromotedTupleTyCon,
@@ -2708,12 +2709,15 @@ famTyConFlav_maybe (TyCon { tyConDetails = details })
| otherwise = Nothing
isUnaryClassTyCon :: TyCon -> Bool
-isUnaryClassTyCon tc@(TyCon { tyConDetails = details })
- | AlgTyCon { algTcFlavour = flav, algTcRhs = UnaryClass {} } <- details
+isUnaryClassTyCon tc = isJust (isUnaryClassTyCon_maybe tc)
+
+isUnaryClassTyCon_maybe :: TyCon -> Maybe DataCon
+isUnaryClassTyCon_maybe tc@(TyCon { tyConDetails = details })
+ | AlgTyCon { algTcFlavour = flav, algTcRhs = UnaryClass { data_con = dc } } <- details
= assertPpr (case flav of { ClassTyCon {} -> True; _ -> False }) (ppr tc) $
- True
+ Just dc
| otherwise
- = False
+ = Nothing
-- | Is this 'TyCon' that for a class instance?
isClassTyCon :: TyCon -> Bool
=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -102,9 +102,12 @@ dsIPBinds (IPBinds ev_binds ip_binds) body
; foldrM ds_ip_bind inner ip_binds } }
where
ds_ip_bind :: LIPBind GhcTc -> CoreExpr -> DsM CoreExpr
+ -- Given (IPBind n s e), we have
+ -- n :: IP s ty, e :: ty
+ -- Use evWrapIP to convert `e` (the user-written RHS) to an IP dictionary
ds_ip_bind (L _ (IPBind n _ e)) body
= do e' <- dsLExpr e
- return (Let (NonRec n e') body)
+ return (Let (NonRec n (evWrapIP (idType n) e')) body)
-------------------------
-- caller sets location
=====================================
compiler/GHC/Tc/Gen/Bind.hs
=====================================
@@ -283,7 +283,7 @@ tcLocalBinds (HsIPBinds x (IPBinds _ ip_binds)) thing_inside
-- We don't have linear implicit parameters, yet. So the wrapper can be
-- the identity.
-- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify.
- ; return (HsIPBinds x (IPBinds ev_binds ip_binds') , idHsWrapper, result) }
+ ; return (HsIPBinds x (IPBinds ev_binds ip_binds'), idHsWrapper, result) }
where
ips = [ip | (L _ (IPBind _ (L _ ip) _)) <- ip_binds]
@@ -296,18 +296,7 @@ tcLocalBinds (HsIPBinds x (IPBinds _ ip_binds)) thing_inside
; let p = mkStrLitTy $ hsIPNameFS ip
; ip_id <- newDict ipClass [p, ty]
; expr' <- tcCheckMonoExpr expr ty
- ; let d = toDict (idType ip_id) expr'
- ; return (ip_id, (IPBind ip_id l_name d)) }
-
- toDict :: Type -- IP "x" t
- -> LHsExpr GhcTc -- def'n of IP variable
- -> LHsExpr GhcTc -- dictionary for IP
- toDict dict_ty (L loc expr)
- = L loc $ HsApp noExtField (L loc inst_con) (L loc expr)
- where
- (_, con, tys) = decomposeIP dict_ty
- inst_con = mkHsWrap (mkWpTyApps tys) $
- HsVar noExtField (noLocA (dataConWorkId con))
+ ; return (ip_id, IPBind ip_id l_name expr') }
-- Why an HsWrapper? See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify.
tcValBinds :: TopLevelFlag
=====================================
compiler/GHC/Tc/Instance/Class.hs
=====================================
@@ -12,8 +12,6 @@ import GHC.Prelude
import GHC.Driver.DynFlags
-import GHC.Core.TyCo.Rep
-
import GHC.Tc.Utils.Env
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.TcType
@@ -22,7 +20,9 @@ import GHC.Tc.Instance.Typeable
import GHC.Tc.Utils.TcMType
import GHC.Tc.Types.Evidence
import GHC.Tc.Types.Origin (InstanceWhat (..), SafeOverlapping)
-import GHC.Tc.Instance.Family( tcGetFamInstEnvs, tcInstNewTyCon_maybe, tcLookupDataFamInst )
+import GHC.Tc.Instance.Family( tcGetFamInstEnvs, tcLookupDataFamInst )
+import GHC.Tc.Errors.Types
+
import GHC.Rename.Env( addUsedGRE, addUsedDataCons, DeprecationWarnings (..) )
import GHC.Builtin.Types
@@ -40,6 +40,7 @@ import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Types.Var
+import GHC.Core.TyCo.Rep
import GHC.Core.Predicate
import GHC.Core.Coercion
import GHC.Core.InstEnv
@@ -62,9 +63,7 @@ import GHC.Unit.Module.Warnings
import GHC.Hs.Extension
import Language.Haskell.Syntax.Basic (FieldLabelString(..))
-import GHC.Tc.Errors.Types
import Control.Monad
-
import Data.Maybe
{- *******************************************************************
@@ -434,29 +433,27 @@ matchWithDict [cls, mty]
| Just (dict_tc, dict_args) <- tcSplitTyConApp_maybe cls
-- Check that C is a class of the form
-- `class C a_1 ... a_n where op :: meth_ty`
- -- and in that case let
- -- co :: C t1 ..tn ~R# inst_meth_ty
- , Just (inst_meth_ty, co) <- tcInstNewTyCon_maybe dict_tc dict_args
+ , Just dict_dc <- isUnaryClassTyCon_maybe dict_tc
+ , [inst_meth_ty] <- dataConInstOrigArgTys dict_dc dict_args
= do { sv <- mkSysLocalM (fsLit "withDict_s") ManyTy mty
; k <- mkSysLocalM (fsLit "withDict_k") ManyTy (mkInvisFunTy cls openAlphaTy)
+ ; wd_cls <- tcLookupClass withDictClassName
- -- Given co2 : mty ~N# inst_meth_ty, construct the method of
+ -- Given ev_expr : mty ~N# inst_meth_ty, construct the method of
-- the WithDict dictionary:
--
-- \@(r :: RuntimeRep) @(a :: TYPE r) (sv :: mty) (k :: cls => a) ->
- -- k (sv |> (sub co ; sym co2))
- ; let evWithDict co2 =
- mkCoreLams [ runtimeRep1TyVar, openAlphaTyVar, sv, k ] $
- Var k
- `App`
- (Var sv `Cast` mkTransCo (mkSubCo co2) (mkSymCo co))
-
- ; wd_cls <- tcLookupClass withDictClassName
- ; let mk_ev [c] = evDictApp wd_cls [cls, mty] $
- [evWithDict (evTermCoercion (EvExpr c))]
+ -- k (MkC tys (sv |> sub co2))
+ ; let evWithDict ev_expr
+ = mkCoreLams [ runtimeRep1TyVar, openAlphaTyVar, sv, k ] $
+ Var k `App` (evWrapUnaryDict dict_tc dict_args meth_arg)
+ where
+ meth_arg = Var sv `Cast` mkSubCo (evExprCoercion ev_expr)
+
+ ; let mk_ev [c] = evDictApp wd_cls [cls, mty] [evWithDict c]
mk_ev e = pprPanic "matchWithDict" (ppr e)
- ; return $ OneInst { cir_new_theta = [mkPrimEqPred mty inst_meth_ty]
+ ; return $ OneInst { cir_new_theta = [mkPrimEqPred mty (scaledThing inst_meth_ty)]
, cir_mk_ev = mk_ev
, cir_canonical = False -- See (WD6) in Note [withDict]
, cir_what = BuiltinInstance }
@@ -509,11 +506,11 @@ as if the following instance declaration existed:
instance (mty ~# inst_meth_ty) => WithDict (C t1..tn) mty where
withDict = \@{rr} @(r :: TYPE rr) (sv :: mty) (k :: C t1..tn => r) ->
- k (sv |> (sub co2 ; sym co))
+ k (MkC (sv |> sub co)))
That is, it matches on the first (constraint) argument of C; if C is
a single-method class, the instance "fires" and emits an equality
-constraint `mty ~ inst_meth_ty`, where `inst_meth_ty` is `meth_ty[ti/ai]`.
+constraint `mty ~# inst_meth_ty`, where `inst_meth_ty` is `meth_ty[ti/ai]`.
The coercion `co2` witnesses the equality `mty ~ inst_meth_ty`.
The coercion `co` is a newtype coercion that coerces from `C t1 ... tn`
@@ -1260,17 +1257,14 @@ matchHasField dflags short_cut clas tys
; let theta = mkPrimEqPred sel_ty (mkVisFunTyMany r_ty a_ty) : preds
-- Use the equality proof to cast the selector Id to
- -- type (r -> a), then use the newtype coercion to cast
- -- it to a HasField dictionary.
- mk_ev (ev1:evs) = evSelector sel_id tvs evs `evCast` co
- where
- co = mkSubCo (evTermCoercion (EvExpr ev1))
- `mkTransCo` mkSymCo co2
+ -- type (r -> a), then use evWrapUnaryDict to turn it
+ -- into a HasField dictionary.
+ mk_ev (ev1:evs) = EvExpr $
+ evWrapUnaryDict (classTyCon clas) tys $
+ evCast (evSelector sel_id tvs evs)
+ (mkSubCo (evExprCoercion ev1))
mk_ev [] = panic "matchHasField.mk_ev"
- Just (_, co2) = tcInstNewTyCon_maybe (classTyCon clas)
- tys
-
tvs = mkTyVarTys (map snd tv_prs)
-- The selector must not be "naughty" (i.e. the field
=====================================
compiler/GHC/Tc/Instance/Family.hs
=====================================
@@ -5,7 +5,7 @@ module GHC.Tc.Instance.Family (
FamInstEnvs, tcGetFamInstEnvs,
checkFamInstConsistency, tcExtendLocalFamInstEnv,
tcLookupDataFamInst, tcLookupDataFamInst_maybe,
- tcInstNewTyCon_maybe, tcTopNormaliseNewTypeTF_maybe,
+ tcTopNormaliseNewTypeTF_maybe,
-- * Injectivity
reportInjectivityErrors, reportConflictingInjectivityErrs
@@ -368,15 +368,6 @@ getFamInsts hpt_fam_insts mod
-}
--- | If @co :: T ts ~ rep_ty@ then:
---
--- > instNewTyCon_maybe T ts = Just (rep_ty, co)
---
--- Checks for a newtype, and for being saturated
--- Just like Coercion.instNewTyCon_maybe, but returns a TcCoercion
-tcInstNewTyCon_maybe :: TyCon -> [TcType] -> Maybe (TcType, TcCoercion)
-tcInstNewTyCon_maybe = instNewTyCon_maybe
-
-- | Like 'tcLookupDataFamInst_maybe', but returns the arguments back if
-- there is no data family to unwrap.
-- Returns a Representational coercion
=====================================
compiler/GHC/Tc/Solver/Solve.hs
=====================================
@@ -545,8 +545,8 @@ finish_rewrite ev@(CtGiven { ctev_evar = old_evar, ctev_loc = loc })
; continueWith new_ev }
where
-- mkEvCast optimises ReflCo
- new_tm = mkEvCast (evId old_evar)
- (downgradeRole Representational (ctEvRole ev) co)
+ new_tm = EvExpr $ mkEvCast (evId old_evar) $
+ downgradeRole Representational (ctEvRole ev) co
finish_rewrite ev@(CtWanted { ctev_dest = dest
, ctev_loc = loc
@@ -554,9 +554,9 @@ finish_rewrite ev@(CtWanted { ctev_dest = dest
(Reduction co new_pred) new_rewriters
= do { mb_new_ev <- newWanted loc rewriters' new_pred
; massert (coercionRole co == ctEvRole ev)
- ; setWantedEvTerm dest True $
- mkEvCast (getEvExpr mb_new_ev)
- (downgradeRole Representational (ctEvRole ev) (mkSymCo co))
+ ; setWantedEvTerm dest True $ EvExpr $
+ mkEvCast (getEvExpr mb_new_ev) $
+ downgradeRole Representational (ctEvRole ev) (mkSymCo co)
; case mb_new_ev of
Fresh new_ev -> continueWith new_ev
Cached _ -> stopWith ev "Cached wanted" }
=====================================
compiler/GHC/Tc/Types/Evidence.hs
=====================================
@@ -29,9 +29,10 @@ module GHC.Tc.Types.Evidence (
EvTerm(..), EvExpr,
evId, evCoercion, evCast, evDFunApp, evDictApp, evSelector, evDelayedError,
mkEvCast, evVarsOfTerm, mkEvScSelectors, evTypeable, findNeededEvVars,
- decomposeIP, evWrapIP, evUnwrapIP,
+ decomposeIP, evWrapIP, evUnwrapIP, evWrapUnaryDict,
evTermCoercion, evTermCoercion_maybe,
+ evExprCoercion, evExprCoercion_maybe,
EvCallStack(..),
EvTypeable(..),
@@ -527,20 +528,18 @@ evCoercion :: TcCoercion -> EvTerm
evCoercion co = EvExpr (Coercion co)
-- | d |> co
-evCast :: EvExpr -> TcCoercion -> EvTerm
-evCast et tc | isReflCo tc = EvExpr et
- | otherwise = EvExpr (Cast et tc)
+evCast :: EvExpr -> TcCoercion -> EvExpr
+evCast et tc | isReflCo tc = et
+ | otherwise = Cast et tc
-- Dictionary instance application
evDFunApp :: DFunId -> [Type] -> [EvExpr] -> EvTerm
evDFunApp df tys ets = EvExpr $ Var df `mkTyApps` tys `mkApps` ets
evDictApp :: Class -> [Type] -> [EvExpr] -> EvTerm
--- Only for classes that are not represented by a newtype
evDictApp cls tys args
= case tyConSingleDataCon_maybe (classTyCon cls) of
- Just dc -> -- assertPpr (not (isNewDataCon dc)) (ppr cls) $
- evDFunApp (dataConWrapId dc) tys args
+ Just dc -> evDFunApp (dataConWrapId dc) tys args
Nothing -> pprPanic "evDictApp" (ppr cls)
-- Selector id plus the types at which it
@@ -810,14 +809,13 @@ Important Details:
-}
-mkEvCast :: EvExpr -> TcCoercion -> EvTerm
+mkEvCast :: EvExpr -> TcCoercion -> EvExpr
mkEvCast ev lco
| assertPpr (coercionRole lco == Representational)
(vcat [text "Coercion of wrong role passed to mkEvCast:", ppr ev, ppr lco]) $
- isReflCo lco = EvExpr ev
+ isReflCo lco = ev
| otherwise = evCast ev lco
-
mkEvScSelectors -- Assume class (..., D ty, ...) => C a b
:: Class -> [TcType] -- C ty1 ty2
-> [(TcPredType, -- D ty[ty1/a,ty2/b]
@@ -837,19 +835,26 @@ isEmptyTcEvBinds :: TcEvBinds -> Bool
isEmptyTcEvBinds (EvBinds b) = isEmptyBag b
isEmptyTcEvBinds (TcEvBinds {}) = panic "isEmptyTcEvBinds"
+evExprCoercion_maybe :: EvExpr -> Maybe TcCoercion
+-- Applied only to EvExprs of type (s~t)
+-- See Note [Coercion evidence terms]
+evExprCoercion_maybe (Var v) = return (mkCoVarCo v)
+evExprCoercion_maybe (Coercion co) = return co
+evExprCoercion_maybe (Cast tm co) = do { co' <- evExprCoercion_maybe tm
+ ; return (mkCoCast co' co) }
+evExprCoercion_maybe _ = Nothing
+
+evExprCoercion :: EvExpr -> TcCoercion
+evExprCoercion tm = case evExprCoercion_maybe tm of
+ Just co -> co
+ Nothing -> pprPanic "evExprCoercion" (ppr tm)
+
evTermCoercion_maybe :: EvTerm -> Maybe TcCoercion
-- Applied only to EvTerms of type (s~t)
-- See Note [Coercion evidence terms]
evTermCoercion_maybe ev_term
- | EvExpr e <- ev_term = go e
+ | EvExpr e <- ev_term = evExprCoercion_maybe e
| otherwise = Nothing
- where
- go :: EvExpr -> Maybe TcCoercion
- go (Var v) = return (mkCoVarCo v)
- go (Coercion co) = return co
- go (Cast tm co) = do { co' <- go tm
- ; return (mkCoCast co' co) }
- go _ = Nothing
evTermCoercion :: EvTerm -> TcCoercion
evTermCoercion tm = case evTermCoercion_maybe tm of
@@ -1035,9 +1040,9 @@ evWrapIP :: PredType -> EvExpr -> EvExpr
-- et_tm :: ty
-- Return an EvTerm of type (IP s ty)
evWrapIP pred ev_tm
- = mkConApp con (map Type tys ++ [ev_tm])
+ = evWrapUnaryDict tc tys ev_tm
where
- (_, con, tys) = decomposeIP pred
+ (tc, tys) = splitTyConApp pred
evUnwrapIP :: PredType -> EvExpr -> EvExpr
-- Given pred = IP s ty
@@ -1048,6 +1053,13 @@ evUnwrapIP pred ev_tm
where
(ip_sel, _, tys) = decomposeIP pred
+evWrapUnaryDict :: TyCon -> [Type] -> EvExpr -> EvExpr
+evWrapUnaryDict tc tys meth
+ | Just dc <- isUnaryClassTyCon_maybe tc
+ = Var (dataConWrapId dc) `mkTyApps` tys `App` meth
+ | otherwise
+ = pprPanic "evWrapUnaryDict" (ppr tc)
+
----------------------------------------------------------------------
-- A datatype used to pass information when desugaring quotations
----------------------------------------------------------------------
=====================================
compiler/GHC/Tc/Utils/TcMType.hs
=====================================
@@ -1589,7 +1589,8 @@ collect_cand_qtvs_co orig_ty cur_lvl bound = go_co
go_prov dv (PhantomProv co) = go_co dv co
go_prov dv (ProofIrrelProv co) = go_co dv co
- go_prov dv (PluginProv _) = return dv
+ go_prov dv (PluginProv {}) = return dv
+ go_prov dv (UnaryClassProv {}) = return dv
go_cv :: CandidatesQTvs -> CoVar -> TcM CandidatesQTvs
go_cv dv@(DV { dv_cvs = cvs }) cv
=====================================
compiler/GHC/Types/Id/Make.hs
=====================================
@@ -503,24 +503,7 @@ mkDictSelId name clas
`setCprSigInfo` topCprSig
info = base_info `setRuleInfo` mkRuleInfo [rule]
-{-
- info | unary_cls -- Same as non-new case; ToDo: explain
- = base_info `setRuleInfo` mkRuleInfo [rule]
- `setInlinePragInfo` neverInlinePragma
- -- See Note [Single-method classes] in GHC.Tc.TyCl.Instance
- -- for why alwaysInlinePragma
- -- TODO Fix this comment!
-
- | otherwise
- = base_info `setRuleInfo` mkRuleInfo [rule]
- `setInlinePragInfo` neverInlinePragma
- `setUnfoldingInfo` mkInlineUnfoldingWithArity defaultSimpleOpts
- StableSystemSrc 1
- (mkDictSelRhs clas val_index)
- -- Add a magic BuiltinRule, but no unfolding
- -- so that the rule is always available to fire.
- -- See Note [ClassOp/DFun selection] in GHC.Tc.TyCl.Instance
--}
+ -- No unfolding for dictionary selectors
-- This is the built-in rule that goes
-- op (dfT d1 d2) ---> opT d1 d2
=====================================
testsuite/tests/tcplugins/CtIdPlugin.hs
=====================================
@@ -43,7 +43,7 @@ solver :: [String]
solver _args defs ev givens wanteds = do
let pluginCo = mkUnivCo (PluginProv "CtIdPlugin") Representational
let substEvidence ct ct' =
- evCast (ctEvExpr $ ctEvidence ct') $ pluginCo (ctPred ct') (ctPred ct)
+ EvExpr $ evCast (ctEvExpr $ ctEvidence ct') $ pluginCo (ctPred ct') (ctPred ct)
if null wanteds
then do
@@ -51,7 +51,7 @@ solver _args defs ev givens wanteds = do
newGivens <- for (zip newGivenPredTypes givens) \case
(Nothing, _) -> return Nothing
(Just pred, ct) ->
- let EvExpr expr =
+ let expr =
evCast (ctEvExpr $ ctEvidence ct) $ pluginCo (ctPred ct) pred
in Just . mkNonCanonical <$> newGiven ev (ctLoc ct) pred expr
let removedGivens =
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/36bbc7313f08cf8221c868c37c68f20f4e9e2d1b
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/36bbc7313f08cf8221c868c37c68f20f4e9e2d1b
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/20240514/1c4623b8/attachment-0001.html>
More information about the ghc-commits
mailing list