Shant Hairapetian writes:

Hi Ben, Thanks for the reply

...

Incidentally, the collapse of LiftedRep and UnliftedRep will happen in GHC 9.2 (turning into `BoxedRep :: Levity -> RuntimeRep`).

Yes I believe this change was accidentally merged a few months ago then reverted? I will keep that in mind.

It was briefly accidentally merged, then reverted, then re-applied. The final commit is 3e082f8ff5ea2f42c5e6430094683b26b5818fb8.

...

Can you provide a program that your patch rejects, as well as the full error that is produced?

My error is in stage 1 in the building of the ghc-bignum library. I have attached the full error as well as the patch itself.

See below.

Thanks, Shant

On Mon, Apr 5, 2021 at 7:41 PM Ben Gamari wrote:

...

Shant Hairapetian writes:

...

Hello,

I’m a master’s student working on implementing the changes outlined in “Kinds are Calling Conventions“ ( https://www.microsoft.com/en-us/research/uploads/prod/2020/03/kacc.pdf). I have been working directly with Paul Downen but have hit some roadblocks.

To sum up the changes to the kind system, I am attempting to modify the “TYPE” type constructor to accept, rather than just a RuntimeRep, a record type (called RuntimeInfo) comprised of a RuntimeRep and a CallingConv (calling convention). The calling convention has an “Eval” constructor which accepts a levity (effectively moving the levity information from the representation to the calling convention. LiftedRep and UnliftedRep would also be collapsed into a single PtrRep constructor) and a “Call” constructor (denoting the arity of primitive, extensional functions, see: Making a Faster Curry with Extensional Types < https://www.microsoft.com/en-us/research/uploads/prod/2019/07/arity-haskell-... ) which accepts a list of RuntimeRep’s. I have created and wired-in the new RuntimeInfo and CallingConv types in GHC.Builtin.Types, as well as the corresponding primitive types in GHC.Builtin.Types.Prim and have modified the “TYPE” constructor to accept a RuntimeInfo rather than a RuntimeRep.

Hi Shant,

It would be helpful to have a bit more information on the nature of your failure. Can you provide a program that your patch rejects, as well as the full error that is produced?

Incidentally, the collapse of LiftedRep and UnliftedRep will happen in GHC 9.2 (turning into `BoxedRep :: Levity -> RuntimeRep`).

Cheers,

- Ben

-- Shant Hairapetian

libraries/ghc-bignum/src/GHC/Num/WordArray.hs:78:22: error: • Couldn't match type: 'TupleRep ('[] @RuntimeRep) with: 'RInfo ('TupleRep ('[] @RuntimeRep)) 'GHC.Types.ConvEval Expected: (# State# s, MutableWordArray# s #) Actual: (# State# s, MutableByteArray# s #) • In the expression: newByteArray# (wordsToBytes# sz) s In an equation for ‘newWordArray#’: newWordArray# sz s = newByteArray# (wordsToBytes# sz) s | 78 | newWordArray# sz s = newByteArray# (wordsToBytes# sz) s | ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^

libraries/ghc-bignum/src/GHC/Num/WordArray.hs:112:71: error: • Couldn't match a lifted type with an unlifted type When matching types b0 :: TYPE ('RInfo 'LiftedRep 'GHC.Types.ConvEval) WordArray# :: TYPE ('RInfo 'UnliftedRep 'GHC.Types.ConvEval) Expected: (# () | WordArray# #) Actual: (# () | b0 #) • In the expression: a In a case alternative: (# _, a #) -> a In the expression: case runRW# io of { (# _, a #) -> a } • Relevant bindings include a :: (# () | b0 #) (bound at libraries/ghc-bignum/src/GHC/Num/WordArray.hs:112:63) | 112 | withNewWordArrayTrimedMaybe# sz act = case runRW# io of (# _, a #) -> a | ^

libraries/ghc-bignum/src/GHC/Num/WordArray.hs:117:40: error: • Couldn't match kind ‘RuntimeInfo’ with ‘RuntimeRep’ When matching the kind of ‘'RInfo 'LiftedRep 'GHC.Types.ConvEval’ • In the expression: () In the expression: (# () | #) In the expression: (# s, (# () | #) #) | 117 | (# s, 0# #) -> (# s, (# () | #) #) | ^^

libraries/ghc-bignum/src/GHC/Num/WordArray.hs:120:48: error: • Couldn't match kind ‘RuntimeInfo’ with ‘RuntimeRep’ When matching kinds 'RInfo 'LiftedRep 'GHC.Types.ConvEval :: RuntimeInfo 'RInfo 'UnliftedRep 'GHC.Types.ConvEval :: RuntimeInfo • In the expression: ba In the expression: (# | ba #) In the expression: (# s, (# | ba #) #) | 120 | (# s, ba #) -> (# s, (# | ba #) #) | ^^

libraries/ghc-bignum/src/GHC/Num/WordArray.hs:431:31: error: • Couldn't match type: 'TupleRep ('[] @RuntimeRep) with: 'RInfo ('TupleRep ('[] @RuntimeRep)) 'GHC.Types.ConvEval Expected: (# State# s, Word# #) Actual: (# State# s, Word# #) • In the expression: readWordArray# mwa i s2 In a case alternative: (# s2, sz #) | isTrue# (i >=# sz) -> (# s2, 0## #) | isTrue# (i <# 0#) -> (# s2, 0## #) | True -> readWordArray# mwa i s2 In the expression: case mwaSize# mwa s of { (# s2, sz #) | isTrue# (i >=# sz) -> (# s2, 0## #) | isTrue# (i <# 0#) -> (# s2, 0## #) | True -> readWordArray# mwa i s2 } | 431 | | True -> readWordArray# mwa i s2 | ^^^^^^^^^^^^^^^^^^^^^^^

libraries/ghc-bignum/src/GHC/Num/WordArray.hs:434:12: error: • Couldn't match type: 'TupleRep ('[] @RuntimeRep) with: 'RInfo ('TupleRep ('[] @RuntimeRep)) 'GHC.Types.ConvEval Expected: MutableWordArray# s -> Int# -> State# s -> (# State# s, Word# #) Actual: MutableByteArray# s -> Int# -> State# s -> (# State# s, Word# #) • In the expression: readWordArray# In an equation for ‘mwaRead#’: mwaRead# = readWordArray# | 434 | mwaRead# = readWordArray# 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

I believe your bug is here. You have filled in a RuntimeRep metavar with a RuntimeInfo. Leave this as liftedRepTy. Cheers, - Ben