diff --git a/compiler/GHC/Builtin/Names.hs b/compiler/GHC/Builtin/Names.hs index cf0f72c50f..78c84147cb 100644 --- a/compiler/GHC/Builtin/Names.hs +++ b/compiler/GHC/Builtin/Names.hs @@ -1949,6 +1949,15 @@ unrestrictedFunTyConKey = mkPreludeTyConUnique 193 multMulTyConKey :: Unique multMulTyConKey = mkPreludeTyConUnique 194 +-- CallingConv +runtimeInfoTyConKey, runtimeInfoDataConKey, callingConvTyConKey, + convEvalDataConKey, convCallDataConKey :: Unique +runtimeInfoTyConKey = mkPreludeTyConUnique 195 +runtimeInfoDataConKey = mkPreludeDataConUnique 196 +callingConvTyConKey = mkPreludeTyConUnique 197 +convEvalDataConKey = mkPreludeDataConUnique 198 +convCallDataConKey = mkPreludeDataConUnique 199 + ---------------- Template Haskell ------------------- -- GHC.Builtin.Names.TH: USES TyConUniques 200-299 ----------------------------------------------------- diff --git a/compiler/GHC/Builtin/Types.hs b/compiler/GHC/Builtin/Types.hs index d06bc4a12b..1bb6a263c6 100644 --- a/compiler/GHC/Builtin/Types.hs +++ b/compiler/GHC/Builtin/Types.hs @@ -109,6 +109,7 @@ module GHC.Builtin.Types ( -- * RuntimeRep and friends runtimeRepTyCon, vecCountTyCon, vecElemTyCon, + runtimeInfoTyCon, rInfo, runtimeRepTy, liftedRepTy, liftedRepDataCon, liftedRepDataConTyCon, @@ -131,6 +132,9 @@ module GHC.Builtin.Types ( doubleElemRepDataConTy, + runtimeInfoTy, runtimeInfoDataConTyCon, callingConvTy, liftedRepEvalTy, + convEvalDataConTy, + -- * Multiplicity and friends multiplicityTyConName, oneDataConName, manyDataConName, multiplicityTy, multiplicityTyCon, oneDataCon, manyDataCon, oneDataConTy, manyDataConTy, @@ -189,6 +193,7 @@ import GHC.Utils.Outputable import GHC.Utils.Misc import GHC.Utils.Panic +import qualified GHC.Core.TyCo.Rep as TyCoRep (Type(TyConApp)) import qualified Data.ByteString.Char8 as BS import Data.List ( elemIndex ) @@ -266,6 +271,8 @@ wiredInTyCons = [ -- Units are not treated like other tuples, because they , multiplicityTyCon , naturalTyCon , integerTyCon + , runtimeInfoTyCon + , callingConvTyCon ] mkWiredInTyConName :: BuiltInSyntax -> Module -> FastString -> Unique -> TyCon -> Name @@ -689,7 +696,7 @@ constraintKindTyCon :: TyCon constraintKindTyCon = pcTyCon constraintKindTyConName Nothing [] [] liftedTypeKind, typeToTypeKind, constraintKind :: Kind -liftedTypeKind = tYPE liftedRepTy +liftedTypeKind = TyCoRep.TyConApp liftedTypeKindTyCon [] typeToTypeKind = liftedTypeKind `mkVisFunTyMany` liftedTypeKind constraintKind = mkTyConApp constraintKindTyCon [] @@ -1027,7 +1034,7 @@ cTupleArr = listArray (0,mAX_CTUPLE_SIZE) [mk_ctuple i | i <- [0..mAX_CTUPLE_SIZ -- [IntRep, LiftedRep])@ unboxedTupleSumKind :: TyCon -> [Type] -> Kind unboxedTupleSumKind tc rr_tys - = tYPE (mkTyConApp tc [mkPromotedListTy runtimeRepTy rr_tys]) + = tYPE $ mkTyConApp runtimeInfoDataConTyCon [(mkTyConApp tc [mkPromotedListTy runtimeRepTy rr_tys]), convEvalDataConTy] -- | Specialization of 'unboxedTupleSumKind' for tuples unboxedTupleKind :: [Type] -> Kind @@ -1064,7 +1071,7 @@ mk_tuple Unboxed arity = (tycon, tuple_con) -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon -- Kind: forall (k1:RuntimeRep) (k2:RuntimeRep). TYPE k1 -> TYPE k2 -> # - tc_binders = mkTemplateTyConBinders (replicate arity runtimeRepTy) + tc_binders = mkTemplateTyConBinders (replicate arity runtimeInfoTy) (\ks -> map tYPE ks) tc_res_kind = unboxedTupleKind rr_tys @@ -1388,11 +1395,11 @@ unrestrictedFunTyCon :: TyCon unrestrictedFunTyCon = buildSynTyCon unrestrictedFunTyConName [] arrowKind [] unrestrictedFunTy where arrowKind = mkTyConKind binders liftedTypeKind -- See also funTyCon - binders = [ Bndr runtimeRep1TyVar (NamedTCB Inferred) - , Bndr runtimeRep2TyVar (NamedTCB Inferred) + binders = [ Bndr runtimeInfo1TyVar (NamedTCB Inferred) + , Bndr runtimeInfo2TyVar (NamedTCB Inferred) ] - ++ mkTemplateAnonTyConBinders [ tYPE runtimeRep1Ty - , tYPE runtimeRep2Ty + ++ mkTemplateAnonTyConBinders [ tYPE runtimeInfo1Ty + , tYPE runtimeInfo2Ty ] unrestrictedFunTyConName :: Name @@ -1400,7 +1407,7 @@ unrestrictedFunTyConName = mkWiredInTyConName BuiltInSyntax gHC_TYPES (fsLit "-> {- ********************************************************************* * * - Kinds and RuntimeRep + Kinds, RuntimeRep and CallingConv * * ********************************************************************* -} @@ -1413,8 +1420,8 @@ runtimeRepTy = mkTyConTy runtimeRepTyCon -- type Type = tYPE 'LiftedRep liftedTypeKindTyCon :: TyCon liftedTypeKindTyCon = buildSynTyCon liftedTypeKindTyConName - [] liftedTypeKind [] - (tYPE liftedRepTy) + [] liftedTypeKind [] rhs + where rhs = TyCoRep.TyConApp tYPETyCon [mkTyConApp runtimeInfoDataConTyCon [liftedRepTy, convEvalDataConTy]] runtimeRepTyCon :: TyCon runtimeRepTyCon = pcTyCon runtimeRepTyConName Nothing [] @@ -1425,13 +1432,13 @@ vecRepDataCon :: DataCon vecRepDataCon = pcSpecialDataCon vecRepDataConName [ mkTyConTy vecCountTyCon , mkTyConTy vecElemTyCon ] runtimeRepTyCon - (RuntimeRep prim_rep_fun) + (RuntimeInfo prim_rep_fun) where -- See Note [Getting from RuntimeRep to PrimRep] in GHC.Types.RepType prim_rep_fun [count, elem] | VecCount n <- tyConRuntimeRepInfo (tyConAppTyCon count) , VecElem e <- tyConRuntimeRepInfo (tyConAppTyCon elem) - = [VecRep n e] + = [RInfo [(VecRep n e)] ConvEval] prim_rep_fun args = pprPanic "vecRepDataCon" (ppr args) @@ -1440,11 +1447,11 @@ vecRepDataConTyCon = promoteDataCon vecRepDataCon tupleRepDataCon :: DataCon tupleRepDataCon = pcSpecialDataCon tupleRepDataConName [ mkListTy runtimeRepTy ] - runtimeRepTyCon (RuntimeRep prim_rep_fun) + runtimeRepTyCon (RuntimeInfo prim_rep_fun) where -- See Note [Getting from RuntimeRep to PrimRep] in GHC.Types.RepType prim_rep_fun [rr_ty_list] - = concatMap (runtimeRepPrimRep doc) rr_tys + = [RInfo (concatMap (runtimeRepPrimRep doc) rr_tys) ConvEval] where rr_tys = extractPromotedList rr_ty_list doc = text "tupleRepDataCon" <+> ppr rr_tys @@ -1456,11 +1463,11 @@ tupleRepDataConTyCon = promoteDataCon tupleRepDataCon sumRepDataCon :: DataCon sumRepDataCon = pcSpecialDataCon sumRepDataConName [ mkListTy runtimeRepTy ] - runtimeRepTyCon (RuntimeRep prim_rep_fun) + runtimeRepTyCon (RuntimeInfo prim_rep_fun) where -- See Note [Getting from RuntimeRep to PrimRep] in GHC.Types.RepType prim_rep_fun [rr_ty_list] - = map slotPrimRep (ubxSumRepType prim_repss) + = [RInfo (map slotPrimRep (ubxSumRepType prim_repss)) ConvEval] where rr_tys = extractPromotedList rr_ty_list doc = text "sumRepDataCon" <+> ppr rr_tys @@ -1488,7 +1495,7 @@ runtimeRepSimpleDataCons@(liftedRepDataCon : _) runtimeRepSimpleDataConNames where mk_runtime_rep_dc primrep name - = pcSpecialDataCon name [] runtimeRepTyCon (RuntimeRep (\_ -> [primrep])) + = pcSpecialDataCon name [] runtimeRepTyCon (RuntimeInfo (\_ -> [RInfo [primrep] ConvEval])) -- See Note [Wiring in RuntimeRep] liftedRepDataConTy, unliftedRepDataConTy, @@ -1558,6 +1565,79 @@ liftedRepDataConTyCon = promoteDataCon liftedRepDataCon liftedRepTy :: Type liftedRepTy = liftedRepDataConTy +-- The type ('BoxedRep 'UnliftedRep) +unliftedRepTy :: Type +unliftedRepTy = unliftedRepDataConTy + +unliftedRepEvalTy :: Type +unliftedRepEvalTy = mkTyConApp runtimeInfoDataConTyCon [unliftedRepTy, convEvalDataConTy] + +liftedRepEvalTy :: Type +liftedRepEvalTy = mkTyConApp runtimeInfoDataConTyCon [liftedRepTy, convEvalDataConTy] + +callingConvTyConName, convEvalDataConName, convCallDataConName :: Name +callingConvTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "CallingConv") callingConvTyConKey callingConvTyCon +convEvalDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "ConvEval") convEvalDataConKey convEvalDataCon +-- convCallDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "ConvCall") convCallDataConKey convCallDataCon +convCallDataConName = undefined + +convEvalDataCon = pcSpecialDataCon convEvalDataConName [] callingConvTyCon (CallingConvInfo $ \_ -> [ConvEval]) + +convEvalDataConTyCon :: TyCon +convEvalDataConTyCon = promoteDataCon convEvalDataCon + +convEvalDataConTy :: Type +convEvalDataConTy = mkTyConTy convEvalDataConTyCon + + +callingConvTyCon :: TyCon +callingConvTyCon = pcTyCon callingConvTyConName Nothing [] + [convEvalDataCon] + +callingConvTy :: Type +callingConvTy = mkTyConTy callingConvTyCon + +{- ********************************************************************* +* * + RuntimeInfo Types +* * +********************************************************************* -} + +runtimeInfoTyConName, runtimeInfoDataConName :: Name +runtimeInfoTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "RuntimeInfo") runtimeInfoTyConKey runtimeInfoTyCon +runtimeInfoDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "RInfo") runtimeInfoDataConKey runtimeInfoDataCon + +runtimeInfoTyCon :: TyCon +runtimeInfoTyCon = pcTyCon runtimeInfoTyConName Nothing [] + [runtimeInfoDataCon] + +runtimeInfoDataCon :: DataCon +runtimeInfoDataCon = pcSpecialDataCon runtimeInfoDataConName [ runtimeRepTy + , mkTyConTy callingConvTyCon ] + runtimeInfoTyCon + (RuntimeInfo prim_info_fun) + where + -- See Note [Getting from RuntimeRep to PrimRep] in GHC.Types.RepType + prim_info_fun tys@[rep, conv] + = pprPanic "here runtimeInfoDataCon" (ppr tys) + -- [RInfo (runtimeRepPrimRep doc rep) ConvEval] + where doc = text "runtimeInfoDataCon" <+> ppr tys + prim_info_fun args + = pprPanic "runtimeInfoDataCon" (ppr args) + +runtimeInfoDataConTyCon :: TyCon +runtimeInfoDataConTyCon = promoteDataCon runtimeInfoDataCon + +runtimeInfoDataConTy :: Type +runtimeInfoDataConTy = mkTyConTy runtimeInfoDataConTyCon + +runtimeInfoTy :: Type +runtimeInfoTy = mkTyConTy runtimeInfoTyCon + +rInfo :: Type -> Type -> Type +rInfo rep conv = TyCoRep.TyConApp runtimeInfoTyCon [rep, conv] + + {- ********************************************************************* * * The boxed primitive types: Char, Int, etc diff --git a/compiler/GHC/Builtin/Types.hs-boot b/compiler/GHC/Builtin/Types.hs-boot index 000df212c3..fc82f9d7b9 100644 --- a/compiler/GHC/Builtin/Types.hs-boot +++ b/compiler/GHC/Builtin/Types.hs-boot @@ -23,6 +23,13 @@ constraintKind :: Kind runtimeRepTyCon, vecCountTyCon, vecElemTyCon :: TyCon runtimeRepTy :: Type + +runtimeInfoTy, callingConvTy, convEvalDataConTy :: Type + +runtimeInfoTyCon, runtimeInfoDataConTyCon :: TyCon + +rInfo :: Type -> Type -> Type + liftedRepDataConTyCon, vecRepDataConTyCon, tupleRepDataConTyCon :: TyCon liftedRepDataConTy, unliftedRepDataConTy, diff --git a/compiler/GHC/Builtin/Types/Prim.hs b/compiler/GHC/Builtin/Types/Prim.hs index fc74596e45..5fb750649c 100644 --- a/compiler/GHC/Builtin/Types/Prim.hs +++ b/compiler/GHC/Builtin/Types/Prim.hs @@ -24,6 +24,7 @@ module GHC.Builtin.Types.Prim( alphaTyVarsUnliftedRep, alphaTyVarUnliftedRep, alphaTysUnliftedRep, alphaTyUnliftedRep, runtimeRep1TyVar, runtimeRep2TyVar, runtimeRep1Ty, runtimeRep2Ty, + runtimeInfo1TyVar, runtimeInfo2TyVar, runtimeInfo1Ty, runtimeInfo2Ty, openAlphaTy, openBetaTy, openAlphaTyVar, openBetaTyVar, multiplicityTyVar, @@ -97,6 +98,7 @@ import GHC.Prelude import {-# SOURCE #-} GHC.Builtin.Types ( runtimeRepTy, unboxedTupleKind, liftedTypeKind + , runtimeInfoTy, runtimeInfoDataConTyCon, convEvalDataConTy , vecRepDataConTyCon, tupleRepDataConTyCon , liftedRepDataConTy, unliftedRepDataConTy , intRepDataConTy @@ -382,11 +384,19 @@ runtimeRep1Ty, runtimeRep2Ty :: Type runtimeRep1Ty = mkTyVarTy runtimeRep1TyVar runtimeRep2Ty = mkTyVarTy runtimeRep2TyVar +runtimeInfo1TyVar, runtimeInfo2TyVar :: TyVar +(runtimeInfo1TyVar : runtimeInfo2TyVar : _) + = drop 16 (mkTemplateTyVars (repeat runtimeInfoTy)) -- selects 'q','r' + +runtimeInfo1Ty, runtimeInfo2Ty :: Type +runtimeInfo1Ty = mkTyVarTy runtimeInfo1TyVar +runtimeInfo2Ty = mkTyVarTy runtimeInfo2TyVar + openAlphaTyVar, openBetaTyVar :: TyVar -- alpha :: TYPE r1 -- beta :: TYPE r2 [openAlphaTyVar,openBetaTyVar] - = mkTemplateTyVars [tYPE runtimeRep1Ty, tYPE runtimeRep2Ty] + = mkTemplateTyVars [tYPE runtimeInfo1Ty, tYPE runtimeInfo2Ty] openAlphaTy, openBetaTy :: Type openAlphaTy = mkTyVarTy openAlphaTyVar @@ -432,10 +442,10 @@ funTyCon = mkFunTyCon funTyConName tc_bndrs tc_rep_nm where -- See also unrestrictedFunTyCon tc_bndrs = [ mkNamedTyConBinder Required multiplicityTyVar - , mkNamedTyConBinder Inferred runtimeRep1TyVar - , mkNamedTyConBinder Inferred runtimeRep2TyVar ] - ++ mkTemplateAnonTyConBinders [ tYPE runtimeRep1Ty - , tYPE runtimeRep2Ty + , mkNamedTyConBinder Inferred runtimeInfo1TyVar + , mkNamedTyConBinder Inferred runtimeInfo2TyVar ] + ++ mkTemplateAnonTyConBinders [ tYPE runtimeInfo1Ty + , tYPE runtimeInfo2Ty ] tc_rep_nm = mkPrelTyConRepName funTyConName @@ -529,7 +539,7 @@ tYPETyCon :: TyCon tYPETyConName :: Name tYPETyCon = mkKindTyCon tYPETyConName - (mkTemplateAnonTyConBinders [runtimeRepTy]) + (mkTemplateAnonTyConBinders [runtimeInfoTy]) liftedTypeKind [Nominal] (mkPrelTyConRepName tYPETyConName) @@ -574,7 +584,7 @@ pcPrimTyCon name roles rep = mkPrimTyCon name binders result_kind roles where binders = mkTemplateAnonTyConBinders (map (const liftedTypeKind) roles) - result_kind = tYPE (primRepToRuntimeRep rep) + result_kind = tYPE $ TyConApp runtimeInfoDataConTyCon [(primRepToRuntimeRep rep), convEvalDataConTy] -- | Convert a 'PrimRep' to a 'Type' of kind RuntimeRep -- Defined here to avoid (more) module loops diff --git a/compiler/GHC/Core/Make.hs b/compiler/GHC/Core/Make.hs index 6d6dd38b29..da285a6455 100644 --- a/compiler/GHC/Core/Make.hs +++ b/compiler/GHC/Core/Make.hs @@ -913,7 +913,7 @@ mkRuntimeErrorId name runtimeErrorTy :: Type -- forall (rr :: RuntimeRep) (a :: rr). Addr# -> a -- See Note [Error and friends have an "open-tyvar" forall] -runtimeErrorTy = mkSpecForAllTys [runtimeRep1TyVar, openAlphaTyVar] +runtimeErrorTy = mkSpecForAllTys [runtimeInfo1TyVar, openAlphaTyVar] (mkVisFunTyMany addrPrimTy openAlphaTy) {- Note [Error and friends have an "open-tyvar" forall] diff --git a/compiler/GHC/Core/TyCon.hs b/compiler/GHC/Core/TyCon.hs index 198b66959b..5c59548ebf 100644 --- a/compiler/GHC/Core/TyCon.hs +++ b/compiler/GHC/Core/TyCon.hs @@ -120,6 +120,7 @@ module GHC.Core.TyCon( -- * Primitive representations of Types PrimRep(..), PrimElemRep(..), + PrimConv (..), PrimInfo (..), isVoidRep, isGcPtrRep, primRepSizeB, primElemRepSizeB, @@ -172,6 +173,10 @@ import GHC.Unit.Module import qualified Data.Data as Data +import {-# SOURCE #-} GHC.Core.Type (splitTyConApp_maybe) +-- import {-# SOURCE #-} GHC.Builtin.Types.Prim (mutableByteArrayPrimTyConKey) +import GHC.Builtin.Names + {- ----------------------------------------------- Notes about type families @@ -1073,6 +1078,8 @@ data RuntimeRepInfo -- be the list of arguments to the promoted datacon. | VecCount Int -- ^ A constructor of @VecCount@ | VecElem PrimElemRep -- ^ A constructor of @VecElem@ + | RuntimeInfo ([Type] -> [PrimInfo]) + | CallingConvInfo ([Type] -> [PrimConv]) -- | Extract those 'DataCon's that we are able to learn about. Note -- that visibility in this sense does not correspond to visibility in @@ -1550,6 +1557,26 @@ primRepIsFloat DoubleRep = Just True primRepIsFloat (VecRep _ _) = Nothing primRepIsFloat _ = Just False +{- +************************************************************************ +* * + PrimConv +* * +************************************************************************ + +Note [PrimConv] + +A type for representing the calling convention of a type. Either the arity +for extensional functions or the levity for data terms. +-} + +data PrimConv = + ConvEval + -- | ConvCall [PrimRep] + deriving (Show) + +data PrimInfo = RInfo {reps :: [PrimRep], conv :: PrimConv} + {- ************************************************************************ @@ -2326,11 +2353,17 @@ expandSynTyCon_maybe -- ^ Expand a type synonym application, if any expandSynTyCon_maybe tc tys + -- | SynonymTyCon { tyConTyVars = tvs, synTcRhs = rhs, tyConArity = arity } <- tc + -- , Just (tc' , _) <- splitTyConApp_maybe rhs + -- , tc' `hasKey` (mutableByteArrayPrimTyConKey) + -- = pprPanic "here" (ppr tc) + | SynonymTyCon { tyConTyVars = tvs, synTcRhs = rhs, tyConArity = arity } <- tc = case tys `listLengthCmp` arity of GT -> Just (tvs `zip` tys, rhs, drop arity tys) EQ -> Just (tvs `zip` tys, rhs, []) LT -> Nothing + | otherwise = Nothing diff --git a/compiler/GHC/Core/Type.hs b/compiler/GHC/Core/Type.hs index 3164e2626b..5f3ab18925 100644 --- a/compiler/GHC/Core/Type.hs +++ b/compiler/GHC/Core/Type.hs @@ -68,6 +68,7 @@ module GHC.Core.Type ( isPredTy, getRuntimeRep_maybe, kindRep_maybe, kindRep, + getRuntimeInfo, getRuntimeInfo_maybe, kindInfo, mkCastTy, mkCoercionTy, splitCastTy_maybe, @@ -125,6 +126,7 @@ module GHC.Core.Type ( isAlgType, isDataFamilyAppType, isPrimitiveType, isStrictType, isRuntimeRepTy, isRuntimeRepVar, isRuntimeRepKindedTy, + isRuntimeInfoTy, isRuntimeInfoVar, dropRuntimeRepArgs, getRuntimeRep, @@ -554,6 +556,11 @@ kindRep k = case kindRep_maybe k of Just r -> r Nothing -> pprPanic "kindRep" (ppr k) +kindInfo :: HasDebugCallStack => Kind -> Type +kindInfo k = case kindInfo_maybe k of + Just r -> r + Nothing -> pprPanic "kindInfo" (ppr k) + -- | Given a kind (TYPE rr), extract its RuntimeRep classifier rr. -- For example, @kindRep_maybe * = Just LiftedRep@ -- Returns 'Nothing' if the kind is not of form (TYPE rr) @@ -561,18 +568,33 @@ kindRep k = case kindRep_maybe k of kindRep_maybe :: HasDebugCallStack => Kind -> Maybe Type kindRep_maybe kind | TyConApp tc [arg] <- coreFullView kind - , tc `hasKey` tYPETyConKey = Just arg - | otherwise = Nothing + , tc `hasKey` tYPETyConKey + , TyConApp rinfo [rep, conv] <- coreFullView arg + , rinfo `hasKey` runtimeInfoDataConKey = Just rep + | TyConApp tc [arg] <- coreFullView kind + , tc `hasKey` tYPETyConKey = Just arg + | otherwise = Nothing + +kindInfo_maybe :: HasDebugCallStack => Kind -> Maybe Type +kindInfo_maybe kind + | TyConApp tc [arg] <- coreFullView kind + , tc `hasKey` tYPETyConKey + , TyConApp rinfo [rep, conv] <- coreFullView arg + , rinfo `hasKey` runtimeInfoDataConKey = Just arg + | TyConApp tc [arg] <- coreFullView kind + , tc `hasKey` tYPETyConKey = Just arg + | otherwise = Nothing -- | This version considers Constraint to be the same as *. Returns True -- if the argument is equivalent to Type/Constraint and False otherwise. -- See Note [Kind Constraint and kind Type] isLiftedTypeKind :: Kind -> Bool isLiftedTypeKind kind - = case kindRep_maybe kind of - Just rep -> isLiftedRuntimeRep rep + = case kindInfo_maybe kind of + Just rinfo -> isLiftedRuntimeInfo rinfo Nothing -> False + pickyIsLiftedTypeKind :: Kind -> Bool -- Checks whether the kind is literally -- TYPE LiftedRep @@ -599,13 +621,23 @@ isLiftedRuntimeRep rep , rr_tc `hasKey` liftedRepDataConKey = ASSERT( null args ) True | otherwise = False +isLiftedRuntimeInfo :: Type -> Bool +-- isLiftedRuntimeRep is true of LiftedRep :: RuntimeRep +-- False of type variables (a :: RuntimeRep) +-- and of other reps e.g. (IntRep :: RuntimeRep) +isLiftedRuntimeInfo rep + | TyConApp rr_tc [rep,conv] <- coreFullView rep + , rr_tc `hasKey` runtimeInfoDataConKey = isLiftedRuntimeRep rep + | otherwise + = False + -- | Returns True if the kind classifies unlifted types and False otherwise. -- Note that this returns False for levity-polymorphic kinds, which may -- be specialized to a kind that classifies unlifted types. isUnliftedTypeKind :: Kind -> Bool isUnliftedTypeKind kind - = case kindRep_maybe kind of - Just rep -> isUnliftedRuntimeRep rep + = case kindInfo_maybe kind of + Just rep -> isUnliftedRuntimeInfo rep Nothing -> False isUnliftedRuntimeRep :: Type -> Bool @@ -622,6 +654,17 @@ isUnliftedRuntimeRep rep | otherwise {- Variables, applications -} = False +isUnliftedRuntimeInfo rep + | TyConApp rinfo [rep, conv] <- coreFullView rep -- NB: args might be non-empty + , rinfo `hasKey` runtimeInfoDataConKey + = isUnliftedRuntimeRep rep + -- Avoid searching all the unlifted RuntimeRep type cons + -- In the RuntimeRep data type, only LiftedRep is lifted + -- But be careful of type families (F tys) :: RuntimeRep + | otherwise {- Variables, applications -} + = False + + -- | Is this the type 'RuntimeRep'? isRuntimeRepTy :: Type -> Bool isRuntimeRepTy ty @@ -644,6 +687,17 @@ isMultiplicityTy ty isMultiplicityVar :: TyVar -> Bool isMultiplicityVar = isMultiplicityTy . tyVarKind +-- | Is this the type 'RuntimeInfo'? +isRuntimeInfoTy :: Type -> Bool +isRuntimeInfoTy ty + | TyConApp tc args <- coreFullView ty + , tc `hasKey` runtimeInfoTyConKey = True + | otherwise = False + +-- | Is a tyvar of type 'RuntimeInfo'? +isRuntimeInfoVar :: TyVar -> Bool +isRuntimeInfoVar = isRuntimeInfoTy . tyVarKind + {- ********************************************************************* * * mapType @@ -927,8 +981,8 @@ repSplitAppTy_maybe :: HasDebugCallStack => Type -> Maybe (Type,Type) repSplitAppTy_maybe (FunTy _ w ty1 ty2) = Just (TyConApp funTyCon [w, rep1, rep2, ty1], ty2) where - rep1 = getRuntimeRep ty1 - rep2 = getRuntimeRep ty2 + rep1 = getRuntimeInfo ty1 + rep2 = getRuntimeInfo ty2 repSplitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2) @@ -2049,6 +2103,10 @@ getRuntimeRep_maybe :: HasDebugCallStack => Type -> Maybe Type getRuntimeRep_maybe = kindRep_maybe . typeKind +getRuntimeInfo_maybe :: HasDebugCallStack + => Type -> Maybe Type +getRuntimeInfo_maybe = kindInfo_maybe . typeKind + -- | Extract the RuntimeRep classifier of a type. For instance, -- @getRuntimeRep_maybe Int = LiftedRep@. Panics if this is not possible. getRuntimeRep :: HasDebugCallStack => Type -> Type @@ -2057,6 +2115,12 @@ getRuntimeRep ty Just r -> r Nothing -> pprPanic "getRuntimeRep" (ppr ty <+> dcolon <+> ppr (typeKind ty)) +getRuntimeInfo :: HasDebugCallStack => Type -> Type +getRuntimeInfo ty + = case getRuntimeInfo_maybe ty of + Just r -> r + Nothing -> pprPanic "getRuntimeInfo" (ppr ty <+> dcolon <+> ppr (typeKind ty)) + isUnboxedTupleType :: Type -> Bool isUnboxedTupleType ty = tyConAppTyCon (getRuntimeRep ty) `hasKey` tupleRepDataConKey @@ -2584,7 +2648,9 @@ tcIsLiftedTypeKind :: Kind -> Bool tcIsLiftedTypeKind ty | Just (tc, [arg]) <- tcSplitTyConApp_maybe ty -- Note: tcSplit here , tc `hasKey` tYPETyConKey - = isLiftedRuntimeRep arg + , Just (rinfo, [rep, conv]) <- tcSplitTyConApp_maybe arg + , rinfo `hasKey` runtimeInfoDataConKey + = isLiftedRuntimeRep rep | otherwise = False diff --git a/compiler/GHC/HsToCore.hs b/compiler/GHC/HsToCore.hs index 9cf33aa02a..3522ad6fab 100644 --- a/compiler/GHC/HsToCore.hs +++ b/compiler/GHC/HsToCore.hs @@ -714,7 +714,7 @@ mkUnsafeCoercePrimPair _old_id old_expr ; let [unsafe_refl_data_con] = tyConDataCons unsafe_equality_tc - rhs = mkLams [ runtimeRep1TyVar, runtimeRep2TyVar + rhs = mkLams [ runtimeInfo1TyVar, runtimeInfo2TyVar , openAlphaTyVar, openBetaTyVar , x ] $ mkSingleAltCase scrut1 @@ -742,10 +742,10 @@ mkUnsafeCoercePrimPair _old_id old_expr -- NB: UnsafeRefl :: (b ~# a) -> UnsafeEquality a b, so we have to -- carefully swap the arguments above - (scrut1, scrut1_ty, rr_cv_ty) = unsafe_equality runtimeRepTy - runtimeRep1Ty - runtimeRep2Ty - (scrut2, scrut2_ty, ab_cv_ty) = unsafe_equality (tYPE runtimeRep2Ty) + (scrut1, scrut1_ty, rr_cv_ty) = unsafe_equality runtimeInfoTy + runtimeInfo1Ty + runtimeInfo2Ty + (scrut2, scrut2_ty, ab_cv_ty) = unsafe_equality (tYPE runtimeInfo2Ty) (openAlphaTy `mkCastTy` alpha_co) openBetaTy @@ -761,7 +761,7 @@ mkUnsafeCoercePrimPair _old_id old_expr info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma `setUnfoldingInfo` mkCompulsoryUnfolding' rhs - ty = mkSpecForAllTys [ runtimeRep1TyVar, runtimeRep2TyVar + ty = mkSpecForAllTys [ runtimeInfo1TyVar, runtimeInfo2TyVar , openAlphaTyVar, openBetaTyVar ] $ mkVisFunTyMany openAlphaTy openBetaTy diff --git a/compiler/GHC/HsToCore/Utils.hs b/compiler/GHC/HsToCore/Utils.hs index 01085b3270..688d227a6e 100644 --- a/compiler/GHC/HsToCore/Utils.hs +++ b/compiler/GHC/HsToCore/Utils.hs @@ -407,7 +407,7 @@ mkErrorAppDs err_id ty msg = do full_msg = showSDoc dflags (hcat [ppr src_loc, vbar, msg]) core_msg = Lit (mkLitString full_msg) -- mkLitString returns a result of type String# - return (mkApps (Var err_id) [Type (getRuntimeRep ty), Type ty, core_msg]) + return (mkApps (Var err_id) [Type (getRuntimeInfo ty), Type ty, core_msg]) {- 'mkCoreAppDs' and 'mkCoreAppsDs' handle the special-case desugaring of 'seq'. diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs index de0fa6f023..b6d1281684 100644 --- a/compiler/GHC/IfaceToCore.hs +++ b/compiler/GHC/IfaceToCore.hs @@ -1438,7 +1438,7 @@ tcIfaceExpr (IfaceTuple sort args) ; let con_tys = map exprType args' some_con_args = map Type con_tys ++ args' con_args = case sort of - UnboxedTuple -> map (Type . getRuntimeRep) con_tys ++ some_con_args + UnboxedTuple -> map (Type . getRuntimeInfo) con_tys ++ some_con_args _ -> some_con_args -- Put the missing type arguments back in con_id = dataConWorkId (tyConSingleDataCon tc) diff --git a/compiler/GHC/Tc/Gen/HsType.hs b/compiler/GHC/Tc/Gen/HsType.hs index bf4b1c91d1..22283296e1 100644 --- a/compiler/GHC/Tc/Gen/HsType.hs +++ b/compiler/GHC/Tc/Gen/HsType.hs @@ -1331,7 +1331,7 @@ finish_tuple rn_ty tup_sort tau_tys tau_kinds exp_kind = do check_expected_kind (mkTyConApp tycon tau_tys) liftedTypeKind UnboxedTuple -> do let tycon = tupleTyCon Unboxed arity - tau_reps = map kindRep tau_kinds + tau_reps = map kindInfo tau_kinds -- See also Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon arg_tys = tau_reps ++ tau_tys res_kind = unboxedTupleKind tau_reps @@ -1340,7 +1340,8 @@ finish_tuple rn_ty tup_sort tau_tys tau_kinds exp_kind = do where arity = length tau_tys check_expected_kind ty act_kind = - checkExpectedKind rn_ty ty act_kind exp_kind + pprPanic "here" (ppr exp_kind) + -- checkExpectedKind rn_ty ty act_kind exp_kind {- Note [Ignore unary constraint tuples] diff --git a/compiler/GHC/Tc/Instance/Typeable.hs b/compiler/GHC/Tc/Instance/Typeable.hs index e4eb7a1b2d..51f0816860 100644 --- a/compiler/GHC/Tc/Instance/Typeable.hs +++ b/compiler/GHC/Tc/Instance/Typeable.hs @@ -28,7 +28,7 @@ import GHC.Builtin.Names import GHC.Builtin.Types.Prim ( primTyCons ) import GHC.Builtin.Types ( tupleTyCon, sumTyCon, runtimeRepTyCon - , vecCountTyCon, vecElemTyCon + , runtimeInfoTyCon, vecCountTyCon, vecElemTyCon , nilDataCon, consDataCon ) import GHC.Types.Name import GHC.Types.Id @@ -564,7 +564,7 @@ mkKindRepRhs stuff@(Stuff {..}) in_scope = new_kind_rep | not (tcIsConstraintKind k) -- Typeable respects the Constraint/Type distinction -- so do not follow the special case here - , Just arg <- kindRep_maybe k + , Just arg <- kindInfo_maybe k , Just (tc, []) <- splitTyConApp_maybe arg , Just dc <- isPromotedDataCon_maybe tc = return $ nlHsDataCon kindRepTYPEDataCon `nlHsApp` nlHsDataCon dc diff --git a/compiler/GHC/Tc/Solver.hs b/compiler/GHC/Tc/Solver.hs index 8b21b72768..ae8609541f 100644 --- a/compiler/GHC/Tc/Solver.hs +++ b/compiler/GHC/Tc/Solver.hs @@ -53,7 +53,7 @@ import GHC.Core.Predicate import GHC.Tc.Types.Origin import GHC.Tc.Utils.TcType import GHC.Core.Type -import GHC.Builtin.Types ( liftedRepTy, manyDataConTy ) +import GHC.Builtin.Types ( liftedRepEvalTy, manyDataConTy ) import GHC.Core.Unify ( tcMatchTyKi ) import GHC.Utils.Misc import GHC.Utils.Panic @@ -2283,13 +2283,13 @@ promoteTyVarTcS tv -- | Like 'defaultTyVar', but in the TcS monad. defaultTyVarTcS :: TcTyVar -> TcS Bool defaultTyVarTcS the_tv - | isRuntimeRepVar the_tv + | isRuntimeInfoVar the_tv , not (isTyVarTyVar the_tv) -- TyVarTvs should only be unified with a tyvar -- never with a type; c.f. GHC.Tc.Utils.TcMType.defaultTyVar -- and Note [Inferring kinds for type declarations] in GHC.Tc.TyCl - = do { traceTcS "defaultTyVarTcS RuntimeRep" (ppr the_tv) - ; unifyTyVar the_tv liftedRepTy + = do { traceTcS "defaultTyVarTcS RuntimeInfo" (ppr the_tv) + ; unifyTyVar the_tv liftedRepEvalTy ; return True } | isMultiplicityVar the_tv , not (isTyVarTyVar the_tv) -- TyVarTvs should only be unified with a tyvar diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs index 3f5b10f343..de9f28fbd9 100644 --- a/compiler/GHC/Tc/TyCl/PatSyn.hs +++ b/compiler/GHC/Tc/TyCl/PatSyn.hs @@ -756,7 +756,7 @@ tcPatSynMatcher (L loc name) lpat (args, arg_tys) pat_ty = do { rr_name <- newNameAt (mkTyVarOcc "rep") loc ; tv_name <- newNameAt (mkTyVarOcc "r") loc - ; let rr_tv = mkTyVar rr_name runtimeRepTy + ; let rr_tv = mkTyVar rr_name runtimeInfoTy rr = mkTyVarTy rr_tv res_tv = mkTyVar tv_name (tYPE rr) res_ty = mkTyVarTy res_tv diff --git a/compiler/GHC/Tc/Utils/TcMType.hs b/compiler/GHC/Tc/Utils/TcMType.hs index ccb9152e01..67295ac3f5 100644 --- a/compiler/GHC/Tc/Utils/TcMType.hs +++ b/compiler/GHC/Tc/Utils/TcMType.hs @@ -492,7 +492,7 @@ inferResultToType (IR { ir_uniq = u, ir_lvl = tc_lvl Just ty -> do { ensureMonoType ty -- See Note [inferResultToType] ; return ty } - Nothing -> do { rr <- newMetaTyVarTyAtLevel tc_lvl runtimeRepTy + Nothing -> do { rr <- newMetaTyVarTyAtLevel tc_lvl runtimeInfoTy ; tau <- newMetaTyVarTyAtLevel tc_lvl (tYPE rr) -- See Note [TcLevel of ExpType] ; writeMutVar ref (Just tau) @@ -667,10 +667,10 @@ promoteTcType dest_lvl ty else promote_it } where promote_it :: TcM (TcCoercion, TcType) - promote_it -- Emit a constraint (alpha :: TYPE rr) ~ ty + promote_it -- Emit a constraint (alpha :: TYPE ri) ~ ty -- where alpha and rr are fresh and from level dest_lvl - = do { rr <- newMetaTyVarTyAtLevel dest_lvl runtimeRepTy - ; prom_ty <- newMetaTyVarTyAtLevel dest_lvl (tYPE rr) + = do { ri <- newMetaTyVarTyAtLevel dest_lvl runtimeInfoTy + ; prom_ty <- newMetaTyVarTyAtLevel dest_lvl (tYPE ri) ; let eq_orig = TypeEqOrigin { uo_actual = ty , uo_expected = prom_ty , uo_thing = Nothing @@ -1048,7 +1048,7 @@ newFlexiTyVarTys n kind = replicateM n (newFlexiTyVarTy kind) newOpenTypeKind :: TcM TcKind newOpenTypeKind - = do { rr <- newFlexiTyVarTy runtimeRepTy + = do { rr <- newFlexiTyVarTy runtimeInfoTy ; return (tYPE rr) } -- | Create a tyvar that can be a lifted or unlifted type. @@ -1765,11 +1765,16 @@ defaultTyVar default_kind tv -- See Note [Inferring kinds for type declarations] in GHC.Tc.TyCl = return False + | isRuntimeInfoVar tv -- Do not quantify over a RuntimeRep var + -- unless it is a TyVarTv, handled earlier + = do { traceTc "Defaulting a RuntimeRep var to LiftedRep" (ppr tv) + ; writeMetaTyVar tv liftedRepEvalTy + ; return True } | isRuntimeRepVar tv -- Do not quantify over a RuntimeRep var -- unless it is a TyVarTv, handled earlier = do { traceTc "Defaulting a RuntimeRep var to LiftedRep" (ppr tv) - ; writeMetaTyVar tv liftedRepTy + ; writeMetaTyVar tv liftedRepEvalTy ; return True } | isMultiplicityVar tv = do { traceTc "Defaulting a Multiplicty var to Many" (ppr tv) diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs index 85587c29f8..feabf616ad 100644 --- a/compiler/GHC/Tc/Utils/Zonk.hs +++ b/compiler/GHC/Tc/Utils/Zonk.hs @@ -1818,9 +1818,9 @@ commitFlexi flexi tv zonked_kind SkolemiseFlexi -> return (mkTyVarTy (mkTyVar name zonked_kind)) DefaultFlexi - | isRuntimeRepTy zonked_kind + | isRuntimeInfoTy zonked_kind -> do { traceTc "Defaulting flexi tyvar to LiftedRep:" (pprTyVar tv) - ; return liftedRepTy } + ; return liftedRepEvalTy } | isMultiplicityTy zonked_kind -> do { traceTc "Defaulting flexi tyvar to Many:" (pprTyVar tv) ; return manyDataConTy } diff --git a/compiler/GHC/Types/Id/Make.hs b/compiler/GHC/Types/Id/Make.hs index 9aa91e3017..a0ec7f9cb7 100644 --- a/compiler/GHC/Types/Id/Make.hs +++ b/compiler/GHC/Types/Id/Make.hs @@ -1513,13 +1513,13 @@ oneShotId = pcMiscPrelId oneShotName ty info where info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma `setUnfoldingInfo` mkCompulsoryUnfolding defaultSimpleOpts rhs - ty = mkSpecForAllTys [ runtimeRep1TyVar, runtimeRep2TyVar + ty = mkSpecForAllTys [ runtimeInfo1TyVar, runtimeInfo2TyVar , openAlphaTyVar, openBetaTyVar ] (mkVisFunTyMany fun_ty fun_ty) fun_ty = mkVisFunTyMany openAlphaTy openBetaTy [body, x] = mkTemplateLocals [fun_ty, openAlphaTy] x' = setOneShotLambda x -- Here is the magic bit! - rhs = mkLams [ runtimeRep1TyVar, runtimeRep2TyVar + rhs = mkLams [ runtimeInfo1TyVar, runtimeInfo2TyVar , openAlphaTyVar, openBetaTyVar , body, x'] $ Var body `App` Var x @@ -1548,7 +1548,7 @@ coerceId = pcMiscPrelId coerceName ty info mkInvisFunTyMany eqRTy $ mkVisFunTyMany a b - bndrs@[rv,av,bv] = mkTemplateKiTyVar runtimeRepTy + bndrs@[rv,av,bv] = mkTemplateKiTyVar runtimeInfoTy (\r -> [tYPE r, tYPE r]) [r, a, b] = mkTyVarTys bndrs diff --git a/compiler/GHC/Types/RepType.hs b/compiler/GHC/Types/RepType.hs index 0ef8cfe9c9..1ecae27eb8 100644 --- a/compiler/GHC/Types/RepType.hs +++ b/compiler/GHC/Types/RepType.hs @@ -13,6 +13,7 @@ module GHC.Types.RepType -- * Type representation for the code generator typePrimRep, typePrimRep1, runtimeRepPrimRep, typePrimRepArgs, + runtimeInfoPrimRep, PrimRep(..), primRepToType, countFunRepArgs, countConRepArgs, tyConPrimRep, tyConPrimRep1, @@ -34,7 +35,7 @@ import GHC.Core.TyCon.RecWalk import GHC.Core.TyCo.Rep import GHC.Core.Type import GHC.Builtin.Types.Prim -import {-# SOURCE #-} GHC.Builtin.Types ( anyTypeOfKind ) +import {-# SOURCE #-} GHC.Builtin.Types ( anyTypeOfKind, rInfo, convEvalDataConTy ) import GHC.Utils.Misc import GHC.Utils.Outputable @@ -511,9 +512,10 @@ kindPrimRep :: HasDebugCallStack => SDoc -> Kind -> [PrimRep] kindPrimRep doc ki | Just ki' <- coreView ki = kindPrimRep doc ki' -kindPrimRep doc (TyConApp typ [runtime_rep]) +kindPrimRep doc (TyConApp typ [arg]) + | Just (rinfo, [rep, conv]) <- splitTyConApp_maybe arg = ASSERT( typ `hasKey` tYPETyConKey ) - runtimeRepPrimRep doc runtime_rep + runtimeRepPrimRep doc rep kindPrimRep doc ki = pprPanic "kindPrimRep" (ppr ki $$ doc) @@ -524,13 +526,25 @@ runtimeRepPrimRep doc rr_ty | Just rr_ty' <- coreView rr_ty = runtimeRepPrimRep doc rr_ty' | TyConApp rr_dc args <- rr_ty - , RuntimeRep fun <- tyConRuntimeRepInfo rr_dc - = fun args + , RuntimeInfo fun <- tyConRuntimeRepInfo rr_dc + = concatMap reps $ fun args | otherwise = pprPanic "runtimeRepPrimRep" (doc $$ ppr rr_ty) +runtimeInfoPrimRep :: HasDebugCallStack => SDoc -> Type -> [PrimRep] +runtimeInfoPrimRep doc rr_ty + | Just rr_ty' <- coreView rr_ty + = runtimeInfoPrimRep doc rr_ty' + | TyConApp rinfo [rr_dc, cc_dc] <- rr_ty + , TyConApp rr_dc' args <- rr_dc + , RuntimeRep fun <- tyConRuntimeRepInfo rr_dc' + = fun args + | otherwise + = pprPanic "runtimeInfoPrimRep" (doc $$ ppr rr_ty) + -- | Convert a PrimRep back to a Type. Used only in the unariser to give types -- to fresh Ids. Really, only the type's representation matters. -- See also Note [RuntimeRep and PrimRep] primRepToType :: PrimRep -> Type -primRepToType = anyTypeOfKind . tYPE . primRepToRuntimeRep +primRepToType p = anyTypeOfKind . tYPE $ rinfo + where rinfo = rInfo (primRepToRuntimeRep p) convEvalDataConTy diff --git a/libraries/base/GHC/Err.hs b/libraries/base/GHC/Err.hs index f175891eca..a43d687fc1 100644 --- a/libraries/base/GHC/Err.hs +++ b/libraries/base/GHC/Err.hs @@ -23,7 +23,7 @@ ----------------------------------------------------------------------------- module GHC.Err( absentErr, error, errorWithoutStackTrace, undefined ) where -import GHC.Types (Char, RuntimeRep) +import GHC.Types (Char, RuntimeRep, RuntimeInfo) import GHC.Stack.Types import GHC.Prim import GHC.Num.Integer () -- See Note [Depend on GHC.Num.Integer] in GHC.Base @@ -32,7 +32,7 @@ import {-# SOURCE #-} GHC.Exception , errorCallException ) -- | 'error' stops execution and displays an error message. -error :: forall (r :: RuntimeRep). forall (a :: TYPE r). +error :: forall (r :: RuntimeInfo). forall (a :: TYPE r). HasCallStack => [Char] -> a error s = raise# (errorCallWithCallStackException s ?callStack) -- Bleh, we should be using 'GHC.Stack.callStack' instead of @@ -43,7 +43,7 @@ error s = raise# (errorCallWithCallStackException s ?callStack) -- | A variant of 'error' that does not produce a stack trace. -- -- @since 4.9.0.0 -errorWithoutStackTrace :: forall (r :: RuntimeRep). forall (a :: TYPE r). +errorWithoutStackTrace :: forall (r :: RuntimeInfo). forall (a :: TYPE r). [Char] -> a errorWithoutStackTrace s = raise# (errorCallException s) @@ -70,7 +70,7 @@ errorWithoutStackTrace s = raise# (errorCallException s) -- It is expected that compilers will recognize this and insert error -- messages which are more appropriate to the context in which 'undefined' -- appears. -undefined :: forall (r :: RuntimeRep). forall (a :: TYPE r). +undefined :: forall (r :: RuntimeInfo). forall (a :: TYPE r). HasCallStack => a undefined = error "Prelude.undefined" diff --git a/libraries/ghc-prim/GHC/Magic.hs b/libraries/ghc-prim/GHC/Magic.hs index cd9474271d..3f8848fecd 100644 --- a/libraries/ghc-prim/GHC/Magic.hs +++ b/libraries/ghc-prim/GHC/Magic.hs @@ -32,7 +32,7 @@ module GHC.Magic ( inline, noinline, lazy, oneShot, runRW# ) where -- because TYPE is not exported by the source Haskell module generated by -- genprimops which Haddock will typecheck (#15935). import GHC.Prim (State#, realWorld#, RealWorld) -import GHC.Types (RuntimeRep, TYPE) +import GHC.Types (RuntimeInfo, TYPE) -- | The call @inline f@ arranges that @f@ is inlined, regardless of -- its size. More precisely, the call @inline f@ rewrites to the @@ -96,7 +96,7 @@ lazy x = x -- -- 'oneShot' is representation polymorphic: the type variables may refer to lifted -- or unlifted types. -oneShot :: forall (q :: RuntimeRep) (r :: RuntimeRep) +oneShot :: forall (q :: RuntimeInfo) (r :: RuntimeInfo) (a :: TYPE q) (b :: TYPE r). (a -> b) -> a -> b oneShot f = f @@ -111,7 +111,7 @@ oneShot f = f -- 'runRW#' is representation polymorphic: the result may have a lifted or -- unlifted type. -runRW# :: forall (r :: RuntimeRep) (o :: TYPE r). +runRW# :: forall (r :: RuntimeInfo) (o :: TYPE r). (State# RealWorld -> o) -> o -- See Note [runRW magic] in GHC.CoreToStg.Prep. {-# NOINLINE runRW# #-} -- runRW# is inlined manually in CorePrep diff --git a/libraries/ghc-prim/GHC/Types.hs b/libraries/ghc-prim/GHC/Types.hs index dc81a9b8d3..6305f1cb50 100644 --- a/libraries/ghc-prim/GHC/Types.hs +++ b/libraries/ghc-prim/GHC/Types.hs @@ -33,7 +33,7 @@ module GHC.Types ( Symbol, Any, type (~~), Coercible, - TYPE, RuntimeRep(..), Type, Constraint, + TYPE, RuntimeRep(..), RuntimeInfo(..), Type, Constraint, -- The historical type * should ideally be written as -- `type *`, without the parentheses. But that's a true -- pain to parse, and for little gain. @@ -86,7 +86,7 @@ type (->) = FUN 'Many data Constraint -- | The kind of types with lifted values. For example @Int :: Type@. -type Type = TYPE 'LiftedRep +type Type = TYPE ('RInfo LiftedRep 'ConvEval) data Multiplicity = Many | One @@ -410,6 +410,11 @@ data SPEC = SPEC | SPEC2 * * ********************************************************************* -} +data Levity = Lifted | Unlifted + +data CallingConv = ConvEval +-- | ConvCall [RuntimeRep] +data RuntimeInfo = RInfo {rep :: RuntimeRep, conv :: CallingConv} -- | GHC maintains a property that the kind of all inhabited types -- (as distinct from type constructors or type-level data) tells us @@ -520,7 +525,7 @@ data KindRep = KindRepTyConApp TyCon [KindRep] | KindRepVar !KindBndr | KindRepApp KindRep KindRep | KindRepFun KindRep KindRep - | KindRepTYPE !RuntimeRep + | KindRepTYPE !RuntimeInfo | KindRepTypeLitS TypeLitSort Addr# | KindRepTypeLitD TypeLitSort [Char]