[Git][ghc/ghc][wip/T23109] Wibbles
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Thu Apr 4 15:54:28 UTC 2024
Simon Peyton Jones pushed to branch wip/T23109 at Glasgow Haskell Compiler / GHC
Commits:
b27f6c8c by Simon Peyton Jones at 2024-04-04T16:53:23+01:00
Wibbles
Notably: define and use mkNewTypeDictApp
- - - - -
5 changed files:
- compiler/GHC/Tc/Instance/Class.hs
- compiler/GHC/Tc/Solver/Dict.hs
- compiler/GHC/Tc/TyCl/PatSyn.hs
- compiler/GHC/Tc/Types/Evidence.hs
- compiler/GHC/Tc/Zonk/Type.hs
Changes:
=====================================
compiler/GHC/Tc/Instance/Class.hs
=====================================
@@ -40,7 +40,6 @@ import GHC.Types.Var.Env ( VarEnv )
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Types.Var
-import GHC.Types.Basic( dfunInlinePragma )
import GHC.Core.Predicate
import GHC.Core.Coercion
@@ -50,8 +49,7 @@ import GHC.Core.Make ( mkCharExpr, mkNaturalExpr, mkStringExprFS, mkCoreLams )
import GHC.Core.DataCon
import GHC.Core.TyCon
import GHC.Core.Class
-import GHC.Core.Unfold.Make( mkDFunUnfolding )
-import GHC.Core ( Expr(..), Bind(..), mkConApp )
+import GHC.Core ( Expr(..), mkConApp )
import GHC.StgToCmm.Closure ( isSmallFamily )
@@ -68,7 +66,6 @@ import Language.Haskell.Syntax.Basic (FieldLabelString(..))
import GHC.Tc.Errors.Types
import Control.Monad
-import Data.Functor
import Data.Maybe
{- *******************************************************************
@@ -224,7 +221,6 @@ match_one so canonical dfun_id mb_inst_tys warn
, iw_safe_over = so
, iw_warn = warn } } }
-
{- Note [Shortcut solving: overlap]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Suppose we have
@@ -255,13 +251,10 @@ was a puzzling example.
matchCTuple :: Class -> [Type] -> TcM ClsInstResult
matchCTuple clas tys -- (isCTupleClass clas) holds
= return (OneInst { cir_new_theta = tys
- , cir_mk_ev = tuple_ev
+ , cir_mk_ev = evDictApp clas tys
, cir_canonical = True
, cir_what = BuiltinInstance })
-- The dfun *is* the data constructor!
- where
- data_con = tyConSingleDataCon (classTyCon clas)
- tuple_ev = evDFunApp (dataConWrapId data_con) tys
{- ********************************************************************
* *
@@ -413,36 +406,21 @@ makeLitDict clas lit_ty lit_expr
, Just rep_tc <- tyConAppTyCon_maybe (classMethodTy meth)
-- If the method type is forall n. KnownNat n => SNat n
-- then rep_tc :: TyCon is SNat
- , [dict_con] <- tyConDataCons (classTyCon clas)
, [rep_con] <- tyConDataCons rep_tc
- , let pred_ty = mkClassPred clas [lit_ty]
- dict_args = [ Type lit_ty, mkConApp rep_con [Type lit_ty, lit_expr] ]
- dfun_rhs = mkConApp dict_con dict_args
- dfun_info = vanillaIdInfo `setUnfoldingInfo` mkDFunUnfolding [] dict_con dict_args
- `setInlinePragInfo` dfunInlinePragma
- dfun_occ_str :: String
- = "$f" ++ occNameString (getOccName clas) ++
- occNameString (getDFunTyKey lit_ty)
-
- = do { df_name <- newName (mkVarOcc dfun_occ_str)
- ; let dfun_id = mkLocalVar (DFunId True) df_name ManyTy pred_ty dfun_info
- ev_tm = EvExpr (Let (NonRec dfun_id dfun_rhs) (Var dfun_id))
+ = do { df_name <- newNTDFName clas
+ ; let mk_ev _ = mkNewTypeDictApp df_name clas [lit_ty] $
+ mkConApp rep_con [Type lit_ty, lit_expr]
; return $ OneInst { cir_new_theta = []
- , cir_mk_ev = \_ -> ev_tm
+ , cir_mk_ev = mk_ev
, cir_canonical = True
, cir_what = BuiltinInstance } }
- | otherwise
- = pprPanic "makeLitDict" $
- text "Unexpected evidence for" <+> ppr (className clas)
- $$ vcat (map (ppr . idType) (classMethods clas))
+ | otherwise
+ = pprPanic "makeLitDict" $
+ text "Unexpected evidence for" <+> ppr (className clas)
+ $$ vcat (map (ppr . idType) (classMethods clas))
+
-{- Here is what we are making
- let $dfKnownNat17 :: KnownNat 17
- [Unfolding = DFun :DKnownNat @17 (UnsafeSNat @17 17)]
- $dfKnownNat17 = :DKnownNat @17 (UnsafeSNat @17 17)
- in $dfKnownNat17
--}
{- ********************************************************************
* *
@@ -475,12 +453,10 @@ matchWithDict [cls, mty]
`App`
(Var sv `Cast` mkTransCo (mkSubCo co2) (mkSymCo co))
- ; tc <- tcLookupTyCon withDictClassName
- ; let Just withdict_data_con
- = tyConSingleDataCon_maybe tc -- "Data constructor"
- -- for WithDict
- mk_ev [c] = evDataConApp withdict_data_con
- [cls, mty] [evWithDict (evTermCoercion (EvExpr c))]
+ ; wd_cls <- tcLookupClass withDictClassName
+ ; dfun_name <- newNTDFName wd_cls
+ ; let mk_ev [c] = mkNewTypeDictApp dfun_name wd_cls [cls, mty] $
+ evWithDict (evTermCoercion (EvExpr c))
mk_ev e = pprPanic "matchWithDict" (ppr e)
; return $ OneInst { cir_new_theta = [mkPrimEqPred mty inst_meth_ty]
@@ -949,21 +925,24 @@ matchDataToTag dataToTagClass [levity, dty] = do
(mkNomReflCo ManyTy)
(mkSymCo repCo)
(mkReflCo Representational intPrimTy)
- dataToTagDataCon = tyConSingleDataCon (classTyCon dataToTagClass)
- mk_ev _ = evDataConApp dataToTagDataCon
- [levity, dty]
- [methodRep `Cast` methodCo]
- -> addUsedDataCons rdr_env repTyCon -- See wrinkles DTW2 and DTW3
- $> OneInst { cir_new_theta = [] -- (Ignore stupid theta.)
- , cir_mk_ev = mk_ev
- , cir_canonical = True
- , cir_what = BuiltinInstance
- }
+ -> do { addUsedDataCons rdr_env repTyCon -- See wrinkles DTW2 and DTW3
+ ; df_name <- newNTDFName dataToTagClass
+ ; let mk_ev _ = mkNewTypeDictApp df_name dataToTagClass [levity, dty] $
+ methodRep `Cast` methodCo
+ ; pure (OneInst { cir_new_theta = [] -- (Ignore stupid theta.)
+ , cir_mk_ev = mk_ev
+ , cir_canonical = True
+ , cir_what = BuiltinInstance })}
| otherwise -> pure NoInstance
matchDataToTag _ _ = pure NoInstance
+newNTDFName :: Class -> TcM Name
+newNTDFName cls = newName (mkVarOcc dfun_occ_str)
+ where
+ dfun_occ_str :: String
+ dfun_occ_str = "$f" ++ occNameString (getOccName cls)
{- ********************************************************************
* *
@@ -1011,8 +990,8 @@ doFunTy clas ty mult arg_ty ret_ty
, cir_what = BuiltinInstance }
where
preds = map (mk_typeable_pred clas) [mult, arg_ty, ret_ty]
- mk_ev [mult_ev, arg_ev, ret_ev] = evTypeable ty $
- EvTypeableTrFun (EvExpr mult_ev) (EvExpr arg_ev) (EvExpr ret_ev)
+ mk_ev [mult_ev, arg_ev, ret_ev]
+ = evTypeable ty $ EvTypeableTrFun (EvExpr mult_ev) (EvExpr arg_ev) (EvExpr ret_ev)
mk_ev _ = panic "GHC.Tc.Instance.Class.doFunTy"
@@ -1164,21 +1143,21 @@ if you'd written
***********************************************************************-}
-- See also Note [The equality types story] in GHC.Builtin.Types.Prim
-matchEqualityInst :: Class -> [Type] -> (DataCon, Role, Type, Type)
+matchEqualityInst :: Class -> [Type] -> (Role, Type, Type)
-- Precondition: `cls` satisfies GHC.Core.Predicate.isEqualityClass
-- See Note [Solving equality classes] in GHC.Tc.Solver.Dict
matchEqualityInst cls args
| cls `hasKey` eqTyConKey -- Solves (t1 ~ t2)
, [_,t1,t2] <- args
- = (eqDataCon, Nominal, t1, t2)
+ = (Nominal, t1, t2)
| cls `hasKey` heqTyConKey -- Solves (t1 ~~ t2)
, [_,_,t1,t2] <- args
- = (heqDataCon, Nominal, t1, t2)
+ = (Nominal, t1, t2)
| cls `hasKey` coercibleTyConKey -- Solves (Coercible t1 t2)
, [_, t1, t2] <- args
- = (coercibleDataCon, Representational, t1, t2)
+ = (Representational, t1, t2)
| otherwise -- Does not satisfy the precondition
= pprPanic "matchEqualityInst" (ppr (mkClassPred cls args))
=====================================
compiler/GHC/Tc/Solver/Dict.hs
=====================================
@@ -405,14 +405,14 @@ solveEqualityDict :: CtEvidence -> Class -> [Type] -> SolverStage Void
solveEqualityDict ev cls tys
| CtWanted { ctev_dest = dest } <- ev
= Stage $
- do { let (data_con, role, t1, t2) = matchEqualityInst cls tys
+ do { let (role, t1, t2) = matchEqualityInst cls tys
-- Unify t1~t2, putting anything that can't be solved
-- immediately into the work list
; (co, _, _) <- wrapUnifierTcS ev role $ \uenv ->
uType uenv t1 t2
-- Set d :: (t1~t2) = Eq# co
; setWantedEvTerm dest True $
- evDataConApp data_con tys [Coercion co]
+ evDictApp cls tys [Coercion co]
; stopWith ev "Solved wanted lifted equality" }
| CtGiven { ctev_evar = ev_id, ctev_loc = loc } <- ev
@@ -823,7 +823,7 @@ shortCutSolver dflags ev_w ev_i
-- Emit work for subgoals but use our local cache
-- so we can solve recursive dictionaries.
- ; let ev_tm = mk_ev (map getEvExpr evc_vs)
+ ; let ev_tm = mk_ev (map getEvExpr evc_vs)
ev_binds' = extendEvBinds ev_binds $
mkWantedEvBind (ctEvEvId ev) canonical ev_tm
=====================================
compiler/GHC/Tc/TyCl/PatSyn.hs
=====================================
@@ -202,15 +202,15 @@ mkProvEvidence ev_id
hetero_tys = [k1, k2, ty1, ty2]
= case r of
ReprEq | is_homo
- -> Just ( mkClassPred coercibleClass homo_tys
- , evDataConApp coercibleDataCon homo_tys eq_con_args )
+ -> Just ( mkClassPred coercibleClass homo_tys
+ , evDictApp coercibleClass homo_tys eq_con_args )
| otherwise -> Nothing
NomEq | is_homo
- -> Just ( mkClassPred eqClass homo_tys
- , evDataConApp eqDataCon homo_tys eq_con_args )
+ -> Just ( mkClassPred eqClass homo_tys
+ , evDictApp eqClass homo_tys eq_con_args )
| otherwise
- -> Just ( mkClassPred heqClass hetero_tys
- , evDataConApp heqDataCon hetero_tys eq_con_args )
+ -> Just ( mkClassPred heqClass hetero_tys
+ , evDictApp heqClass hetero_tys eq_con_args )
| otherwise
= Just (pred, EvExpr (evId ev_id))
=====================================
compiler/GHC/Tc/Types/Evidence.hs
=====================================
@@ -27,7 +27,7 @@ module GHC.Tc.Types.Evidence (
-- * EvTerm (already a CoreExpr)
EvTerm(..), EvExpr,
- evId, evCoercion, evCast, evDFunApp, evDataConApp, evSelector,
+ evId, evCoercion, evCast, evDFunApp, evDictApp, mkNewTypeDictApp, evSelector,
mkEvCast, evVarsOfTerm, mkEvScSelectors, evTypeable, findNeededEvVars,
evTermCoercion, evTermCoercion_maybe,
@@ -50,27 +50,34 @@ module GHC.Tc.Types.Evidence (
import GHC.Prelude
-import GHC.Types.Unique.DFM
-import GHC.Types.Unique.FM
-import GHC.Types.Var
-import GHC.Types.Id( idScaledType )
+import GHC.Tc.Utils.TcType
+
+import GHC.Core
import GHC.Core.Coercion.Axiom
import GHC.Core.Coercion
import GHC.Core.Ppr () -- Instance OutputableBndr TyVar
-import GHC.Tc.Utils.TcType
+import GHC.Core.Unfold.Make( mkDFunUnfolding )
import GHC.Core.Type
import GHC.Core.TyCon
-import GHC.Core.DataCon ( DataCon, dataConWrapId )
-import GHC.Builtin.Names
+import GHC.Core.Class( classTyCon )
+import GHC.Core.DataCon ( isNewDataCon, dataConWrapId )
+import GHC.Core.Class (Class, classSCSelId )
+import GHC.Core.FVs ( exprSomeFreeVars )
+import GHC.Core.InstEnv ( Canonical )
+
+
+import GHC.Types.Unique.DFM
+import GHC.Types.Unique.FM
+import GHC.Types.Var
+import GHC.Types.Id( idScaledType )
+import GHC.Types.Id.Info
import GHC.Types.Var.Env
import GHC.Types.Var.Set
import GHC.Core.Predicate
import GHC.Types.Basic
+import GHC.Types.Name( Name )
-import GHC.Core
-import GHC.Core.Class (Class, classSCSelId )
-import GHC.Core.FVs ( exprSomeFreeVars )
-import GHC.Core.InstEnv ( Canonical )
+import GHC.Builtin.Names
import GHC.Utils.Misc
import GHC.Utils.Panic
@@ -529,8 +536,51 @@ evCast et tc | isReflCo tc = EvExpr et
evDFunApp :: DFunId -> [Type] -> [EvExpr] -> EvTerm
evDFunApp df tys ets = EvExpr $ Var df `mkTyApps` tys `mkApps` ets
-evDataConApp :: DataCon -> [Type] -> [EvExpr] -> EvTerm
-evDataConApp dc tys ets = evDFunApp (dataConWrapId dc) tys 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
+ Nothing -> pprPanic "evDictApp" (ppr cls)
+
+mkNewTypeDictApp :: Name -> Class -> [Type] -> EvExpr -> EvTerm
+mkNewTypeDictApp df_name cls tys arg
+ | not (isNewTyCon tycon)
+ = evDictApp cls tys [arg]
+ | otherwise
+ = EvExpr $ Let (NonRec dfun dict_app) (Var dfun)
+ where
+ tycon = classTyCon cls
+ dict_con = tyConSingleDataCon tycon
+ pred_ty = mkClassPred cls tys
+ dict_args = map Type tys ++ [arg]
+ dict_app = mkConApp dict_con dict_args
+ dfun = mkLocalVar (DFunId True) df_name ManyTy pred_ty dfun_info
+ unf = mkDFunUnfolding [] dict_con dict_args
+ dfun_info = vanillaIdInfo `setUnfoldingInfo` unf
+ `setInlinePragInfo` dfunInlinePragma
+
+{- Here is what we are making:
+ let $fKnownNat :: KnownNat 17
+ {-# Unfolding = DFun :DKnownNat @17 (UnsafeSNat @17 17) #-}
+ $fKnownNat = :DKnownNat @17 (UnsafeSNat @17 17)
+ in $fKnownNat
+
+Here we have introduced a funny extra binding:
+
+* KnownNat is a newtype class
+
+* $fKnownNat is a full DFun, with a DFun unfolding. So
+ - it does not inline;
+ - it interacts nicely with the class selector
+
+* :DKnowNat, the data construtor, will inline to a cast right away
+ But we don't want that to be visible to clients of this constraint
+
+All this is important for any newtype class; so evDictApp checks
+that it is not used for newtype classes.
+-}
-- Selector id plus the types at which it
-- should be instantiated, used for HasField
=====================================
compiler/GHC/Tc/Zonk/Type.hs
=====================================
@@ -76,8 +76,8 @@ import GHC.Utils.Misc
import GHC.Utils.Monad
import GHC.Utils.Panic
-import GHC.Core.Multiplicity
import GHC.Core
+import GHC.Core.Multiplicity
import GHC.Core.Predicate
import GHC.Types.Name
@@ -597,7 +597,23 @@ zonkIdBndrX v
zonkIdBndr :: TcId -> ZonkTcM Id
zonkIdBndr v
= do { Scaled w' ty' <- zonkScaledTcTypeToTypeX (idScaledType v)
- ; return $ setIdMult (setIdType v ty') w' }
+ ; v' <- if isLocalId v && hasCoreUnfolding unf -- Local DFuns are like this
+ then do { unf' <- zonkUnfolding unf
+ ; return (setIdUnfolding v unf') }
+ else return v
+ ; return $ setIdMult (setIdType v' ty') w' }
+ where
+ unf = realIdUnfolding v
+
+zonkUnfolding :: Unfolding -> ZonkTcM Unfolding
+zonkUnfolding unf@(CoreUnfolding { uf_tmpl = tmpl })
+ = do { tmpl' <- zonkCoreExpr tmpl
+ ; return (unf { uf_tmpl = tmpl'}) }
+zonkUnfolding unf@(DFunUnfolding { df_bndrs = bndrs, df_args = args })
+ = runZonkBndrT (zonkCoreBndrsX bndrs) $ \ bndrs' ->
+ do { args' <- mapM zonkCoreExpr args
+ ; return (unf { df_bndrs = bndrs', df_args = args'}) }
+zonkUnfolding unf = return unf
zonkIdBndrs :: [TcId] -> ZonkTcM [Id]
zonkIdBndrs ids = mapM zonkIdBndr ids
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b27f6c8cc59bf576089c3c66ab0bed174aa65e6e
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b27f6c8cc59bf576089c3c66ab0bed174aa65e6e
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/20240404/57db65cc/attachment-0001.html>
More information about the ghc-commits
mailing list