[Git][ghc/ghc][wip/T21623] Wibble Typeable binds etc
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Wed Aug 17 15:47:42 UTC 2022
Simon Peyton Jones pushed to branch wip/T21623 at Glasgow Haskell Compiler / GHC
Commits:
184a8f9d by Simon Peyton Jones at 2022-08-17T16:48:54+01:00
Wibble Typeable binds etc
- - - - -
9 changed files:
- compiler/GHC/Builtin/Names.hs
- compiler/GHC/Core/Make.hs
- compiler/GHC/Core/Map/Type.hs
- compiler/GHC/Core/Type.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Gen/HsType.hs
- compiler/GHC/Tc/Instance/Typeable.hs
- compiler/GHC/Tc/Validity.hs
- libraries/ghc-prim/GHC/Types.hs
Changes:
=====================================
compiler/GHC/Builtin/Names.hs
=====================================
@@ -258,6 +258,7 @@ basicKnownKeyNames
starKindRepName,
starArrStarKindRepName,
starArrStarArrStarKindRepName,
+ constraintKindRepName,
-- WithDict
withDictClassName,
@@ -1401,10 +1402,12 @@ typeCharTypeRepName = varQual tYPEABLE_INTERNAL (fsLit "typeCharTypeRep") type
trGhcPrimModuleName = varQual gHC_TYPES (fsLit "tr$ModuleGHCPrim") trGhcPrimModuleKey
-- Typeable KindReps for some common cases
-starKindRepName, starArrStarKindRepName, starArrStarArrStarKindRepName :: Name
-starKindRepName = varQual gHC_TYPES (fsLit "krep$*") starKindRepKey
-starArrStarKindRepName = varQual gHC_TYPES (fsLit "krep$*Arr*") starArrStarKindRepKey
-starArrStarArrStarKindRepName = varQual gHC_TYPES (fsLit "krep$*->*->*") starArrStarArrStarKindRepKey
+starKindRepName, starArrStarKindRepName,
+ starArrStarArrStarKindRepName, constraintKindRepName :: Name
+starKindRepName = varQual gHC_TYPES (fsLit "krep$*") starKindRepKey
+starArrStarKindRepName = varQual gHC_TYPES (fsLit "krep$*Arr*") starArrStarKindRepKey
+starArrStarArrStarKindRepName = varQual gHC_TYPES (fsLit "krep$*->*->*") starArrStarArrStarKindRepKey
+constraintKindRepName = varQual gHC_TYPES (fsLit "krep$Constraint") constraintKindRepKey
-- WithDict
withDictClassName :: Name
@@ -2492,14 +2495,15 @@ tr'PtrRepLiftedKey = mkPreludeMiscIdUnique 515
trLiftedRepKey = mkPreludeMiscIdUnique 516
-- KindReps for common cases
-starKindRepKey, starArrStarKindRepKey, starArrStarArrStarKindRepKey :: Unique
-starKindRepKey = mkPreludeMiscIdUnique 520
-starArrStarKindRepKey = mkPreludeMiscIdUnique 521
+starKindRepKey, starArrStarKindRepKey, starArrStarArrStarKindRepKey, constraintKindRepKey :: Unique
+starKindRepKey = mkPreludeMiscIdUnique 520
+starArrStarKindRepKey = mkPreludeMiscIdUnique 521
starArrStarArrStarKindRepKey = mkPreludeMiscIdUnique 522
+constraintKindRepKey = mkPreludeMiscIdUnique 523
-- Dynamic
toDynIdKey :: Unique
-toDynIdKey = mkPreludeMiscIdUnique 523
+toDynIdKey = mkPreludeMiscIdUnique 530
bitIntegerIdKey :: Unique
=====================================
compiler/GHC/Core/Make.hs
=====================================
@@ -1087,8 +1087,8 @@ mkAbsentErrorApp :: Type -- The type to instantiate 'a'
mkAbsentErrorApp res_ty err_msg
= mkApps (Var err_id) [ Type res_ty, err_string ]
where
- err_id | isConstraintKind (typeKind res_ty) = aBSENT_CONSTRAINT_ERROR_ID
- | otherwise = aBSENT_ERROR_ID
+ err_id | isConstraintLikeKind (typeKind res_ty) = aBSENT_CONSTRAINT_ERROR_ID
+ | otherwise = aBSENT_ERROR_ID
err_string = Lit (mkLitString err_msg)
absentErrorName, absentConstraintErrorName :: Name
=====================================
compiler/GHC/Core/Map/Type.hs
=====================================
@@ -156,9 +156,6 @@ data TypeMapX a
-- | Squeeze out any synonyms, and change TyConApps to nested AppTys. Why the
-- last one? See Note [Equality on AppTys] in GHC.Core.Type
--
--- Note, however, that we keep Constraint and Type apart here, despite the fact
--- that they are both synonyms of TYPE 'LiftedRep (see #11715).
---
-- We also keep (Eq a => a) as a FunTy, distinct from ((->) (Eq a) a).
trieMapView :: Type -> Maybe Type
trieMapView ty
@@ -168,7 +165,9 @@ trieMapView ty
= Just $ foldl' AppTy (mkTyConTy tc) tys
-- Then resolve any remaining nullary synonyms.
- | Just ty' <- tcView ty = Just ty'
+ | Just ty' <- tcView ty
+ = Just ty'
+
trieMapView _ = Nothing
instance TrieMap TypeMapX where
=====================================
compiler/GHC/Core/Type.hs
=====================================
@@ -156,8 +156,9 @@ module GHC.Core.Type (
-- ** Finding the kind of a type
typeKind, tcTypeKind, typeHasFixedRuntimeRep, argsHaveFixedRuntimeRep,
- tcIsLiftedTypeKind, isConstraintKind, tcReturnsConstraintKind,
- tcIsBoxedTypeKind, tcIsRuntimeTypeKind,
+ tcIsLiftedTypeKind,
+ isConstraintKind, isConstraintLikeKind, returnsConstraintKind,
+ tcIsBoxedTypeKind, isTypeLikeKind,
-- ** Common Kind
liftedTypeKind, unliftedTypeKind,
@@ -1662,63 +1663,6 @@ tcSplitTyConApp_maybe ty
mkTyConTy :: TyCon -> Type
mkTyConTy tycon = tyConNullaryTy tycon
--- | A key function: builds a 'TyConApp' or 'FunTy' as appropriate to
--- its arguments. Applies its arguments to the constructor from left to right.
-mkTyConApp :: TyCon -> [Type] -> Type
-mkTyConApp tycon []
- = -- See Note [Sharing nullary TyConApps] in GHC.Core.TyCon
- mkTyConTy tycon
-
-mkTyConApp tycon tys@(ty1:rest)
- | Just (af, mult, arg, res) <- tyConAppFun_maybe id tycon tys
- = FunTy { ft_af = af, ft_mult = mult, ft_arg = arg, ft_res = res }
-
- -- See Note [Using synonyms to compress types]
- | key == tYPETyConKey
- = assert (null rest) $
--- mkTYPEapp_maybe ty1 `orElse` bale_out
- case mkTYPEapp_maybe ty1 of
- Just ty -> ty -- pprTrace "mkTYPEapp:yes" (ppr ty) ty
- Nothing -> bale_out -- pprTrace "mkTYPEapp:no" (ppr bale_out) bale_out
-
- -- See Note [Using synonyms to compress types]
- | key == boxedRepDataConTyConKey
- = assert (null rest) $
--- mkBoxedRepApp_maybe ty1 `orElse` bale_out
- case mkBoxedRepApp_maybe ty1 of
- Just ty -> ty -- pprTrace "mkBoxedRepApp:yes" (ppr ty) ty
- Nothing -> bale_out -- pprTrace "mkBoxedRepApp:no" (ppr bale_out) bale_out
-
- | key == tupleRepDataConTyConKey
- = case mkTupleRepApp_maybe ty1 of
- Just ty -> ty -- pprTrace "mkTupleRepApp:yes" (ppr ty) ty
- Nothing -> bale_out -- pprTrace "mkTupleRepApp:no" (ppr bale_out) bale_out
-
- -- The catch-all case
- | otherwise
- = bale_out
- where
- key = tyConUnique tycon
- bale_out = TyConApp tycon tys
-
-
-{- Note [Care using synonyms to compress types]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Using a synonym to compress a types has a tricky wrinkle. Consider
-coreView applied to (TyConApp LiftedRep [])
-
-* coreView expands the LiftedRep synonym:
- type LiftedRep = BoxedRep Lifted
-
-* Danger: we might apply the empty substitution to the RHS of the
- synonym. And substTy calls mkTyConApp BoxedRep [Lifted]. And
- mkTyConApp compresses that back to LiftedRep. Loop!
-
-* Solution: in expandSynTyConApp_maybe, don't call substTy for nullary
- type synonyms. That's more efficient anyway.
--}
-
-
-------------------
newTyConInstRhs :: TyCon -> [Type] -> Type
-- ^ Unwrap one 'layer' of newtype on a type constructor and its
@@ -3085,13 +3029,19 @@ classifiesTypeWithValues :: Kind -> Bool
-- ^ True of a kind `TYPE _` or `CONSTRAINT _`
classifiesTypeWithValues k = isJust (sORTKind_maybe k)
-isConstraintKind :: Kind -> Bool
+isConstraintLikeKind :: Kind -> Bool
-- True of (CONSTRAINT _)
+isConstraintLikeKind kind
+ = case sORTKind_maybe kind of
+ Just (ConstraintLike, _) -> True
+ _ -> False
+
+isConstraintKind :: Kind -> Bool
+-- True of (CONSTRAINT LiftedRep)
isConstraintKind kind
- | Just (ConstraintLike, _) <- sORTKind_maybe kind
- = True
- | otherwise
- = False
+ = case sORTKind_maybe kind of
+ Just (ConstraintLike, rep) -> isLiftedRuntimeRep rep
+ _ -> False
tcIsLiftedTypeKind :: Kind -> Bool
-- ^ Is this kind equivalent to 'Type' i.e. TYPE LiftedRep?
@@ -3118,23 +3068,21 @@ tcIsBoxedTypeKind kind
-- | Is this kind equivalent to @TYPE r@ (for some unknown r)?
--
-- This considers 'Constraint' to be distinct from @*@.
-tcIsRuntimeTypeKind :: Kind -> Bool
-tcIsRuntimeTypeKind kind
- | Just (TypeLike, _) <- sORTKind_maybe kind
- = True
- | otherwise
- = False
+isTypeLikeKind :: Kind -> Bool
+isTypeLikeKind kind
+ = case sORTKind_maybe kind of
+ Just (TypeLike, _) -> True
+ _ -> False
-tcReturnsConstraintKind :: Kind -> Bool
+returnsConstraintKind :: Kind -> Bool
-- True <=> the Kind ultimately returns a Constraint
-- E.g. * -> Constraint
-- forall k. k -> Constraint
-tcReturnsConstraintKind kind
- | Just kind' <- tcView kind = tcReturnsConstraintKind kind'
-tcReturnsConstraintKind (ForAllTy _ ty) = tcReturnsConstraintKind ty
-tcReturnsConstraintKind (FunTy { ft_res = ty }) = tcReturnsConstraintKind ty
-tcReturnsConstraintKind (TyConApp tc _) = isConstraintKindCon tc
-tcReturnsConstraintKind _ = False
+returnsConstraintKind kind
+ | Just kind' <- tcView kind = returnsConstraintKind kind'
+returnsConstraintKind (ForAllTy _ ty) = returnsConstraintKind ty
+returnsConstraintKind (FunTy { ft_res = ty }) = returnsConstraintKind ty
+returnsConstraintKind kind = isConstraintLikeKind kind
--------------------------
typeLiteralKind :: TyLit -> Kind
@@ -3959,6 +3907,59 @@ e.g., during comparison.
See #17958, #20541
-}
+-- | A key function: builds a 'TyConApp' or 'FunTy' as appropriate to
+-- its arguments. Applies its arguments to the constructor from left to right.
+mkTyConApp :: TyCon -> [Type] -> Type
+mkTyConApp tycon []
+ = -- See Note [Sharing nullary TyConApps] in GHC.Core.TyCon
+ mkTyConTy tycon
+
+mkTyConApp tycon tys@(ty1:rest)
+ | Just (af, mult, arg, res) <- tyConAppFun_maybe id tycon tys
+ = FunTy { ft_af = af, ft_mult = mult, ft_arg = arg, ft_res = res }
+
+ -- See Note [Using synonyms to compress types]
+ | key == tYPETyConKey
+ , Just ty <- mkTYPEapp_maybe ty1
+ = assert (null rest) ty
+
+ | key == cONSTRAINTTyConKey
+ , Just ty <- mkCONSTRAINTapp_maybe ty1
+ = assert (null rest) ty
+
+ -- See Note [Using synonyms to compress types]
+ | key == boxedRepDataConTyConKey
+ , Just ty <- mkBoxedRepApp_maybe ty1
+ = assert (null rest) ty
+
+ | key == tupleRepDataConTyConKey
+ , Just ty <- mkTupleRepApp_maybe ty1
+ = assert (null rest) ty
+
+ -- The catch-all case
+ | otherwise
+ = TyConApp tycon tys
+ where
+ key = tyConUnique tycon
+
+
+{- Note [Care using synonyms to compress types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Using a synonym to compress a types has a tricky wrinkle. Consider
+coreView applied to (TyConApp LiftedRep [])
+
+* coreView expands the LiftedRep synonym:
+ type LiftedRep = BoxedRep Lifted
+
+* Danger: we might apply the empty substitution to the RHS of the
+ synonym. And substTy calls mkTyConApp BoxedRep [Lifted]. And
+ mkTyConApp compresses that back to LiftedRep. Loop!
+
+* Solution: in expandSynTyConApp_maybe, don't call substTy for nullary
+ type synonyms. That's more efficient anyway.
+-}
+
+
mkTYPEapp :: RuntimeRepType -> Type
mkTYPEapp rr
= case mkTYPEapp_maybe rr of
=====================================
compiler/GHC/Tc/Errors/Ppr.hs
=====================================
@@ -2078,7 +2078,7 @@ pprTcSolverReportMsg _
2 (text "but" <+> quotes (ppr thing) <+> text "has kind" <+>
quotes (ppr act))
where
- kind_desc | isConstraintKind exp = text "a constraint"
+ kind_desc | isConstraintLikeKind exp = text "a constraint"
| Just arg <- kindRep_maybe exp -- TYPE t0
, tcIsTyVarTy arg = sdocOption sdocPrintExplicitRuntimeReps $ \case
True -> text "kind" <+> quotes (ppr exp)
=====================================
compiler/GHC/Tc/Gen/HsType.hs
=====================================
@@ -1177,7 +1177,7 @@ tc_hs_type mode (HsQualTy { hst_ctxt = ctxt, hst_body = rn_ty }) exp_kind
= tc_lhs_type mode rn_ty exp_kind
-- See Note [Body kind of a HsQualTy]
- | isConstraintKind exp_kind
+ | isConstraintLikeKind exp_kind
= do { ctxt' <- tc_hs_context mode ctxt
; ty' <- tc_lhs_type mode rn_ty constraintKind
; return (tcMkDFunPhiTy ctxt' ty') }
@@ -1395,9 +1395,9 @@ tupKindSort_maybe :: TcKind -> Maybe TupleSort
tupKindSort_maybe k
| Just (k', _) <- splitCastTy_maybe k = tupKindSort_maybe k'
| Just k' <- tcView k = tupKindSort_maybe k'
- | isConstraintKind k = Just ConstraintTuple
- | tcIsLiftedTypeKind k = Just BoxedTuple
- | otherwise = Nothing
+ | isConstraintKind k = Just ConstraintTuple
+ | tcIsLiftedTypeKind k = Just BoxedTuple
+ | otherwise = Nothing
tc_tuple :: HsType GhcRn -> TcTyMode -> TupleSort -> [LHsType GhcRn] -> TcKind -> TcM TcType
tc_tuple rn_ty mode tup_sort tys exp_kind
@@ -3729,8 +3729,8 @@ splitTyConKind skol_info in_scope avoid_occs kind
; return (go new_occs new_uniqs subst [] kind) }
isAllowedDataResKind :: AllowedDataResKind -> Kind -> Bool
-isAllowedDataResKind AnyTYPEKind kind = tcIsRuntimeTypeKind kind
-isAllowedDataResKind AnyBoxedKind kind = tcIsBoxedTypeKind kind
+isAllowedDataResKind AnyTYPEKind kind = isTypeLikeKind kind
+isAllowedDataResKind AnyBoxedKind kind = tcIsBoxedTypeKind kind
isAllowedDataResKind LiftedKind kind = tcIsLiftedTypeKind kind
-- | Checks that the return kind in a data declaration's kind signature is
@@ -3821,7 +3821,7 @@ checkDataKindSig data_sort kind
TcRnInvalidReturnKind data_sort (allowed_kind dflags) kind (ext_hint dflags)
ext_hint dflags
- | tcIsRuntimeTypeKind kind
+ | isTypeLikeKind kind
, is_newtype
, not (xopt LangExt.UnliftedNewtypes dflags)
= Just SuggestUnliftedNewtypes
=====================================
compiler/GHC/Tc/Instance/Typeable.hs
=====================================
@@ -13,7 +13,7 @@ module GHC.Tc.Instance.Typeable(mkTypeableBinds, tyConIsTypeable) where
import GHC.Prelude
import GHC.Platform
-import GHC.Types.Basic ( Boxity(..), neverInlinePragma )
+import GHC.Types.Basic ( Boxity(..), TypeOrConstraint(..), neverInlinePragma )
import GHC.Types.SourceText ( SourceText(..) )
import GHC.Iface.Env( newGlobalBinder )
import GHC.Core.TyCo.Rep( Type(..), TyLit(..) )
@@ -330,9 +330,11 @@ mkPrimTypeableTodos
-- Build TypeRepTodos for built-in KindReps
; todo1 <- todoForExportedKindReps builtInKindReps
+
-- Build TypeRepTodos for types in GHC.Prim
; todo2 <- todoForTyCons gHC_PRIM ghc_prim_module_id
ghcPrimTypeableTyCons
+
; return ( gbl_env' , [todo1, todo2])
}
else do gbl_env <- getGblEnv
@@ -464,12 +466,14 @@ newtype KindRepM a = KindRepM { unKindRepM :: StateT KindRepEnv TcRn a }
liftTc :: TcRn a -> KindRepM a
liftTc = KindRepM . lift
--- | We generate @KindRep at s for a few common kinds in @GHC.Types@ so that they
+-- | We generate `KindRep`s for a few common kinds, so that they
-- can be reused across modules.
+-- These definitions are generated in `ghc-prim:GHC.Types`.
builtInKindReps :: [(Kind, Name)]
builtInKindReps =
- [ (star, starKindRepName)
- , (mkVisFunTyMany star star, starArrStarKindRepName)
+ [ (star, starKindRepName)
+ , (constraintKind, constraintKindRepName)
+ , (mkVisFunTyMany star star, starArrStarKindRepName)
, (mkVisFunTysMany [star, star] star, starArrStarArrStarKindRepName)
]
where
@@ -481,6 +485,7 @@ initialKindRepEnv = foldlM add_kind_rep emptyTypeMap builtInKindReps
add_kind_rep acc (k,n) = do
id <- tcLookupId n
return $! extendTypeMap acc k (id, Nothing)
+ -- The TypeMap looks through type synonyms
-- | Performed while compiling "GHC.Types" to generate the built-in 'KindRep's.
mkExportedKindReps :: TypeableStuff
@@ -496,6 +501,7 @@ mkExportedKindReps stuff = mapM_ kindrep_binding
-- since the latter would find the built-in 'KindRep's in the
-- 'KindRepEnv' (by virtue of being in 'initialKindRepEnv').
rhs <- mkKindRepRhs stuff empty_scope kind
+ liftTc (traceTc "mkExport" (ppr kind $$ ppr rep_bndr $$ ppr rhs))
addKindRepBind empty_scope kind rep_bndr rhs
addKindRepBind :: CmEnv -> Kind -> Id -> LHsExpr GhcTc -> KindRepM ()
@@ -528,10 +534,8 @@ getKindRep stuff@(Stuff {..}) in_scope = go
go' :: Kind -> KindRepEnv -> TcRn (LHsExpr GhcTc, KindRepEnv)
go' k env
- -- Look through type synonyms
- | Just k' <- tcView k = go' k' env
-
-- We've already generated the needed KindRep
+ -- This lookup looks through synonyms
| Just (id, _) <- lookupTypeMapWithScope env in_scope k
= return (nlHsVar id, env)
@@ -560,24 +564,27 @@ mkKindRepRhs stuff@(Stuff {..}) in_scope = new_kind_rep_shortcut
-- We handle (TYPE LiftedRep) etc separately to make it
-- clear to consumers (e.g. serializers) that there is
-- a loop here (as TYPE :: RuntimeRep -> TYPE 'LiftedRep)
- | not (isConstraintKind k)
+ | Just (TypeLike, rep) <- sORTKind_maybe k
-- Typeable respects the Constraint/Type distinction
-- so do not follow the special case here
- , Just arg <- kindRep_maybe k
- = case splitTyConApp_maybe arg of
- Just (tc, [])
+ = -- Here k = TYPE <something>
+ case splitTyConApp_maybe rep of
+ Just (tc, []) -- TYPE IntRep, TYPE FloatRep etc
| Just dc <- isPromotedDataCon_maybe tc
-> return $ nlHsDataCon kindRepTYPEDataCon `nlHsApp` nlHsDataCon dc
- Just (rep, [levArg])
- | Just dcRep <- isPromotedDataCon_maybe rep
- , Just (lev, []) <- splitTyConApp_maybe levArg
- , Just dcLev <- isPromotedDataCon_maybe lev
+ Just (rep_tc, [levArg]) -- TYPE (BoxedRep lev)
+ | Just dcRep <- isPromotedDataCon_maybe rep_tc
+ , Just (lev_tc, []) <- splitTyConApp_maybe levArg
+ , Just dcLev <- isPromotedDataCon_maybe lev_tc
-> return $ nlHsDataCon kindRepTYPEDataCon `nlHsApp` (nlHsDataCon dcRep `nlHsApp` nlHsDataCon dcLev)
_ -> new_kind_rep k
| otherwise = new_kind_rep k
+ new_kind_rep ki -- Expand synonyms
+ | Just ki' <- tcView ki
+ = new_kind_rep ki'
new_kind_rep (TyVarTy v)
| Just idx <- lookupCME in_scope v
=====================================
compiler/GHC/Tc/Validity.hs
=====================================
@@ -445,10 +445,10 @@ checkValidMonoType ty
checkTySynRhs :: UserTypeCtxt -> TcType -> TcM ()
checkTySynRhs ctxt ty
- | tcReturnsConstraintKind actual_kind
+ | returnsConstraintKind actual_kind
= do { ck <- xoptM LangExt.ConstraintKinds
; if ck
- then when (isConstraintKind actual_kind)
+ then when (isConstraintLikeKind actual_kind)
(do { dflags <- getDynFlags
; expand <- initialExpandMode
; check_pred_ty emptyTidyEnv dflags ctxt expand ty })
=====================================
libraries/ghc-prim/GHC/Types.hs
=====================================
@@ -63,7 +63,6 @@ import GHC.Prim
infixr 5 :
-
{- *********************************************************************
* *
Functions
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/184a8f9d8cc147c71b88756062c05fea2ff1a267
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/184a8f9d8cc147c71b88756062c05fea2ff1a267
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/20220817/25e820f5/attachment-0001.html>
More information about the ghc-commits
mailing list