[Git][ghc/ghc][wip/T21623] More wibbles
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Tue Aug 23 11:46:48 UTC 2022
Simon Peyton Jones pushed to branch wip/T21623 at Glasgow Haskell Compiler / GHC
Commits:
8812d764 by Simon Peyton Jones at 2022-08-23T12:48:06+01:00
More wibbles
- - - - -
10 changed files:
- compiler/GHC/Builtin/Types.hs
- compiler/GHC/Core/Coercion.hs
- compiler/GHC/Core/Coercion/Opt.hs
- compiler/GHC/Core/Opt/Arity.hs
- compiler/GHC/Core/TyCo/Rep.hs
- compiler/GHC/Core/TyCon.hs
- compiler/GHC/Core/Type.hs
- compiler/GHC/Iface/Type.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Instance/Class.hs
Changes:
=====================================
compiler/GHC/Builtin/Types.hs
=====================================
@@ -183,7 +183,6 @@ import GHC.Settings.Constants ( mAX_TUPLE_SIZE, mAX_CTUPLE_SIZE, mAX_SUM_SIZE )
import GHC.Unit.Module ( Module )
import GHC.Core.Type
import qualified GHC.Core.TyCo.Rep as TyCoRep (Type(TyConApp))
-import GHC.Core.TyCo.Rep ( RuntimeRepType )
import GHC.Types.RepType
import GHC.Core.DataCon
import GHC.Core.ConLike
@@ -521,20 +520,6 @@ tupleRepDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "TupleRep
sumRepDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "SumRep") sumRepDataConKey sumRepDataCon
boxedRepDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "BoxedRep") boxedRepDataConKey boxedRepDataCon
--- See Note [Wiring in RuntimeRep]
-runtimeRepSimpleDataConNames :: [Name]
-runtimeRepSimpleDataConNames
- = zipWith3Lazy mk_special_dc_name
- [ fsLit "IntRep"
- , fsLit "Int8Rep", fsLit "Int16Rep", fsLit "Int32Rep", fsLit "Int64Rep"
- , fsLit "WordRep"
- , fsLit "Word8Rep", fsLit "Word16Rep", fsLit "Word32Rep", fsLit "Word64Rep"
- , fsLit "AddrRep"
- , fsLit "FloatRep", fsLit "DoubleRep"
- ]
- runtimeRepSimpleDataConKeys
- runtimeRepSimpleDataCons
-
vecCountTyConName :: Name
vecCountTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "VecCount") vecCountTyConKey vecCountTyCon
@@ -1505,8 +1490,6 @@ constraintKindTyCon
constraintKindTyConName :: Name
constraintKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Constraint")
constraintKindTyConKey constraintKindTyCon
--- Old comment: todo
--- 'TyCon.isConstraintKindCon' assumes that this is an AlgTyCon!
typeToTypeKind, constraintKind :: Kind
constraintKind = mkTyConTy constraintKindTyCon
@@ -1694,6 +1677,20 @@ runtimeRepSimpleDataCons
mk_runtime_rep_dc primrep name
= pcSpecialDataCon name [] runtimeRepTyCon (RuntimeRep (\_ -> [primrep]))
+-- See Note [Wiring in RuntimeRep]
+runtimeRepSimpleDataConNames :: [Name]
+runtimeRepSimpleDataConNames
+ = zipWith3Lazy mk_special_dc_name
+ [ fsLit "IntRep"
+ , fsLit "Int8Rep", fsLit "Int16Rep", fsLit "Int32Rep", fsLit "Int64Rep"
+ , fsLit "WordRep"
+ , fsLit "Word8Rep", fsLit "Word16Rep", fsLit "Word32Rep", fsLit "Word64Rep"
+ , fsLit "AddrRep"
+ , fsLit "FloatRep", fsLit "DoubleRep"
+ ]
+ runtimeRepSimpleDataConKeys
+ runtimeRepSimpleDataCons
+
-- See Note [Wiring in RuntimeRep]
intRepDataConTy,
int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy,
=====================================
compiler/GHC/Core/Coercion.hs
=====================================
@@ -421,7 +421,7 @@ decomposeCo :: Arity -> Coercion
-> [Coercion]
decomposeCo arity co rs
= [mkSelCo r (SelTyCon n) co | (n,r) <- [0..(arity-1)] `zip` rs ]
- -- Remember, Nth is zero-indexed
+ -- Remember, SelTyCon is zero-indexed
decomposeFunCo :: HasDebugCallStack
=> Role -- Role of the input coercion
@@ -1851,7 +1851,7 @@ The KPUSH rule deals with this situation
We want to push the coercion inside the constructor application.
So we do this
- g' :: t1~t2 = Nth 0 g
+ g' :: t1~t2 = SelCo (SelTyCon 0) g
case K @t2 (x |> g' -> Maybe g') of
K (y:t2 -> Maybe t2) -> rhs
@@ -1868,7 +1868,7 @@ available at www.cis.upenn.edu/~sweirich/papers/fckinds-extended.pdf
Note [extendLiftingContextEx]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider we have datatype
- K :: \/k. \/a::k. P -> T k -- P be some type
+ K :: /\k. /\a::k. P -> T k -- P be some type
g :: T k1 ~ T k2
case (K @k1 @t1 x) |> g of
@@ -1876,7 +1876,7 @@ Consider we have datatype
We want to push the coercion inside the constructor application.
We first get the coercion mapped by the universal type variable k:
- lc = k |-> Nth 0 g :: k1~k2
+ lc = k |-> SelCo (SelTyCon 0) g :: k1~k2
Here, the important point is that the kind of a is coerced, and P might be
dependent on the existential type variable a.
=====================================
compiler/GHC/Core/Coercion/Opt.hs
=====================================
@@ -1194,7 +1194,9 @@ etaAppCo_maybe co
etaTyConAppCo_maybe :: TyCon -> Coercion -> Maybe [Coercion]
-- If possible, split a coercion
-- g :: T s1 .. sn ~ T t1 .. tn
--- into [ Nth 0 g :: s1~t1, ..., Nth (n-1) g :: sn~tn ]
+-- into [ SelCo (SelTyCon 0) g :: s1~t1
+-- , ...
+-- , SelCo (SelTyCon (n-1)) g :: sn~tn ]
etaTyConAppCo_maybe tc (TyConAppCo _ tc2 cos2)
= assert (tc == tc2) $ Just cos2
=====================================
compiler/GHC/Core/Opt/Arity.hs
=====================================
@@ -2728,11 +2728,11 @@ pushCoDataCon dc dc_args co
collectBindersPushingCo :: CoreExpr -> ([Var], CoreExpr)
-- Collect lambda binders, pushing coercions inside if possible
-- E.g. (\x.e) |> g g :: <Int> -> blah
--- = (\x. e |> Nth 1 g)
+-- = (\x. e |> SelCo (SelFun SelRes) g)
--
-- That is,
--
--- collectBindersPushingCo ((\x.e) |> g) === ([x], e |> Nth 1 g)
+-- collectBindersPushingCo ((\x.e) |> g) === ([x], e |> SelCo (SelFun SelRes) g)
collectBindersPushingCo e
= go [] e
where
=====================================
compiler/GHC/Core/TyCo/Rep.hs
=====================================
@@ -1563,7 +1563,7 @@ their representation type (see Type.coreView and Type.predTypeRep).
This collapse is done by mkPredCo; there is no PredCo constructor
in Coercion. This is important because we need Nth to work on
predicates too:
- Nth 1 ((~) [c] g) = g
+ SelCo (SelTyCon 1) ((~) [c] g) = g
See Simplify.simplCoercionF, which generates such selections.
Note [Roles]
=====================================
compiler/GHC/Core/TyCon.hs
=====================================
@@ -45,7 +45,7 @@ module GHC.Core.TyCon(
noTcTyConScopedTyVars,
-- ** Predicates on TyCons
- isAlgTyCon, isVanillaAlgTyCon, isConstraintKindCon,
+ isAlgTyCon, isVanillaAlgTyCon,
isClassTyCon, isFamInstTyCon,
isPrimTyCon,
isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon,
@@ -2067,16 +2067,6 @@ isVanillaAlgTyCon :: TyCon -> Bool
isVanillaAlgTyCon (AlgTyCon { algTcFlavour = VanillaAlgTyCon _ }) = True
isVanillaAlgTyCon _ = False
--- | Returns @True@ for the 'TyCon' of the 'Constraint' kind.
-{-# INLINE isConstraintKindCon #-} -- See Note [Inlining coreView] in GHC.Core.Type
-isConstraintKindCon :: TyCon -> Bool
--- NB: We intentionally match on AlgTyCon, because 'constraintKindTyCon' is
--- always an AlgTyCon (see 'pcTyCon' in TysWiredIn) and the record selector
--- for 'tyConUnique' would generate unreachable code for every other data
--- constructor of TyCon (see #18026).
-isConstraintKindCon AlgTyCon { tyConUnique = u } = u == constraintKindTyConKey
-isConstraintKindCon _ = False
-
isDataTyCon :: TyCon -> Bool
-- ^ Returns @True@ for data types that are /definitely/ represented by
-- heap-allocated constructors. These are scrutinised by Core-level
=====================================
compiler/GHC/Core/Type.hs
=====================================
@@ -20,7 +20,7 @@ module GHC.Core.Type (
KindOrType, PredType, ThetaType, FRRType,
Var, TyVar, isTyVar, TyCoVar, TyCoBinder, TyCoVarBinder, TyVarBinder,
Mult, Scaled,
- KnotTied,
+ KnotTied, RuntimeRepType,
-- ** Constructing and deconstructing types
mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe, repGetTyVar_maybe,
@@ -44,7 +44,7 @@ module GHC.Core.Type (
tyConAppTyCon_maybe, tyConAppTyConPicky_maybe,
tyConAppArgs_maybe, tyConAppTyCon, tyConAppArgs,
- splitTyConApp_maybe, splitTyConAppNoSyn_maybe, splitTyConApp, tyConAppArgN,
+ splitTyConApp_maybe, splitTyConAppNoSyn_maybe, splitTyConApp,
tcSplitTyConApp_maybe,
mkForAllTy, mkForAllTys, mkInvisForAllTys, mkTyCoInvForAllTys,
@@ -241,7 +241,6 @@ module GHC.Core.Type (
tidyTyCoVarBinder, tidyTyCoVarBinders,
-- * Kinds
- isConstraintKindCon,
classifiesTypeWithValues,
isConcrete, isFixedRuntimeRepKind,
) where
@@ -299,7 +298,6 @@ import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Data.FastString
import GHC.Data.Pair
-import GHC.Data.List.SetOps
import GHC.Types.Unique ( nonDetCmpUnique )
import GHC.Data.Maybe ( orElse, isJust )
@@ -807,7 +805,7 @@ isMultiplicityVar = isMultiplicityTy . tyVarKind
-- See Note [Promoted data constructors] in GHC.Core.TyCon
-- May not be possible if `rr` is a type variable or type
-- family application
-splitRuntimeRep_maybe :: Type -> Maybe (TyCon, [Type])
+splitRuntimeRep_maybe :: RuntimeRepType -> Maybe (TyCon, [Type])
splitRuntimeRep_maybe rep
| TyConApp rr_tc args <- coreFullView rep
, isPromotedDataCon rr_tc
@@ -1637,13 +1635,6 @@ tyConAppArgs_maybe ty = case splitTyConApp_maybe ty of
tyConAppArgs :: HasCallStack => Type -> [Type]
tyConAppArgs ty = tyConAppArgs_maybe ty `orElse` pprPanic "tyConAppArgs" (ppr ty)
-tyConAppArgN :: Int -> Type -> Type
--- Executing Nth
-tyConAppArgN n ty
- = case tyConAppArgs_maybe ty of
- Just tys -> tys `getNth` n
- Nothing -> pprPanic "tyConAppArgN" (ppr n <+> ppr ty)
-
-- | Attempts to tease a type apart into a type constructor and the application
-- of a number of arguments to that constructor. Panics if that is not possible.
-- See also 'splitTyConApp_maybe'
@@ -2838,15 +2829,11 @@ nonDetCmpTypesX _ [] _ = LT
nonDetCmpTypesX _ _ [] = GT
-------------
--- | Compare two 'TyCon's. NB: This should /never/ see 'Constraint' (as
--- recognized by Kind.isConstraintKindCon) which is considered a synonym for
--- 'Type' in Core.
--- See Note [Kind Constraint and kind Type] in "GHC.Core.Type".
+-- | Compare two 'TyCon's.
-- See Note [nonDetCmpType nondeterminism]
nonDetCmpTc :: TyCon -> TyCon -> Ordering
nonDetCmpTc tc1 tc2
- = assert (not (isConstraintKindCon tc1) && not (isConstraintKindCon tc2)) $
- u1 `nonDetCmpUnique` u2
+ = u1 `nonDetCmpUnique` u2
where
u1 = tyConUnique tc1
u2 = tyConUnique tc2
=====================================
compiler/GHC/Iface/Type.hs
=====================================
@@ -1787,7 +1787,7 @@ ppr_co ctxt_prec (IfaceTransCo co1 co2)
in maybeParen ctxt_prec opPrec $
vcat (ppr_co topPrec co1 : ppr_trans co2)
ppr_co ctxt_prec (IfaceSelCo d co)
- = ppr_special_co ctxt_prec (text "Nth:" <> ppr d) [co]
+ = ppr_special_co ctxt_prec (text "SelCo:" <> ppr d) [co]
ppr_co ctxt_prec (IfaceLRCo lr co)
= ppr_special_co ctxt_prec (ppr lr) [co]
ppr_co ctxt_prec (IfaceSubCo co)
=====================================
compiler/GHC/Tc/Errors/Ppr.hs
=====================================
@@ -2105,8 +2105,7 @@ pprTcSolverReportMsg ctxt
, Right ea_msg <- mk_ea_msg ctxt (Just item) level orig
= nargs_msg $$ pprTcSolverReportMsg ctxt ea_msg
- | -- pprTrace "check" (ppr ea_looks_same $$ ppr exp $$ ppr act $$ ppr ty1 $$ ppr ty2) $
- ea_looks_same ty1 ty2 exp act
+ | ea_looks_same ty1 ty2 exp act
, Right ea_msg <- mk_ea_msg ctxt (Just item) level orig
= pprTcSolverReportMsg ctxt ea_msg
@@ -2123,52 +2122,37 @@ pprTcSolverReportMsg ctxt
-- 'expected' is (TYPE rep) or (CONSTRAINT rep)
msg_for_exp_sort exp_torc exp_rep
| Just (act_torc, act_rep) <- sORTKind_maybe act
- , act_torc == exp_torc
- = -- (TYPE exp_rep) ~ (TYPE act_rep) or similar with CONSTRAINT
- case (splitRuntimeRep_maybe exp_rep, splitRuntimeRep_maybe act_rep) of
- (Just (exp_rr_tc, exp_rr_args), Just (act_rr_tc, act_rr_args))
- | exp_rr_tc == act_rr_tc -> msg_for_same_rep exp_rr_args act_rr_args
- | otherwise -> msg_for_different_rep exp_rr_tc act_rr_tc
- _ -> bale_out_msg
-
+ = -- (TYPE exp_rep) ~ (CONSTRAINT act_rep) etc
+ msg_torc_torc act_torc act_rep
| otherwise
- = -- (TYPE _) ~ (CONSTRAINT _) or (TYPE _) ~ Bool, etc
+ = -- (TYPE _) ~ Bool, etc
maybe_num_args_msg $$
- sep [ text "Expected a" <+> pp_exp_thing <> comma
+ sep [ text "Expected a" <+> ppr_torc exp_torc <> comma
, text "but" <+> case mb_thing of
Nothing -> text "found something with kind"
Just thing -> quotes (ppr thing) <+> text "has kind"
, quotes (pprWithTYPE act) ]
where
- pp_exp_thing = case exp_torc of TypeLike -> text "type";
- ConstraintLike -> text "constraint"
-
- -- (TYPE (BoxedRep lev1)) ~ (TYPE (BoxedRep lev2)); or CONSTRAINT ditto
- msg_for_same_rep exp_rr_args act_rr_args
- | [exp_lev_ty] <- exp_rr_args -- BoxedRep has exactly one arg
- , [act_lev_ty] <- act_rr_args
- , Just exp_lev <- levityType_maybe exp_lev_ty
- , Just act_lev <- levityType_maybe act_lev_ty
- = sep [ text "Expected" <+> ppr_an_lev exp_lev <+> pp_exp_thing <> comma
+ msg_torc_torc act_torc act_rep
+ | exp_torc == act_torc
+ = msg_same_torc act_torc act_rep
+ | otherwise
+ = sep [ text "Expected a" <+> ppr_torc exp_torc <> comma
, text "but" <+> case mb_thing of
- Just thing -> quotes (ppr thing) <+> text "is" <+> ppr_lev act_lev
- Nothing -> text "got" <+> ppr_an_lev act_lev <+> pp_exp_thing ]
- msg_for_same_rep _ _
- = bale_out_msg
-
- -- (TYPE (BoxedRep lev)) ~ (TYPE IntRep); or CONSTRAINT ditto
- msg_for_different_rep exp_rr_tc act_rr_tc
- = sep [ text "Expected a" <+> what <> comma
+ Nothing -> text "found a"
+ Just thing -> quotes (ppr thing) <+> text "is a"
+ <+> ppr_torc act_torc ]
+
+ msg_same_torc act_torc act_rep
+ | Just exp_doc <- describe_rep exp_rep
+ , Just act_doc <- describe_rep act_rep
+ = sep [ text "Expected" <+> exp_doc <+> ppr_torc exp_torc <> comma
, text "but" <+> case mb_thing of
- Just thing -> quotes (ppr thing)
- Nothing -> quotes (pprWithTYPE act)
- <+> text "has representation" <+> ppr_rep act_rr_tc ]
- where
- what | exp_rr_tc `hasKey` boxedRepDataConKey
- = text "boxed" <+> pp_exp_thing
- | otherwise
- = pp_exp_thing <+> text "with representation" <+> ppr_rep exp_rr_tc
+ Just thing -> quotes (ppr thing) <+> text "is"
+ Nothing -> text "got"
+ <+> act_doc <+> ppr_torc act_torc ]
+ msg_same_torc _ _ = bale_out_msg
ct_loc = errorItemCtLoc item
orig = errorItemOrigin item
@@ -2195,13 +2179,36 @@ pprTcSolverReportMsg ctxt
count_args ty = count isVisibleBinder $ fst $ splitPiTys ty
+ ppr_torc TypeLike = text "type";
+ ppr_torc ConstraintLike = text "constraint"
+
ppr_lev Lifted = text "lifted"
ppr_lev Unlifted = text "unlifted"
+
ppr_an_lev Lifted = text "a lifted"
ppr_an_lev Unlifted = text "an unlifted"
ppr_rep rep_tc = quotes (ppr (getOccName rep_tc)) -- Don't qualify
+ describe_rep :: RuntimeRepType -> Maybe SDoc
+ describe_rep rep
+ | Just (rr_tc, rr_args) <- splitRuntimeRep_maybe rep
+ = case rr_args of
+ [lev_ty] | rr_tc `hasKey` boxedRepDataConKey
+ , Just lev <- levityType_maybe lev_ty
+ -> case lev of
+ Lifted -> Just (text "a lifted")
+ Unlifted -> Just (text "a boxed unlifted")
+ [] | rr_tc `hasKey` tupleRepDataConTyConKey -> Just (text "a zero-bit")
+ | starts_with_vowel rr_tc -> Just (text "an" <+> ppr rr_tc)
+ | otherwise -> Just (text "a" <+> ppr rr_tc)
+ _ -> Nothing -- Must be TupleRep [r1..rn]
+ | otherwise = Nothing
+
+ starts_with_vowel tc
+ | (c:_) <- occNameString (getOccName tc) = c `elem` "aeiou"
+ | otherwise = False
+
pprTcSolverReportMsg _ (FixedRuntimeRepError frr_origs) =
vcat (map make_msg frr_origs)
where
=====================================
compiler/GHC/Tc/Instance/Class.hs
=====================================
@@ -654,10 +654,15 @@ matchTypeable clas [k,t] -- clas = Typeable
| k `eqType` naturalTy = doTyLit knownNatClassName t
| k `eqType` typeSymbolKind = doTyLit knownSymbolClassName t
| k `eqType` charTy = doTyLit knownCharClassName t
+
+ -- Functions
| Just (af,mult,arg,ret) <- splitFunTy_maybe t
, isVisibleAnonArg af = doFunTy clas t mult arg ret
+
+ -- Applications
| Just (tc, ks) <- splitTyConApp_maybe t -- See Note [Typeable (T a b c)]
, onlyNamedBndrsApplied tc ks = doTyConApp clas t tc ks
+
| Just (f,kt) <- splitAppTy_maybe t = doTyApp clas t f kt
matchTypeable _ _ = return NoInstance
@@ -738,14 +743,31 @@ doTyLit kc t = do { kc_clas <- tcLookupClass kc
{- Note [Typeable (T a b c)]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
For type applications we always decompose using binary application,
-via doTyApp, until we get to a *kind* instantiation. Example
- Proxy :: forall k. k -> *
+via doTyApp (building a TrApp), until we get to a *kind* instantiation
+(building a TrTyCon). We detect a pure kind instantiation using
+`onlyNamedBndrsApplied`.
+
+Example: Proxy :: forall k. k -> *
+
+ To solve Typeable (Proxy @(* -> *) Maybe) we
+
+ - First decompose with doTyApp (onlyNamedBndrsApplied is False)
+ to get (Typeable (Proxy @(* -> *))) and Typeable Maybe.
+ This step returns a TrApp.
+
+ - Then solve (Typeable (Proxy @(* -> *))) with doTyConApp
+ (onlyNamedBndrsApplied is True).
+ This step returns a TrTyCon
+
+ So the TypeRep we build is
+ TrApp (TrTyCon ("Proxy" @(*->*))) (TrTyCon "Maybe")
-To solve Typeable (Proxy (* -> *) Maybe) we
- - First decompose with doTyApp,
- to get (Typeable (Proxy (* -> *))) and Typeable Maybe
- - Then solve (Typeable (Proxy (* -> *))) with doTyConApp
+Notice also that TYPE and CONSTRAINT are distinct so, in effect, we
+allow (Typeable TYPE) and (Typeable CONSTRAINT), giving disinct TypeReps.
+This is very important: we may want to get a TypeRep for a kind like
+ Type -> Constraint
If we attempt to short-cut by solving it all at once, via
doTyConApp
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8812d7641dc563e93bcc1083ef1657d919ae5780
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8812d7641dc563e93bcc1083ef1657d919ae5780
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/20220823/788e6290/attachment-0001.html>
More information about the ghc-commits
mailing list