diff options
| author | sheaf <sam.derbyshire@gmail.com> | 2022-01-17 10:48:11 +0100 |
|---|---|---|
| committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2022-01-26 12:01:45 -0500 |
| commit | e471a6803842db93483526f2be58b61ea3c33dc7 (patch) | |
| tree | e07383ab88832f5ae806e4b04a8a734061b60dde | |
| parent | 781323a3076781b5db50bdbeb8f64394add43836 (diff) | |
| download | haskell-e471a6803842db93483526f2be58b61ea3c33dc7.tar.gz | |
Levity-polymorphic arrays and mutable variables
This patch makes the following types levity-polymorphic in their
last argument:
- Array# a, SmallArray# a, Weak# b, StablePtr# a, StableName# a
- MutableArray# s a, SmallMutableArray# s a,
MutVar# s a, TVar# s a, MVar# s a, IOPort# s a
The corresponding primops are also made levity-polymorphic, e.g.
`newArray#`, `readArray#`, `writeMutVar#`, `writeIOPort#`, etc.
Additionally, exception handling functions such as `catch#`, `raise#`,
`maskAsyncExceptions#`,... are made levity/representation-polymorphic.
Now that Array# and MutableArray# also work with unlifted types,
we can simply re-define ArrayArray# and MutableArrayArray# in terms
of them. This means that ArrayArray# and MutableArrayArray# are no
longer primitive types, but simply unlifted newtypes around Array# and
MutableArrayArray#.
This completes the implementation of the Pointer Rep proposal
https://github.com/ghc-proposals/ghc-proposals/pull/203
Fixes #20911
-------------------------
Metric Increase:
T12545
-------------------------
-------------------------
Metric Decrease:
T12545
-------------------------
55 files changed, 1322 insertions, 423 deletions
diff --git a/compiler/GHC/Builtin/Names.hs b/compiler/GHC/Builtin/Names.hs index 89dbfa5f30..c0ebb2929b 100644 --- a/compiler/GHC/Builtin/Names.hs +++ b/compiler/GHC/Builtin/Names.hs @@ -1770,7 +1770,7 @@ hasFieldClassNameKey = mkPreludeClassUnique 50 ************************************************************************ -} -addrPrimTyConKey, arrayPrimTyConKey, arrayArrayPrimTyConKey, boolTyConKey, +addrPrimTyConKey, arrayPrimTyConKey, boolTyConKey, byteArrayPrimTyConKey, charPrimTyConKey, charTyConKey, doublePrimTyConKey, doubleTyConKey, floatPrimTyConKey, floatTyConKey, funTyConKey, intPrimTyConKey, intTyConKey, int8TyConKey, int16TyConKey, @@ -1778,7 +1778,7 @@ addrPrimTyConKey, arrayPrimTyConKey, arrayArrayPrimTyConKey, boolTyConKey, int64PrimTyConKey, int64TyConKey, integerTyConKey, naturalTyConKey, listTyConKey, foreignObjPrimTyConKey, maybeTyConKey, - weakPrimTyConKey, mutableArrayPrimTyConKey, mutableArrayArrayPrimTyConKey, + weakPrimTyConKey, mutableArrayPrimTyConKey, mutableByteArrayPrimTyConKey, orderingTyConKey, mVarPrimTyConKey, ratioTyConKey, rationalTyConKey, realWorldTyConKey, stablePtrPrimTyConKey, stablePtrTyConKey, eqTyConKey, heqTyConKey, ioPortPrimTyConKey, @@ -1825,8 +1825,6 @@ stablePtrPrimTyConKey = mkPreludeTyConUnique 38 stablePtrTyConKey = mkPreludeTyConUnique 39 eqTyConKey = mkPreludeTyConUnique 40 heqTyConKey = mkPreludeTyConUnique 41 -arrayArrayPrimTyConKey = mkPreludeTyConUnique 42 -mutableArrayArrayPrimTyConKey = mkPreludeTyConUnique 43 statePrimTyConKey, stableNamePrimTyConKey, stableNameTyConKey, mutVarPrimTyConKey, ioTyConKey, diff --git a/compiler/GHC/Builtin/Types/Prim.hs b/compiler/GHC/Builtin/Types/Prim.hs index 5eb260ce59..6570867898 100644 --- a/compiler/GHC/Builtin/Types/Prim.hs +++ b/compiler/GHC/Builtin/Types/Prim.hs @@ -66,11 +66,9 @@ module GHC.Builtin.Types.Prim( arrayPrimTyCon, mkArrayPrimTy, byteArrayPrimTyCon, byteArrayPrimTy, - arrayArrayPrimTyCon, mkArrayArrayPrimTy, smallArrayPrimTyCon, mkSmallArrayPrimTy, mutableArrayPrimTyCon, mkMutableArrayPrimTy, mutableByteArrayPrimTyCon, mkMutableByteArrayPrimTy, - mutableArrayArrayPrimTyCon, mkMutableArrayArrayPrimTy, smallMutableArrayPrimTyCon, mkSmallMutableArrayPrimTy, mutVarPrimTyCon, mkMutVarPrimTy, @@ -138,11 +136,12 @@ import GHC.Types.Unique import GHC.Builtin.Uniques import GHC.Builtin.Names import GHC.Data.FastString +import GHC.Utils.Misc ( changeLast ) import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Core.TyCo.Rep -- Doesn't need special access, but this is easier to avoid -- import loops which show up if you import Type instead -import {-# SOURCE #-} GHC.Core.Type ( mkTyConTy, mkTyConApp, mkTYPEapp ) +import {-# SOURCE #-} GHC.Core.Type ( mkTyConTy, mkTyConApp, mkTYPEapp, getLevity ) import Data.Char @@ -175,7 +174,6 @@ exposedPrimTyCons = [ addrPrimTyCon , arrayPrimTyCon , byteArrayPrimTyCon - , arrayArrayPrimTyCon , smallArrayPrimTyCon , charPrimTyCon , doublePrimTyCon @@ -189,7 +187,6 @@ exposedPrimTyCons , weakPrimTyCon , mutableArrayPrimTyCon , mutableByteArrayPrimTyCon - , mutableArrayArrayPrimTyCon , smallMutableArrayPrimTyCon , mVarPrimTyCon , ioPortPrimTyCon @@ -234,8 +231,8 @@ charPrimTyConName, intPrimTyConName, int8PrimTyConName, int16PrimTyConName, int3 wordPrimTyConName, word32PrimTyConName, word8PrimTyConName, word16PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, statePrimTyConName, proxyPrimTyConName, realWorldTyConName, - arrayPrimTyConName, arrayArrayPrimTyConName, smallArrayPrimTyConName, byteArrayPrimTyConName, - mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutableArrayArrayPrimTyConName, + arrayPrimTyConName, smallArrayPrimTyConName, byteArrayPrimTyConName, + mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, smallMutableArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, ioPortPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, compactPrimTyConName, bcoPrimTyConName, @@ -265,11 +262,9 @@ eqPhantPrimTyConName = mkBuiltInPrimTc (fsLit "~P#") eqPhantPrimTyConKe realWorldTyConName = mkPrimTc (fsLit "RealWorld") realWorldTyConKey realWorldTyCon arrayPrimTyConName = mkPrimTc (fsLit "Array#") arrayPrimTyConKey arrayPrimTyCon byteArrayPrimTyConName = mkPrimTc (fsLit "ByteArray#") byteArrayPrimTyConKey byteArrayPrimTyCon -arrayArrayPrimTyConName = mkPrimTc (fsLit "ArrayArray#") arrayArrayPrimTyConKey arrayArrayPrimTyCon smallArrayPrimTyConName = mkPrimTc (fsLit "SmallArray#") smallArrayPrimTyConKey smallArrayPrimTyCon mutableArrayPrimTyConName = mkPrimTc (fsLit "MutableArray#") mutableArrayPrimTyConKey mutableArrayPrimTyCon mutableByteArrayPrimTyConName = mkPrimTc (fsLit "MutableByteArray#") mutableByteArrayPrimTyConKey mutableByteArrayPrimTyCon -mutableArrayArrayPrimTyConName= mkPrimTc (fsLit "MutableArrayArray#") mutableArrayArrayPrimTyConKey mutableArrayArrayPrimTyCon smallMutableArrayPrimTyConName= mkPrimTc (fsLit "SmallMutableArray#") smallMutableArrayPrimTyConKey smallMutableArrayPrimTyCon mutVarPrimTyConName = mkPrimTc (fsLit "MutVar#") mutVarPrimTyConKey mutVarPrimTyCon ioPortPrimTyConName = mkPrimTc (fsLit "IOPort#") ioPortPrimTyConKey ioPortPrimTyCon @@ -644,13 +639,49 @@ functionWithMultiplicity mul = TyConApp funTyCon [mul] ************************************************************************ -} --- only used herein -pcPrimTyCon :: Name -> [Role] -> PrimRep -> TyCon -pcPrimTyCon name roles rep +-- | Create a primitive 'TyCon' with the given 'Name', +-- arguments of kind 'Type` with the given 'Role's, +-- and the given result kind representation. +-- +-- Only use this in "GHC.Builtin.Types.Prim". +pcPrimTyCon :: Name + -> [Role] -> PrimRep -> TyCon +pcPrimTyCon name roles res_rep = mkPrimTyCon name binders result_kind roles where - binders = mkTemplateAnonTyConBinders (map (const liftedTypeKind) roles) - result_kind = mkTYPEapp (primRepToRuntimeRep rep) + bndr_kis = liftedTypeKind <$ roles + binders = mkTemplateAnonTyConBinders bndr_kis + result_kind = mkTYPEapp (primRepToRuntimeRep res_rep) + +-- | Create a primitive nullary 'TyCon' with the given 'Name' +-- and result kind representation. +-- +-- Only use this in "GHC.Builtin.Types.Prim". +pcPrimTyCon0 :: Name -> PrimRep -> TyCon +pcPrimTyCon0 name res_rep + = pcPrimTyCon name [] res_rep + +-- | Create a primitive 'TyCon' like 'pcPrimTyCon', except the last +-- argument is levity-polymorphic. +-- +-- Only use this in "GHC.Builtin.Types.Prim". +pcPrimTyCon_LevPolyLastArg :: Name + -> [Role] -- ^ roles of the arguments (must be non-empty), + -- not including the implicit argument of kind 'Levity', + -- which always has 'Nominal' role + -> PrimRep + -> TyCon +pcPrimTyCon_LevPolyLastArg name roles res_rep + = mkPrimTyCon name binders result_kind (Nominal : roles) + where + result_kind = mkTYPEapp (primRepToRuntimeRep res_rep) + lev_bndr = mkNamedTyConBinder Inferred levity1TyVar + binders = lev_bndr : mkTemplateAnonTyConBinders anon_bndr_kis + lev_tv = mkTyVarTy (binderVar lev_bndr) + + -- [ Type, ..., Type, TYPE (BoxedRep l) ] + anon_bndr_kis = changeLast (liftedTypeKind <$ roles) + (mkTYPEapp $ mkTyConApp boxedRepDataConTyCon [lev_tv]) -- | Convert a 'PrimRep' to a 'Type' of kind RuntimeRep -- Defined here to avoid (more) module loops @@ -706,10 +737,6 @@ primRepsToRuntimeRep :: [PrimRep] -> Type primRepsToRuntimeRep [rep] = primRepToRuntimeRep rep primRepsToRuntimeRep reps = mkTupleRep $ map primRepToRuntimeRep reps -pcPrimTyCon0 :: Name -> PrimRep -> TyCon -pcPrimTyCon0 name rep - = pcPrimTyCon name [] rep - charPrimTy :: Type charPrimTy = mkTyConTy charPrimTyCon charPrimTyCon :: TyCon @@ -1067,33 +1094,27 @@ concretePrimTyCon = ********************************************************************* -} arrayPrimTyCon, mutableArrayPrimTyCon, mutableByteArrayPrimTyCon, - byteArrayPrimTyCon, arrayArrayPrimTyCon, mutableArrayArrayPrimTyCon, + byteArrayPrimTyCon, smallArrayPrimTyCon, smallMutableArrayPrimTyCon :: TyCon -arrayPrimTyCon = pcPrimTyCon arrayPrimTyConName [Representational] UnliftedRep -mutableArrayPrimTyCon = pcPrimTyCon mutableArrayPrimTyConName [Nominal, Representational] UnliftedRep +arrayPrimTyCon = pcPrimTyCon_LevPolyLastArg arrayPrimTyConName [Representational] UnliftedRep +mutableArrayPrimTyCon = pcPrimTyCon_LevPolyLastArg mutableArrayPrimTyConName [Nominal, Representational] UnliftedRep mutableByteArrayPrimTyCon = pcPrimTyCon mutableByteArrayPrimTyConName [Nominal] UnliftedRep byteArrayPrimTyCon = pcPrimTyCon0 byteArrayPrimTyConName UnliftedRep -arrayArrayPrimTyCon = pcPrimTyCon0 arrayArrayPrimTyConName UnliftedRep -mutableArrayArrayPrimTyCon = pcPrimTyCon mutableArrayArrayPrimTyConName [Nominal] UnliftedRep -smallArrayPrimTyCon = pcPrimTyCon smallArrayPrimTyConName [Representational] UnliftedRep -smallMutableArrayPrimTyCon = pcPrimTyCon smallMutableArrayPrimTyConName [Nominal, Representational] UnliftedRep +smallArrayPrimTyCon = pcPrimTyCon_LevPolyLastArg smallArrayPrimTyConName [Representational] UnliftedRep +smallMutableArrayPrimTyCon = pcPrimTyCon_LevPolyLastArg smallMutableArrayPrimTyConName [Nominal, Representational] UnliftedRep mkArrayPrimTy :: Type -> Type -mkArrayPrimTy elt = TyConApp arrayPrimTyCon [elt] +mkArrayPrimTy elt = TyConApp arrayPrimTyCon [getLevity elt, elt] byteArrayPrimTy :: Type byteArrayPrimTy = mkTyConTy byteArrayPrimTyCon -mkArrayArrayPrimTy :: Type -mkArrayArrayPrimTy = mkTyConTy arrayArrayPrimTyCon mkSmallArrayPrimTy :: Type -> Type -mkSmallArrayPrimTy elt = TyConApp smallArrayPrimTyCon [elt] +mkSmallArrayPrimTy elt = TyConApp smallArrayPrimTyCon [getLevity elt, elt] mkMutableArrayPrimTy :: Type -> Type -> Type -mkMutableArrayPrimTy s elt = TyConApp mutableArrayPrimTyCon [s, elt] +mkMutableArrayPrimTy s elt = TyConApp mutableArrayPrimTyCon [getLevity elt, s, elt] mkMutableByteArrayPrimTy :: Type -> Type mkMutableByteArrayPrimTy s = TyConApp mutableByteArrayPrimTyCon [s] -mkMutableArrayArrayPrimTy :: Type -> Type -mkMutableArrayArrayPrimTy s = TyConApp mutableArrayArrayPrimTyCon [s] mkSmallMutableArrayPrimTy :: Type -> Type -> Type -mkSmallMutableArrayPrimTy s elt = TyConApp smallMutableArrayPrimTyCon [s, elt] +mkSmallMutableArrayPrimTy s elt = TyConApp smallMutableArrayPrimTyCon [getLevity elt, s, elt] {- ********************************************************************* @@ -1103,10 +1124,10 @@ mkSmallMutableArrayPrimTy s elt = TyConApp smallMutableArrayPrimTyCon [s, elt] ********************************************************************* -} mutVarPrimTyCon :: TyCon -mutVarPrimTyCon = pcPrimTyCon mutVarPrimTyConName [Nominal, Representational] UnliftedRep +mutVarPrimTyCon = pcPrimTyCon_LevPolyLastArg mutVarPrimTyConName [Nominal, Representational] UnliftedRep mkMutVarPrimTy :: Type -> Type -> Type -mkMutVarPrimTy s elt = TyConApp mutVarPrimTyCon [s, elt] +mkMutVarPrimTy s elt = TyConApp mutVarPrimTyCon [getLevity elt, s, elt] {- ************************************************************************ @@ -1117,10 +1138,10 @@ mkMutVarPrimTy s elt = TyConApp mutVarPrimTyCon [s, elt] -} ioPortPrimTyCon :: TyCon -ioPortPrimTyCon = pcPrimTyCon ioPortPrimTyConName [Nominal, Representational] UnliftedRep +ioPortPrimTyCon = pcPrimTyCon_LevPolyLastArg ioPortPrimTyConName [Nominal, Representational] UnliftedRep mkIOPortPrimTy :: Type -> Type -> Type -mkIOPortPrimTy s elt = TyConApp ioPortPrimTyCon [s, elt] +mkIOPortPrimTy s elt = TyConApp ioPortPrimTyCon [getLevity elt, s, elt] {- ************************************************************************ @@ -1132,10 +1153,10 @@ mkIOPortPrimTy s elt = TyConApp ioPortPrimTyCon [s, elt] -} mVarPrimTyCon :: TyCon -mVarPrimTyCon = pcPrimTyCon mVarPrimTyConName [Nominal, Representational] UnliftedRep +mVarPrimTyCon = pcPrimTyCon_LevPolyLastArg mVarPrimTyConName [Nominal, Representational] UnliftedRep mkMVarPrimTy :: Type -> Type -> Type -mkMVarPrimTy s elt = TyConApp mVarPrimTyCon [s, elt] +mkMVarPrimTy s elt = TyConApp mVarPrimTyCon [getLevity elt, s, elt] {- ************************************************************************ @@ -1146,10 +1167,10 @@ mkMVarPrimTy s elt = TyConApp mVarPrimTyCon [s, elt] -} tVarPrimTyCon :: TyCon -tVarPrimTyCon = pcPrimTyCon tVarPrimTyConName [Nominal, Representational] UnliftedRep +tVarPrimTyCon = pcPrimTyCon_LevPolyLastArg tVarPrimTyConName [Nominal, Representational] UnliftedRep mkTVarPrimTy :: Type -> Type -> Type -mkTVarPrimTy s elt = TyConApp tVarPrimTyCon [s, elt] +mkTVarPrimTy s elt = TyConApp tVarPrimTyCon [getLevity elt, s, elt] {- ************************************************************************ @@ -1160,10 +1181,10 @@ mkTVarPrimTy s elt = TyConApp tVarPrimTyCon [s, elt] -} stablePtrPrimTyCon :: TyCon -stablePtrPrimTyCon = pcPrimTyCon stablePtrPrimTyConName [Representational] AddrRep +stablePtrPrimTyCon = pcPrimTyCon_LevPolyLastArg stablePtrPrimTyConName [Representational] AddrRep mkStablePtrPrimTy :: Type -> Type -mkStablePtrPrimTy ty = TyConApp stablePtrPrimTyCon [ty] +mkStablePtrPrimTy ty = TyConApp stablePtrPrimTyCon [getLevity ty, ty] {- ************************************************************************ @@ -1174,10 +1195,10 @@ mkStablePtrPrimTy ty = TyConApp stablePtrPrimTyCon [ty] -} stableNamePrimTyCon :: TyCon -stableNamePrimTyCon = pcPrimTyCon stableNamePrimTyConName [Phantom] UnliftedRep +stableNamePrimTyCon = pcPrimTyCon_LevPolyLastArg stableNamePrimTyConName [Phantom] UnliftedRep mkStableNamePrimTy :: Type -> Type -mkStableNamePrimTy ty = TyConApp stableNamePrimTyCon [ty] +mkStableNamePrimTy ty = TyConApp stableNamePrimTyCon [getLevity ty, ty] {- ************************************************************************ @@ -1233,10 +1254,10 @@ bcoPrimTyCon = pcPrimTyCon0 bcoPrimTyConName LiftedRep -} weakPrimTyCon :: TyCon -weakPrimTyCon = pcPrimTyCon weakPrimTyConName [Representational] UnliftedRep +weakPrimTyCon = pcPrimTyCon_LevPolyLastArg weakPrimTyConName [Representational] UnliftedRep mkWeakPrimTy :: Type -> Type -mkWeakPrimTy v = TyConApp weakPrimTyCon [v] +mkWeakPrimTy v = TyConApp weakPrimTyCon [getLevity v, v] {- ************************************************************************ diff --git a/compiler/GHC/Builtin/primops.txt.pp b/compiler/GHC/Builtin/primops.txt.pp index b2a45ad79f..092be8e26a 100644 --- a/compiler/GHC/Builtin/primops.txt.pp +++ b/compiler/GHC/Builtin/primops.txt.pp @@ -1340,7 +1340,7 @@ primtype Array# a primtype MutableArray# s a primop NewArrayOp "newArray#" GenPrimOp - Int# -> a -> State# s -> (# State# s, MutableArray# s a #) + Int# -> v -> State# s -> (# State# s, MutableArray# s v #) {Create a new mutable array with the specified number of elements, in the specified state thread, with each element containing the specified initial value.} @@ -1349,14 +1349,14 @@ primop NewArrayOp "newArray#" GenPrimOp has_side_effects = True primop ReadArrayOp "readArray#" GenPrimOp - MutableArray# s a -> Int# -> State# s -> (# State# s, a #) + MutableArray# s v -> Int# -> State# s -> (# State# s, v #) {Read from specified index of mutable array. Result is not yet evaluated.} with has_side_effects = True can_fail = True primop WriteArrayOp "writeArray#" GenPrimOp - MutableArray# s a -> Int# -> a -> State# s -> State# s + MutableArray# s v -> Int# -> v -> State# s -> State# s {Write to specified index of mutable array.} with has_side_effects = True @@ -1364,15 +1364,15 @@ primop WriteArrayOp "writeArray#" GenPrimOp code_size = 2 -- card update too primop SizeofArrayOp "sizeofArray#" GenPrimOp - Array# a -> Int# + Array# v -> Int# {Return the number of elements in the array.} primop SizeofMutableArrayOp "sizeofMutableArray#" GenPrimOp - MutableArray# s a -> Int# + MutableArray# s v -> Int# {Return the number of elements in the array.} primop IndexArrayOp "indexArray#" GenPrimOp - Array# a -> Int# -> (# a #) + Array# v -> Int# -> (# v #) {Read from the specified index of an immutable array. The result is packaged into an unboxed unary tuple; the result itself is not yet evaluated. Pattern matching on the tuple forces the indexing of the @@ -1384,20 +1384,20 @@ primop IndexArrayOp "indexArray#" GenPrimOp can_fail = True primop UnsafeFreezeArrayOp "unsafeFreezeArray#" GenPrimOp - MutableArray# s a -> State# s -> (# State# s, Array# a #) + MutableArray# s v -> State# s -> (# State# s, Array# v #) {Make a mutable array immutable, without copying.} with has_side_effects = True primop UnsafeThawArrayOp "unsafeThawArray#" GenPrimOp - Array# a -> State# s -> (# State# s, MutableArray# s a #) + Array# v -> State# s -> (# State# s, MutableArray# s v #) {Make an immutable array mutable, without copying.} with out_of_line = True has_side_effects = True primop CopyArrayOp "copyArray#" GenPrimOp - Array# a -> Int# -> MutableArray# s a -> Int# -> Int# -> State# s -> State# s + Array# v -> Int# -> MutableArray# s v -> Int# -> Int# -> State# s -> State# s {Given a source array, an offset into the source array, a destination array, an offset into the destination array, and a number of elements to copy, copy the elements from the source array @@ -1411,7 +1411,7 @@ primop CopyArrayOp "copyArray#" GenPrimOp can_fail = True primop CopyMutableArrayOp "copyMutableArray#" GenPrimOp - MutableArray# s a -> Int# -> MutableArray# s a -> Int# -> Int# -> State# s -> State# s + MutableArray# s v -> Int# -> MutableArray# s v -> Int# -> Int# -> State# s -> State# s {Given a source array, an offset into the source array, a destination array, an offset into the destination array, and a number of elements to copy, copy the elements from the source array @@ -1425,7 +1425,7 @@ primop CopyMutableArrayOp "copyMutableArray#" GenPrimOp can_fail = True primop CloneArrayOp "cloneArray#" GenPrimOp - Array# a -> Int# -> Int# -> Array# a + Array# v -> Int# -> Int# -> Array# v {Given a source array, an offset into the source array, and a number of elements to copy, create a new array with the elements from the source array. The provided array must fully contain the specified @@ -1436,7 +1436,7 @@ primop CloneArrayOp "cloneArray#" GenPrimOp can_fail = True primop CloneMutableArrayOp "cloneMutableArray#" GenPrimOp - MutableArray# s a -> Int# -> Int# -> State# s -> (# State# s, MutableArray# s a #) + MutableArray# s v -> Int# -> Int# -> State# s -> (# State# s, MutableArray# s v #) {Given a source array, an offset into the source array, and a number of elements to copy, create a new array with the elements from the source array. The provided array must fully contain the specified @@ -1447,7 +1447,7 @@ primop CloneMutableArrayOp "cloneMutableArray#" GenPrimOp can_fail = True primop FreezeArrayOp "freezeArray#" GenPrimOp - MutableArray# s a -> Int# -> Int# -> State# s -> (# State# s, Array# a #) + MutableArray# s v -> Int# -> Int# -> State# s -> (# State# s, Array# v #) {Given a source array, an offset into the source array, and a number of elements to copy, create a new array with the elements from the source array. The provided array must fully contain the specified @@ -1458,7 +1458,7 @@ primop FreezeArrayOp "freezeArray#" GenPrimOp can_fail = True primop ThawArrayOp "thawArray#" GenPrimOp - Array# a -> Int# -> Int# -> State# s -> (# State# s, MutableArray# s a #) + Array# v -> Int# -> Int# -> State# s -> (# State# s, MutableArray# s v #) {Given a source array, an offset into the source array, and a number of elements to copy, create a new array with the elements from the source array. The provided array must fully contain the specified @@ -1469,7 +1469,7 @@ primop ThawArrayOp "thawArray#" GenPrimOp can_fail = True primop CasArrayOp "casArray#" GenPrimOp - MutableArray# s a -> Int# -> a -> a -> State# s -> (# State# s, Int#, a #) + MutableArray# s v -> Int# -> v -> v -> State# s -> (# State# s, Int#, v #) {Given an array, an offset, the expected old value, and the new value, perform an atomic compare and swap (i.e. write the new value if the current value and the old value are the same pointer). @@ -1477,7 +1477,7 @@ primop CasArrayOp "casArray#" GenPrimOp the element at the offset after the operation completes. This means that on a success the new value is returned, and on a failure the actual old value (not the expected one) is returned. Implies a full memory barrier. - The use of a pointer equality on a lifted value makes this function harder + The use of a pointer equality on a boxed value makes this function harder to use correctly than {\tt casIntArray\#}. All of the difficulties of using {\tt reallyUnsafePtrEquality\#} correctly apply to {\tt casArray\#} as well. @@ -1516,7 +1516,7 @@ primtype SmallArray# a primtype SmallMutableArray# s a primop NewSmallArrayOp "newSmallArray#" GenPrimOp - Int# -> a -> State# s -> (# State# s, SmallMutableArray# s a #) + Int# -> v -> State# s -> (# State# s, SmallMutableArray# s v #) {Create a new mutable array with the specified number of elements, in the specified state thread, with each element containing the specified initial value.} @@ -1525,7 +1525,7 @@ primop NewSmallArrayOp "newSmallArray#" GenPrimOp has_side_effects = True primop ShrinkSmallMutableArrayOp_Char "shrinkSmallMutableArray#" GenPrimOp - SmallMutableArray# s a -> Int# -> State# s -> State# s + SmallMutableArray# s v -> Int# -> State# s -> State# s {Shrink mutable array to new specified size, in the specified state thread. The new size argument must be less than or equal to the current size as reported by {\tt getSizeofSmallMutableArray\#}.} @@ -1533,49 +1533,49 @@ primop ShrinkSmallMutableArrayOp_Char "shrinkSmallMutableArray#" GenPrimOp has_side_effects = True primop ReadSmallArrayOp "readSmallArray#" GenPrimOp - SmallMutableArray# s a -> Int# -> State# s -> (# State# s, a #) + SmallMutableArray# s v -> Int# -> State# s -> (# State# s, v #) {Read from specified index of mutable array. Result is not yet evaluated.} with has_side_effects = True can_fail = True primop WriteSmallArrayOp "writeSmallArray#" GenPrimOp - SmallMutableArray# s a -> Int# -> a -> State# s -> State# s + SmallMutableArray# s v -> Int# -> v -> State# s -> State# s {Write to specified index of mutable array.} with has_side_effects = True can_fail = True primop SizeofSmallArrayOp "sizeofSmallArray#" GenPrimOp - SmallArray# a -> Int# + SmallArray# v -> Int# {Return the number of elements in the array.} primop SizeofSmallMutableArrayOp "sizeofSmallMutableArray#" GenPrimOp - SmallMutableArray# s a -> Int# + SmallMutableArray# s v -> Int# {Return the number of elements in the array. Note that this is deprecated as it is unsafe in the presence of shrink and resize operations on the same small mutable array.} with deprecated_msg = { Use 'getSizeofSmallMutableArray#' instead } primop GetSizeofSmallMutableArrayOp "getSizeofSmallMutableArray#" GenPrimOp - SmallMutableArray# s a -> State# s -> (# State# s, Int# #) + SmallMutableArray# s v -> State# s -> (# State# s, Int# #) {Return the number of elements in the array.} primop IndexSmallArrayOp "indexSmallArray#" GenPrimOp - SmallArray# a -> Int# -> (# a #) + SmallArray# v -> Int# -> (# v #) {Read from specified index of immutable array. Result is packaged into an unboxed singleton; the result itself is not yet evaluated.} with can_fail = True primop UnsafeFreezeSmallArrayOp "unsafeFreezeSmallArray#" GenPrimOp - SmallMutableArray# s a -> State# s -> (# State# s, SmallArray# a #) + SmallMutableArray# s v -> State# s -> (# State# s, SmallArray# v #) {Make a mutable array immutable, without copying.} with has_side_effects = True primop UnsafeThawSmallArrayOp "unsafeThawSmallArray#" GenPrimOp - SmallArray# a -> State# s -> (# State# s, SmallMutableArray# s a #) + SmallArray# v -> State# s -> (# State# s, SmallMutableArray# s v #) {Make an immutable array mutable, without copying.} with out_of_line = True @@ -1585,7 +1585,7 @@ primop UnsafeThawSmallArrayOp "unsafeThawSmallArray#" GenPrimOp -- primops aren't inlined. It would be nice to keep track of both. primop CopySmallArrayOp "copySmallArray#" GenPrimOp - SmallArray# a -> Int# -> SmallMutableArray# s a -> Int# -> Int# -> State# s -> State# s + SmallArray# v -> Int# -> SmallMutableArray# s v -> Int# -> Int# -> State# s -> State# s {Given a source array, an offset into the source array, a destination array, an offset into the destination array, and a number of elements to copy, copy the elements from the source array @@ -1599,7 +1599,7 @@ primop CopySmallArrayOp "copySmallArray#" GenPrimOp can_fail = True primop CopySmallMutableArrayOp "copySmallMutableArray#" GenPrimOp - SmallMutableArray# s a -> Int# -> SmallMutableArray# s a -> Int# -> Int# -> State# s -> State# s + SmallMutableArray# s v -> Int# -> SmallMutableArray# s v -> Int# -> Int# -> State# s -> State# s {Given a source array, an offset into the source array, a destination array, an offset into the destination array, and a number of elements to copy, copy the elements from the source array @@ -1614,7 +1614,7 @@ primop CopySmallMutableArrayOp "copySmallMutableArray#" GenPrimOp can_fail = True primop CloneSmallArrayOp "cloneSmallArray#" GenPrimOp - SmallArray# a -> Int# -> Int# -> SmallArray# a + SmallArray# v -> Int# -> Int# -> SmallArray# v {Given a source array, an offset into the source array, and a number of elements to copy, create a new array with the elements from the source array. The provided array must fully contain the specified @@ -1625,7 +1625,7 @@ primop CloneSmallArrayOp "cloneSmallArray#" GenPrimOp can_fail = True primop CloneSmallMutableArrayOp "cloneSmallMutableArray#" GenPrimOp - SmallMutableArray# s a -> Int# -> Int# -> State# s -> (# State# s, SmallMutableArray# s a #) + SmallMutableArray# s v -> Int# -> Int# -> State# s -> (# State# s, SmallMutableArray# s v #) {Given a source array, an offset into the source array, and a number of elements to copy, create a new array with the elements from the source array. The provided array must fully contain the specified @@ -1636,7 +1636,7 @@ primop CloneSmallMutableArrayOp "cloneSmallMutableArray#" GenPrimOp can_fail = True primop FreezeSmallArrayOp "freezeSmallArray#" GenPrimOp - SmallMutableArray# s a -> Int# -> Int# -> State# s -> (# State# s, SmallArray# a #) + SmallMutableArray# s v -> Int# -> Int# -> State# s -> (# State# s, SmallArray# v #) {Given a source array, an offset into the source array, and a number of elements to copy, create a new array with the elements from the source array. The provided array must fully contain the specified @@ -1647,7 +1647,7 @@ primop FreezeSmallArrayOp "freezeSmallArray#" GenPrimOp can_fail = True primop ThawSmallArrayOp "thawSmallArray#" GenPrimOp - SmallArray# a -> Int# -> Int# -> State# s -> (# State# s, SmallMutableArray# s a #) + SmallArray# v -> Int# -> Int# -> State# s -> (# State# s, SmallMutableArray# s v #) {Given a source array, an offset into the source array, and a number of elements to copy, create a new array with the elements from the source array. The provided array must fully contain the specified @@ -1658,7 +1658,7 @@ primop ThawSmallArrayOp "thawSmallArray#" GenPrimOp can_fail = True primop CasSmallArrayOp "casSmallArray#" GenPrimOp - SmallMutableArray# s a -> Int# -> a -> a -> State# s -> (# State# s, Int#, a #) + SmallMutableArray# s v -> Int# -> v -> v -> State# s -> (# State# s, Int#, v #) {Unsafe, machine-level atomic compare and swap on an element within an array. See the documentation of {\tt casArray\#}.} with @@ -1970,114 +1970,6 @@ primop FetchXorByteArrayOp_Int "fetchXorIntArray#" GenPrimOp with has_side_effects = True can_fail = True - ------------------------------------------------------------------------- -section "Arrays of arrays" - {Operations on {\tt ArrayArray\#}. An {\tt ArrayArray\#} contains references to {\em unpointed} - arrays, such as {\tt ByteArray\#s}. Hence, it is not parameterised by the element types, - just like a {\tt ByteArray\#}, but it needs to be scanned during GC, just like an {\tt Array\#}. - We represent an {\tt ArrayArray\#} exactly as a {\tt Array\#}, but provide element-type-specific - indexing, reading, and writing.} ------------------------------------------------------------------------- - -primtype ArrayArray# - -primtype MutableArrayArray# s - -primop NewArrayArrayOp "newArrayArray#" GenPrimOp - Int# -> State# s -> (# State# s, MutableArrayArray# s #) - {Create a new mutable array of arrays with the specified number of elements, - in the specified state thread, with each element recursively referring to the - newly created array.} - with - out_of_line = True - has_side_effects = True - -primop UnsafeFreezeArrayArrayOp "unsafeFreezeArrayArray#" GenPrimOp - MutableArrayArray# s -> State# s -> (# State# s, ArrayArray# #) - {Make a mutable array of arrays immutable, without copying.} - with - has_side_effects = True - -primop SizeofArrayArrayOp "sizeofArrayArray#" GenPrimOp - ArrayArray# -> Int# - {Return the number of elements in the array.} - -primop SizeofMutableArrayArrayOp "sizeofMutableArrayArray#" GenPrimOp - MutableArrayArray# s -> Int# - {Return the number of elements in the array.} - -primop IndexArrayArrayOp_ByteArray "indexByteArrayArray#" GenPrimOp - ArrayArray# -> Int# -> ByteArray# - with can_fail = True - -primop IndexArrayArrayOp_ArrayArray "indexArrayArrayArray#" GenPrimOp - ArrayArray# -> Int# -> ArrayArray# - with can_fail = True - -primop ReadArrayArrayOp_ByteArray "readByteArrayArray#" GenPrimOp - MutableArrayArray# s -> Int# -> State# s -> (# State# s, ByteArray# #) - with has_side_effects = True - can_fail = True - -primop ReadArrayArrayOp_MutableByteArray "readMutableByteArrayArray#" GenPrimOp - MutableArrayArray# s -> Int# -> State# s -> (# State# s, MutableByteArray# s #) - with has_side_effects = True - can_fail = True - -primop ReadArrayArrayOp_ArrayArray "readArrayArrayArray#" GenPrimOp - MutableArrayArray# s -> Int# -> State# s -> (# State# s, ArrayArray# #) - with has_side_effects = True - can_fail = True - -primop ReadArrayArrayOp_MutableArrayArray "readMutableArrayArrayArray#" GenPrimOp - MutableArrayArray# s -> Int# -> State# s -> (# State# s, MutableArrayArray# s #) - with has_side_effects = True - can_fail = True - -primop WriteArrayArrayOp_ByteArray "writeByteArrayArray#" GenPrimOp - MutableArrayArray# s -> Int# -> ByteArray# -> State# s -> State# s - with has_side_effects = True - can_fail = True - -primop WriteArrayArrayOp_MutableByteArray "writeMutableByteArrayArray#" GenPrimOp - MutableArrayArray# s -> Int# -> MutableByteArray# s -> State# s -> State# s - with has_side_effects = True - can_fail = True - -primop WriteArrayArrayOp_ArrayArray "writeArrayArrayArray#" GenPrimOp - MutableArrayArray# s -> Int# -> ArrayArray# -> State# s -> State# s - with has_side_effects = True - can_fail = True - -primop WriteArrayArrayOp_MutableArrayArray "writeMutableArrayArrayArray#" GenPrimOp - MutableArrayArray# s -> Int# -> MutableArrayArray# s -> State# s -> State# s - with has_side_effects = True - can_fail = True - -primop CopyArrayArrayOp "copyArrayArray#" GenPrimOp - ArrayArray# -> Int# -> MutableArrayArray# s -> Int# -> Int# -> State# s -> State# s - {Copy a range of the ArrayArray\# to the specified region in the MutableArrayArray\#. - Both arrays must fully contain the specified ranges, but this is not checked. - The two arrays must not be the same array in different states, but this is not checked either.} - with - out_of_line = True - has_side_effects = True - can_fail = True - -primop CopyMutableArrayArrayOp "copyMutableArrayArray#" GenPrimOp - MutableArrayArray# s -> Int# -> MutableArrayArray# s -> Int# -> Int# -> State# s -> State# s - {Copy a range of the first MutableArrayArray# to the specified region in the second - MutableArrayArray#. - Both arrays must fully contain the specified ranges, but this is not checked. - The regions are allowed to overlap, although this is only possible when the same - array is provided as both the source and the destination. - } - with - out_of_line = True - has_side_effects = True - can_fail = True - ------------------------------------------------------------------------ section "Addr#" ------------------------------------------------------------------------ @@ -2508,7 +2400,7 @@ primtype MutVar# s a {A {\tt MutVar\#} behaves like a single-element mutable array.} primop NewMutVarOp "newMutVar#" GenPrimOp - a -> State# s -> (# State# s, MutVar# s a #) + v -> State# s -> (# State# s, MutVar# s v #) {Create {\tt MutVar\#} with specified initial value in specified state thread.} with out_of_line = True @@ -2529,14 +2421,14 @@ primop NewMutVarOp "newMutVar#" GenPrimOp -- at least. primop ReadMutVarOp "readMutVar#" GenPrimOp - MutVar# s a -> State# s -> (# State# s, a #) + MutVar# s v -> State# s -> (# State# s, v #) {Read contents of {\tt MutVar\#}. Result is not yet evaluated.} with -- See Note [Why MutVar# ops can't fail] has_side_effects = True primop WriteMutVarOp "writeMutVar#" GenPrimOp - MutVar# s a -> a -> State# s -> State# s + MutVar# s v -> v -> State# s -> State# s {Write contents of {\tt MutVar\#}.} with -- See Note [Why MutVar# ops can't fail] @@ -2580,7 +2472,22 @@ primop AtomicModifyMutVar_Op "atomicModifyMutVar_#" GenPrimOp can_fail = True primop CasMutVarOp "casMutVar#" GenPrimOp - MutVar# s a -> a -> a -> State# s -> (# State# s, Int#, a #) + MutVar# s v -> v -> v -> State# s -> (# State# s, Int#, v #) + { Compare-and-swap: perform a pointer equality test between + the first value passed to this function and the value + stored inside the {\tt MutVar\#}. If the pointers are equal, + replace the stored value with the second value passed to this + function, otherwise do nothing. + Returns the final value stored inside the {\tt MutVar\#}. + The {\tt Int\#} indicates whether a swap took place, + with {\tt 1\#} meaning that we didn't swap, and {\tt 0\#} + that we did. + Implies a full memory barrier. + Because the comparison is done on the level of pointers, + all of the difficulties of using + {\tt reallyUnsafePtrEquality\#} correctly apply to + {\tt casMutVar\#} as well. + } with out_of_line = True has_side_effects = True @@ -2603,10 +2510,10 @@ section "Exceptions" -- head-strict in 'ma': GHC.IO.catchException. primop CatchOp "catch#" GenPrimOp - (State# RealWorld -> (# State# RealWorld, a #) ) - -> (b -> State# RealWorld -> (# State# RealWorld, a #) ) + (State# RealWorld -> (# State# RealWorld, o #) ) + -> (w -> State# RealWorld -> (# State# RealWorld, o #) ) -> State# RealWorld - -> (# State# RealWorld, a #) + -> (# State# RealWorld, o #) with strictness = { \ _arity -> mkClosedDmdSig [ lazyApply1Dmd , lazyApply2Dmd @@ -2616,9 +2523,9 @@ primop CatchOp "catch#" GenPrimOp has_side_effects = True primop RaiseOp "raise#" GenPrimOp - a -> p - -- NB: "p" is the same as "b" except it is representation-polymorphic - -- (we shouldn't use "o" here as that would conflict with "a") + v -> p + -- NB: "v" is the same as "a" except levity-polymorphic, + -- and "p" is the same as "b" except representation-polymorphic -- See Note [Levity and representation polymorphic primops] with -- In contrast to 'raiseIO#', which throws a *precise* exception, @@ -2633,7 +2540,7 @@ primop RaiseOp "raise#" GenPrimOp can_fail = True primop RaiseIOOp "raiseIO#" GenPrimOp - a -> State# RealWorld -> (# State# RealWorld, b #) + v -> State# RealWorld -> (# State# RealWorld, p #) with -- See Note [Precise exceptions and strictness analysis] in "GHC.Types.Demand" -- for why this is the *only* primop that has 'exnDiv' @@ -2642,8 +2549,8 @@ primop RaiseIOOp "raiseIO#" GenPrimOp has_side_effects = True primop MaskAsyncExceptionsOp "maskAsyncExceptions#" GenPrimOp - (State# RealWorld -> (# State# RealWorld, a #)) - -> (State# RealWorld -> (# State# RealWorld, a #)) + (State# RealWorld -> (# State# RealWorld, o #)) + -> (State# RealWorld -> (# State# RealWorld, o #)) with strictness = { \ _arity -> mkClosedDmdSig [strictOnceApply1Dmd,topDmd] topDiv } -- See Note [Strictness for mask/unmask/catch] @@ -2651,16 +2558,16 @@ primop MaskAsyncExceptionsOp "maskAsyncExceptions#" GenPrimOp has_side_effects = True primop MaskUninterruptibleOp "maskUninterruptible#" GenPrimOp - (State# RealWorld -> (# State# RealWorld, a #)) - -> (State# RealWorld -> (# State# RealWorld, a #)) + (State# RealWorld -> (# State# RealWorld, o #)) + -> (State# RealWorld -> (# State# RealWorld, o #)) with strictness = { \ _arity -> mkClosedDmdSig [strictOnceApply1Dmd,topDmd] topDiv } out_of_line = True has_side_effects = True primop UnmaskAsyncExceptionsOp "unmaskAsyncExceptions#" GenPrimOp - (State# RealWorld -> (# State# RealWorld, a #)) - -> (State# RealWorld -> (# State# RealWorld, a #)) + (State# RealWorld -> (# State# RealWorld, o #)) + -> (State# RealWorld -> (# State# RealWorld, o #)) with strictness = { \ _arity -> mkClosedDmdSig [strictOnceApply1Dmd,topDmd] topDiv } -- See Note [Strictness for mask/unmask/catch] @@ -2680,8 +2587,8 @@ section "STM-accessible Mutable Variables" primtype TVar# s a primop AtomicallyOp "atomically#" GenPrimOp - (State# RealWorld -> (# State# RealWorld, a #) ) - -> State# RealWorld -> (# State# RealWorld, a #) + (State# RealWorld -> (# State# RealWorld, v #) ) + -> State# RealWorld -> (# State# RealWorld, v #) with strictness = { \ _arity -> mkClosedDmdSig [strictManyApply1Dmd,topDmd] topDiv } -- See Note [Strictness for mask/unmask/catch] @@ -2699,16 +2606,16 @@ primop AtomicallyOp "atomically#" GenPrimOp -- retry# s1 -- where 'e' would be unreachable anyway. See #8091. primop RetryOp "retry#" GenPrimOp - State# RealWorld -> (# State# RealWorld, a #) + State# RealWorld -> (# State# RealWorld, v #) with strictness = { \ _arity -> mkClosedDmdSig [topDmd] botDiv } out_of_line = True has_side_effects = True primop CatchRetryOp "catchRetry#" GenPrimOp - (State# RealWorld -> (# State# RealWorld, a #) ) - -> (State# RealWorld -> (# State# RealWorld, a #) ) - -> (State# RealWorld -> (# State# RealWorld, a #) ) + (State# RealWorld -> (# State# RealWorld, v #) ) + -> (State# RealWorld -> (# State# RealWorld, v #) ) + -> (State# RealWorld -> (# State# RealWorld, v #) ) with strictness = { \ _arity -> mkClosedDmdSig [ lazyApply1Dmd , lazyApply1Dmd @@ -2718,9 +2625,9 @@ primop CatchRetryOp "catchRetry#" GenPrimOp has_side_effects = True primop CatchSTMOp "catchSTM#" GenPrimOp - (State# RealWorld -> (# State# RealWorld, a #) ) - -> (b -> State# RealWorld -> (# State# RealWorld, a #) ) - -> (State# RealWorld -> (# State# RealWorld, a #) ) + (State# RealWorld -> (# State# RealWorld, v #) ) + -> (b -> State# RealWorld -> (# State# RealWorld, v #) ) + -> (State# RealWorld -> (# State# RealWorld, v #) ) with strictness = { \ _arity -> mkClosedDmdSig [ lazyApply1Dmd , lazyApply2Dmd @@ -2730,32 +2637,35 @@ primop CatchSTMOp "catchSTM#" GenPrimOp has_side_effects = True primop NewTVarOp "newTVar#" GenPrimOp - a - -> State# s -> (# State# s, TVar# s a #) + v + -> State# s -> (# State# s, TVar# s v #) {Create a new {\tt TVar\#} holding a specified initial value.} with out_of_line = True has_side_effects = True primop ReadTVarOp "readTVar#" GenPrimOp - TVar# s a - -> State# s -> (# State# s, a #) - {Read contents of {\tt TVar\#}. Result is not yet evaluated.} + TVar# s v + -> State# s -> (# State# s, v #) + {Read contents of {\tt TVar\#} inside an STM transaction, + i.e. within a call to {\tt atomically\#}. + Does not force evaluation of the result.} with out_of_line = True has_side_effects = True primop ReadTVarIOOp "readTVarIO#" GenPrimOp - TVar# s a - -> State# s -> (# State# s, a #) - {Read contents of {\tt TVar\#} outside an STM transaction} + TVar# s v + -> State# s -> (# State# s, v #) + {Read contents of {\tt TVar\#} outside an STM transaction. + Does not force evaluation of the result.} with out_of_line = True has_side_effects = True primop WriteTVarOp "writeTVar#" GenPrimOp - TVar# s a - -> a + TVar# s v + -> v -> State# s -> State# s {Write contents of {\tt TVar\#}.} with @@ -2774,14 +2684,14 @@ primtype MVar# s a represented by {\tt (MutVar\# (Maybe a))}.) } primop NewMVarOp "newMVar#" GenPrimOp - State# s -> (# State# s, MVar# s a #) + State# s -> (# State# s, MVar# s v #) {Create new {\tt MVar\#}; initially empty.} with out_of_line = True has_side_effects = True primop TakeMVarOp "takeMVar#" GenPrimOp - MVar# s a -> State# s -> (# State# s, a #) + MVar# s v -> State# s -> (# State# s, v #) {If {\tt MVar\#} is empty, block until it becomes full. Then remove and return its contents, and set it empty.} with @@ -2789,7 +2699,7 @@ primop TakeMVarOp "takeMVar#" GenPrimOp has_side_effects = True primop TryTakeMVarOp "tryTakeMVar#" GenPrimOp - MVar# s a -> State# s -> (# State# s, Int#, a #) + MVar# s v -> State# s -> (# State# s, Int#, v #) {If {\tt MVar\#} is empty, immediately return with integer 0 and value undefined. Otherwise, return with integer 1 and contents of {\tt MVar\#}, and set {\tt MVar\#} empty.} with @@ -2797,7 +2707,7 @@ primop TryTakeMVarOp "tryTakeMVar#" GenPrimOp has_side_effects = True primop PutMVarOp "putMVar#" GenPrimOp - MVar# s a -> a -> State# s -> State# s + MVar# s v -> v -> State# s -> State# s {If {\tt MVar\#} is full, block until it becomes empty. Then store value arg as its new contents.} with @@ -2805,7 +2715,7 @@ primop PutMVarOp "putMVar#" GenPrimOp has_side_effects = True primop TryPutMVarOp "tryPutMVar#" GenPrimOp - MVar# s a -> a -> State# s -> (# State# s, Int# #) + MVar# s v -> v -> State# s -> (# State# s, Int# #) {If {\tt MVar\#} is full, immediately return with integer 0. Otherwise, store value arg as {\tt MVar\#}'s new contents, and return with integer 1.} with @@ -2813,7 +2723,7 @@ primop TryPutMVarOp "tryPutMVar#" GenPrimOp has_side_effects = True primop ReadMVarOp "readMVar#" GenPrimOp - MVar# s a -> State# s -> (# State# s, a #) + MVar# s v -> State# s -> (# State# s, v #) {If {\tt MVar\#} is empty, block until it becomes full. Then read its contents without modifying the MVar, without possibility of intervention from other threads.} @@ -2822,7 +2732,7 @@ primop ReadMVarOp "readMVar#" GenPrimOp has_side_effects = True primop TryReadMVarOp "tryReadMVar#" GenPrimOp - MVar# s a -> State# s -> (# State# s, Int#, a #) + MVar# s v -> State# s -> (# State# s, Int#, v #) {If {\tt MVar\#} is empty, immediately return with integer 0 and value undefined. Otherwise, return with integer 1 and contents of {\tt MVar\#}.} with @@ -2830,7 +2740,7 @@ primop TryReadMVarOp "tryReadMVar#" GenPrimOp has_side_effects = True primop IsEmptyMVarOp "isEmptyMVar#" GenPrimOp - MVar# s a -> State# s -> (# State# s, Int# #) + MVar# s v -> State# s -> (# State# s, Int# #) {Return 1 if {\tt MVar\#} is empty; 0 otherwise.} with out_of_line = True @@ -2847,24 +2757,27 @@ primtype IOPort# s a The main difference is that IOPort has no deadlock detection or deadlock breaking code that forcibly releases the lock. } -primop NewIOPortrOp "newIOPort#" GenPrimOp - State# s -> (# State# s, IOPort# s a #) +primop NewIOPortOp "newIOPort#" GenPrimOp + State# s -> (# State# s, IOPort# s v #) {Create new {\tt IOPort\#}; initially empty.} with out_of_line = True has_side_effects = True primop ReadIOPortOp "readIOPort#" GenPrimOp - IOPort# s a -> State# s -> (# State# s, a #) + IOPort# s v -> State# s -> (# State# s, v #) {If {\tt IOPort\#} is empty, block until it becomes full. - Then remove and return its contents, and set it empty.} + Then remove and return its contents, and set it empty. + Throws an {\tt IOPortException} if another thread is already + waiting to read this {\tt IOPort\#}.} with out_of_line = True has_side_effects = True primop WriteIOPortOp "writeIOPort#" GenPrimOp - IOPort# s a -> a -> State# s -> (# State# s, Int# #) - {If {\tt IOPort\#} is full, immediately return with integer 0. + IOPort# s v -> v -> State# s -> (# State# s, Int# #) + {If {\tt IOPort\#} is full, immediately return with integer 0, + throwing an {\tt IOPortException}. Otherwise, store value arg as {\tt IOPort\#}'s new contents, and return with integer 1. } with @@ -2918,7 +2831,7 @@ primtype ThreadId# other operations can be omitted.)} primop ForkOp "fork#" GenPrimOp - (State# RealWorld -> (# State# RealWorld, a #)) + (State# RealWorld -> (# State# RealWorld, o #)) -> State# RealWorld -> (# State# RealWorld, ThreadId# #) with has_side_effects = True @@ -2927,7 +2840,7 @@ primop ForkOp "fork#" GenPrimOp , topDmd ] topDiv } primop ForkOnOp "forkOn#" GenPrimOp - Int# -> (State# RealWorld -> (# State# RealWorld, a #)) + Int# -> (State# RealWorld -> (# State# RealWorld, o #)) -> State# RealWorld -> (# State# RealWorld, ThreadId# #) with has_side_effects = True @@ -2983,12 +2896,12 @@ section "Weak pointers" primtype Weak# b --- Note: "v" denotes a levity-polymorphic type variable +-- N.B. "v" and "w" denote levity-polymorphic type variables. -- See Note [Levity and representation polymorphic primops] primop MkWeakOp "mkWeak#" GenPrimOp - v -> b -> (State# RealWorld -> (# State# RealWorld, c #)) - -> State# RealWorld -> (# State# RealWorld, Weak# b #) + v -> w -> (State# RealWorld -> (# State# RealWorld, c #)) + -> State# RealWorld -> (# State# RealWorld, Weak# w #) { {\tt mkWeak# k v finalizer s} creates a weak reference to value {\tt k}, with an associated reference to some value {\tt v}. If {\tt k} is still alive then {\tt v} can be retrieved using {\tt deRefWeak#}. Note that @@ -2999,13 +2912,13 @@ primop MkWeakOp "mkWeak#" GenPrimOp out_of_line = True primop MkWeakNoFinalizerOp "mkWeakNoFinalizer#" GenPrimOp - v -> b -> State# RealWorld -> (# State# RealWorld, Weak# b #) + v -> w -> State# RealWorld -> (# State# RealWorld, Weak# w #) with has_side_effects = True out_of_line = True primop AddCFinalizerToWeakOp "addCFinalizerToWeak#" GenPrimOp - Addr# -> Addr# -> Int# -> Addr# -> Weak# b + Addr# -> Addr# -> Int# -> Addr# -> Weak# w -> State# RealWorld -> (# State# RealWorld, Int# #) { {\tt addCFinalizerToWeak# fptr ptr flag eptr w} attaches a C function pointer {\tt fptr} to a weak pointer {\tt w} as a finalizer. If @@ -3018,13 +2931,13 @@ primop AddCFinalizerToWeakOp "addCFinalizerToWeak#" GenPrimOp out_of_line = True primop DeRefWeakOp "deRefWeak#" GenPrimOp - Weak# a -> State# RealWorld -> (# State# RealWorld, Int#, a #) + Weak# v -> State# RealWorld -> (# State# RealWorld, Int#, v #) with has_side_effects = True out_of_line = True primop FinalizeWeakOp "finalizeWeak#" GenPrimOp - Weak# a -> State# RealWorld -> (# State# RealWorld, Int#, + Weak# v -> State# RealWorld -> (# State# RealWorld, Int#, (State# RealWorld -> (# State# RealWorld, b #) ) #) { Finalize a weak pointer. The return value is an unboxed tuple containing the new state of the world and an "unboxed Maybe", @@ -3050,30 +2963,30 @@ primtype StablePtr# a primtype StableName# a primop MakeStablePtrOp "makeStablePtr#" GenPrimOp - a -> State# RealWorld -> (# State# RealWorld, StablePtr# a #) + v -> State# RealWorld -> (# State# RealWorld, StablePtr# v #) with has_side_effects = True out_of_line = True primop DeRefStablePtrOp "deRefStablePtr#" GenPrimOp - StablePtr# a -> State# RealWorld -> (# State# RealWorld, a #) + StablePtr# v -> State# RealWorld -> (# State# RealWorld, v #) with has_side_effects = True out_of_line = True primop EqStablePtrOp "eqStablePtr#" GenPrimOp - StablePtr# a -> StablePtr# a -> Int# + StablePtr# v -> StablePtr# v -> Int# with has_side_effects = True primop MakeStableNameOp "makeStableName#" GenPrimOp - a -> State# RealWorld -> (# State# RealWorld, StableName# a #) + v -> State# RealWorld -> (# State# RealWorld, StableName# v #) with has_side_effects = True out_of_line = True primop StableNameToIntOp "stableNameToInt#" GenPrimOp - StableName# a -> Int# + StableName# v -> Int# ------------------------------------------------------------------------ section "Compact normal form" diff --git a/compiler/GHC/Core/Opt/Simplify/Utils.hs b/compiler/GHC/Core/Opt/Simplify/Utils.hs index d0b8445665..d058fc5aa2 100644 --- a/compiler/GHC/Core/Opt/Simplify/Utils.hs +++ b/compiler/GHC/Core/Opt/Simplify/Utils.hs @@ -588,9 +588,18 @@ mkArgInfo env fun rules n_val_args call_cont | Just (_, arg_ty, fun_ty') <- splitFunTy_maybe fun_ty -- Add strict-type info , dmd : rest_dmds <- dmds - , let dmd' = case isLiftedType_maybe arg_ty of - Just False -> strictifyDmd dmd - _ -> dmd + , let dmd' + -- TODO: we should just use isLiftedType_maybe, but that + -- function is currently wrong (#20837). + | Just rr <- getRuntimeRep_maybe arg_ty + , Just False <- isLiftedRuntimeRep_maybe rr + -- The type is definitely unlifted, such as: + -- - TYPE (BoxedRep Unlifted) + -- - TYPE IntRep, TYPE FloatRep, ... + = strictifyDmd dmd + | otherwise + -- Could be definitely lifted, or we're not sure (e.g. levity-polymorphic). + = dmd = dmd' : add_type_strictness fun_ty' rest_dmds -- If the type is representation-polymorphic, we can't know whether -- it's strict. isLiftedType_maybe will return Just False only when diff --git a/compiler/GHC/Core/Type.hs b/compiler/GHC/Core/Type.hs index 85cc635791..e3ad6e989c 100644 --- a/compiler/GHC/Core/Type.hs +++ b/compiler/GHC/Core/Type.hs @@ -122,7 +122,8 @@ module GHC.Core.Type ( -- *** Levity and boxity isLiftedType_maybe, isLiftedTypeKind, isUnliftedTypeKind, isBoxedTypeKind, pickyIsLiftedTypeKind, - isLiftedRuntimeRep, isUnliftedRuntimeRep, isBoxedRuntimeRep, + isLiftedRuntimeRep, isUnliftedRuntimeRep, isLiftedRuntimeRep_maybe, + isBoxedRuntimeRep, isLiftedLevity, isUnliftedLevity, isUnliftedType, isBoxedType, mightBeUnliftedType, isUnboxedTupleType, isUnboxedSumType, isAlgType, isDataFamilyAppType, @@ -130,7 +131,7 @@ module GHC.Core.Type ( isLevityTy, isLevityVar, isRuntimeRepTy, isRuntimeRepVar, isRuntimeRepKindedTy, dropRuntimeRepArgs, - getRuntimeRep, + getRuntimeRep, getLevity, getLevity_maybe, -- * Multiplicity @@ -258,6 +259,7 @@ import {-# SOURCE #-} GHC.Builtin.Types ( charTy, naturalTy, listTyCon , typeSymbolKind, liftedTypeKind, unliftedTypeKind , liftedRepTy, unliftedRepTy, zeroBitRepTy + , boxedRepDataConTyCon , constraintKind, zeroBitTypeKind , unrestrictedFunTyCon , manyDataConTy, oneDataConTy ) @@ -731,42 +733,65 @@ isBoxedRuntimeRep_maybe rep | otherwise = Nothing -isLiftedRuntimeRep :: Type -> Bool --- isLiftedRuntimeRep is true of LiftedRep :: RuntimeRep --- False of type variables (a :: RuntimeRep) --- and of other reps e.g. (IntRep :: RuntimeRep) -isLiftedRuntimeRep rep - | Just [lev] <- isTyConKeyApp_maybe boxedRepDataConKey rep - = isLiftedLevity lev - | otherwise - = False - -isUnliftedRuntimeRep :: Type -> Bool --- PRECONDITION: The type has kind RuntimeRep --- True of definitely-unlifted RuntimeReps --- False of (LiftedRep :: RuntimeRep) --- and of variables (a :: RuntimeRep) -isUnliftedRuntimeRep rep - | TyConApp rr_tc args <- coreFullView rep -- NB: args might be non-empty - -- e.g. TupleRep [r1, .., rn] +-- | Check whether a type of kind 'RuntimeRep' is lifted, unlifted, or unknown. +-- +-- @isLiftedRuntimeRep rr@ returns: +-- +-- * @Just True @ if @rr@ is @LiftedRep :: RuntimeRep@ +-- * @Just False@ if @rr@ is definitely not lifted, e.g. @IntRep@ +-- * @Nothing @ if not known (e.g. it's a type variable or a type family application). +isLiftedRuntimeRep_maybe :: Type -> Maybe Bool +isLiftedRuntimeRep_maybe rep + | TyConApp rr_tc args <- coreFullView rep , isPromotedDataCon rr_tc = -- NB: args might be non-empty e.g. TupleRep [r1, .., rn] if (rr_tc `hasKey` boxedRepDataConKey) then case args of - [lev] -> isUnliftedLevity lev - _ -> False - else True + [lev] | isLiftedLevity lev -> Just True + | isUnliftedLevity lev -> Just False + _ -> Nothing + else Just False -- 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, -- hence the isPromotedDataCon rr_tc -isUnliftedRuntimeRep _ = False +isLiftedRuntimeRep_maybe _ = Nothing + +-- | Check whether a type of kind 'RuntimeRep' is lifted. +-- +-- 'isLiftedRuntimeRep' is: +-- +-- * True of @LiftedRep :: RuntimeRep@ +-- * False of type variables, type family applications, +-- and of other reps such as @IntRep :: RuntimeRep@. +isLiftedRuntimeRep :: Type -> Bool +isLiftedRuntimeRep rep + | Just True <- isLiftedRuntimeRep_maybe rep + = True + | otherwise + = False --- | An INLINE helper for function such as 'isLiftedRuntimeRep' below. +-- | Check whether a type of kind 'RuntimeRep' is unlifted. +-- +-- * True of definitely unlifted 'RuntimeRep's such as +-- 'UnliftedRep', 'IntRep', 'FloatRep', ... +-- * False of 'LiftedRep', +-- * False for type variables and type family applications. +isUnliftedRuntimeRep :: Type -> Bool +isUnliftedRuntimeRep rep + | Just False <- isLiftedRuntimeRep_maybe rep + = True + | otherwise + = False + +-- | An INLINE helper for functions such as 'isLiftedLevity' and 'isUnliftedLevity'. +-- +-- Checks whether the type is a nullary 'TyCon' application, +-- for a 'TyCon' with the given 'Unique'. isNullaryTyConKeyApp :: Unique -> Type -> Bool isNullaryTyConKeyApp key ty | Just args <- isTyConKeyApp_maybe key ty - = assert (null args ) True + = assert (null args) True | otherwise = False {-# INLINE isNullaryTyConKeyApp #-} @@ -2448,7 +2473,7 @@ dropRuntimeRepArgs :: [Type] -> [Type] dropRuntimeRepArgs = dropWhile isRuntimeRepKindedTy -- | Extract the RuntimeRep classifier of a type. For instance, --- @getRuntimeRep_maybe Int = LiftedRep@. Returns 'Nothing' if this is not +-- @getRuntimeRep_maybe Int = Just LiftedRep@. Returns 'Nothing' if this is not -- possible. getRuntimeRep_maybe :: HasDebugCallStack => Type -> Maybe Type @@ -2462,6 +2487,30 @@ getRuntimeRep ty Just r -> r Nothing -> pprPanic "getRuntimeRep" (ppr ty <+> dcolon <+> ppr (typeKind ty)) +-- | Extract the 'Levity' of a type. For example, @getLevity_maybe Int = Just Lifted@, +-- @getLevity (Array# Int) = Just Unlifted@, @getLevity Float# = Nothing@. +-- +-- Returns 'Nothing' if this is not possible. Does not look through type family applications. +getLevity_maybe :: HasDebugCallStack => Type -> Maybe Type +getLevity_maybe ty + | Just rep <- getRuntimeRep_maybe ty + , Just (tc, [lev]) <- splitTyConApp_maybe rep + , tc == boxedRepDataConTyCon + = Just lev + | otherwise + = Nothing + +-- | Extract the 'Levity' of a type. For example, @getLevity Int = Lifted@, +-- or @getLevity (Array# Int) = Unlifted@. +-- +-- Panics if this is not possible. Does not look through type family applications. +getLevity :: HasDebugCallStack => Type -> Type +getLevity ty + | Just lev <- getLevity_maybe ty + = lev + | otherwise + = pprPanic "getLevity" (ppr ty <+> dcolon <+> ppr (typeKind ty)) + isUnboxedTupleType :: Type -> Bool isUnboxedTupleType ty = tyConAppTyCon (getRuntimeRep ty) `hasKey` tupleRepDataConKey diff --git a/compiler/GHC/Core/Type.hs-boot b/compiler/GHC/Core/Type.hs-boot index 94f9e34f83..f5b9c6f20d 100644 --- a/compiler/GHC/Core/Type.hs-boot +++ b/compiler/GHC/Core/Type.hs-boot @@ -27,4 +27,6 @@ mkTYPEapp :: Type -> Type splitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type]) tyConAppTyCon_maybe :: Type -> Maybe TyCon +getLevity :: HasDebugCallStack => Type -> Type + partitionInvisibleTypes :: TyCon -> [Type] -> ([Type], [Type]) diff --git a/compiler/GHC/Core/Utils.hs b/compiler/GHC/Core/Utils.hs index 381cd4f561..fea3a93ce6 100644 --- a/compiler/GHC/Core/Utils.hs +++ b/compiler/GHC/Core/Utils.hs @@ -123,7 +123,7 @@ import qualified Data.Set as Set ************************************************************************ -} -exprType :: CoreExpr -> Type +exprType :: HasDebugCallStack => CoreExpr -> Type -- ^ Recover the type of a well-typed Core expression. Fails when -- applied to the actual 'GHC.Core.Type' expression as it cannot -- really be said to have a type @@ -229,7 +229,7 @@ Note that there might be existentially quantified coercion variables, too. -} -- Not defined with applyTypeToArg because you can't print from GHC.Core. -applyTypeToArgs :: SDoc -> Type -> [CoreExpr] -> Type +applyTypeToArgs :: HasDebugCallStack => SDoc -> Type -> [CoreExpr] -> Type -- ^ A more efficient version of 'applyTypeToArg' when we have several arguments. -- The first argument is just for debugging, and gives some context applyTypeToArgs pp_e op_ty args diff --git a/compiler/GHC/Runtime/Heap/Inspect.hs b/compiler/GHC/Runtime/Heap/Inspect.hs index 52c79e50a3..4f6e2b7057 100644 --- a/compiler/GHC/Runtime/Heap/Inspect.hs +++ b/compiler/GHC/Runtime/Heap/Inspect.hs @@ -807,17 +807,19 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do go max_depth my_ty old_ty ind -- We also follow references MutVarClosure{var=contents} - | Just (tycon,[world,contents_ty]) <- tcSplitTyConApp_maybe old_ty + | Just (tycon,[lev,world,contents_ty]) <- tcSplitTyConApp_maybe old_ty -> do -- Deal with the MutVar# primitive -- It does not have a constructor at all, -- so we simulate the following one -- MutVar# :: contents_ty -> MutVar# s contents_ty - traceTR (text "Following a MutVar") - contents_tv <- newVar liftedTypeKind + massert (tycon == mutVarPrimTyCon) massert (isUnliftedType my_ty) + traceTR (text "Following a MutVar") + let contents_kind = mkTYPEapp (mkTyConApp boxedRepDataConTyCon [lev]) + contents_tv <- newVar contents_kind (mutvar_ty,_) <- instScheme $ quantifyType $ mkVisFunTyMany - contents_ty (mkTyConApp tycon [world,contents_ty]) + contents_ty (mkTyConApp tycon [lev, world,contents_ty]) addConstraint (mkVisFunTyMany contents_tv my_ty) mutvar_ty x <- go (pred max_depth) contents_tv contents_ty contents return (RefWrap my_ty x) @@ -1039,11 +1041,14 @@ cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do case clos of BlackholeClosure{indirectee=ind} -> go my_ty ind IndClosure{indirectee=ind} -> go my_ty ind - MutVarClosure{var=contents} -> do - tv' <- newVar liftedTypeKind - world <- newVar liftedTypeKind - addConstraint my_ty (mkTyConApp mutVarPrimTyCon [world,tv']) - return [(tv', contents)] + MutVarClosure{var=contents} + | Just (_tycon,[lev,_world,_contents_ty]) <- tcSplitTyConApp_maybe my_ty + -> do + massert (_tycon == mutVarPrimTyCon) + tv' <- newVar $ mkTYPEapp (mkTyConApp boxedRepDataConTyCon [lev]) + world <- newVar liftedTypeKind + addConstraint my_ty $ mkMutVarPrimTy world tv' + return [(tv', contents)] APClosure {payload=pLoad} -> do -- #19559 (incr) mapM_ (go my_ty) pLoad return [] diff --git a/compiler/GHC/StgToCmm/Foreign.hs b/compiler/GHC/StgToCmm/Foreign.hs index 78a01d06d6..4c414df9e9 100644 --- a/compiler/GHC/StgToCmm/Foreign.hs +++ b/compiler/GHC/StgToCmm/Foreign.hs @@ -603,9 +603,9 @@ closureField profile off = off + fixedHdrSize profile -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- -- For certain types passed to foreign calls, we adjust the actual --- value passed to the call. For ByteArray#, Array#, SmallArray#, --- and ArrayArray#, we pass the address of the array's payload, not --- the address of the heap object. For example, consider +-- value passed to the call. For ByteArray#, Array# and SmallArray#, +-- we pass the address of the array's payload, not the address of +-- the heap object. For example, consider: -- foreign import "c_foo" foo :: ByteArray# -> Int# -> IO () -- At a Haskell call like `foo x y`, we'll generate a C call that -- is more like @@ -715,8 +715,6 @@ typeToStgFArgType :: Type -> StgFArgType typeToStgFArgType typ | tycon == arrayPrimTyCon = StgArrayType | tycon == mutableArrayPrimTyCon = StgArrayType - | tycon == arrayArrayPrimTyCon = StgArrayType - | tycon == mutableArrayArrayPrimTyCon = StgArrayType | tycon == smallArrayPrimTyCon = StgSmallArrayType | tycon == smallMutableArrayPrimTyCon = StgSmallArrayType | tycon == byteArrayPrimTyCon = StgByteArrayType diff --git a/compiler/GHC/StgToCmm/Prim.hs b/compiler/GHC/StgToCmm/Prim.hs index e0af686b47..5c538c45c8 100644 --- a/compiler/GHC/StgToCmm/Prim.hs +++ b/compiler/GHC/StgToCmm/Prim.hs @@ -176,16 +176,6 @@ emitPrimOp dflags primop = case primop of opIntoRegs $ \ [] -> doCopyMutableArrayOp src src_off dst dst_off (fromInteger n) _ -> PrimopCmmEmit_External - CopyArrayArrayOp -> \case - [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] -> - opIntoRegs $ \ [] -> doCopyArrayOp src src_off dst dst_off (fromInteger n) - _ -> PrimopCmmEmit_External - - CopyMutableArrayArrayOp -> \case - [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] -> - opIntoRegs $ \ [] -> doCopyMutableArrayOp src src_off dst dst_off (fromInteger n) - _ -> PrimopCmmEmit_External - CloneArrayOp -> \case [src, src_off, (CmmLit (CmmInt n w))] | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) @@ -373,10 +363,6 @@ emitPrimOp dflags primop = case primop of emit $ catAGraphs [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_DIRTY_infoLabel)), mkAssign (CmmLocal res) arg ] - UnsafeFreezeArrayArrayOp -> \[arg] -> opIntoRegs $ \[res] -> - emit $ catAGraphs - [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_DIRTY_infoLabel)), - mkAssign (CmmLocal res) arg ] UnsafeFreezeSmallArrayOp -> \[arg] -> opIntoRegs $ \[res] -> emit $ catAGraphs [ setInfo arg (CmmLit (CmmLabel mkSMAP_FROZEN_DIRTY_infoLabel)), @@ -395,27 +381,6 @@ emitPrimOp dflags primop = case primop of WriteArrayOp -> \[obj, ix, v] -> opIntoRegs $ \[] -> doWritePtrArrayOp obj ix v - IndexArrayArrayOp_ByteArray -> \[obj, ix] -> opIntoRegs $ \[res] -> - doReadPtrArrayOp res obj ix - IndexArrayArrayOp_ArrayArray -> \[obj, ix] -> opIntoRegs $ \[res] -> - doReadPtrArrayOp res obj ix - ReadArrayArrayOp_ByteArray -> \[obj, ix] -> opIntoRegs $ \[res] -> - doReadPtrArrayOp res obj ix - ReadArrayArrayOp_MutableByteArray -> \[obj, ix] -> opIntoRegs $ \[res] -> - doReadPtrArrayOp res obj ix - ReadArrayArrayOp_ArrayArray -> \[obj, ix] -> opIntoRegs $ \[res] -> - doReadPtrArrayOp res obj ix - ReadArrayArrayOp_MutableArrayArray -> \[obj, ix] -> opIntoRegs $ \[res] -> - doReadPtrArrayOp res obj ix - WriteArrayArrayOp_ByteArray -> \[obj,ix,v] -> opIntoRegs $ \[] -> - doWritePtrArrayOp obj ix v - WriteArrayArrayOp_MutableByteArray -> \[obj,ix,v] -> opIntoRegs $ \[] -> - doWritePtrArrayOp obj ix v - WriteArrayArrayOp_ArrayArray -> \[obj,ix,v] -> opIntoRegs $ \[] -> - doWritePtrArrayOp obj ix v - WriteArrayArrayOp_MutableArrayArray -> \[obj,ix,v] -> opIntoRegs $ \[] -> - doWritePtrArrayOp obj ix v - ReadSmallArrayOp -> \[obj, ix] -> opIntoRegs $ \[res] -> doReadSmallPtrArrayOp res obj ix IndexSmallArrayOp -> \[obj, ix] -> opIntoRegs $ \[res] -> @@ -430,8 +395,6 @@ emitPrimOp dflags primop = case primop of (fixedHdrSizeW profile + bytesToWordsRoundUp platform (pc_OFFSET_StgMutArrPtrs_ptrs (platformConstants platform))) (bWord platform)) SizeofMutableArrayOp -> emitPrimOp dflags SizeofArrayOp - SizeofArrayArrayOp -> emitPrimOp dflags SizeofArrayOp - SizeofMutableArrayArrayOp -> emitPrimOp dflags SizeofArrayOp SizeofSmallArrayOp -> \[arg] -> opIntoRegs $ \[res] -> emit $ mkAssign (CmmLocal res) (cmmLoadIndexW platform arg @@ -1600,7 +1563,6 @@ emitPrimOp dflags primop = case primop of ShrinkMutableByteArrayOp_Char -> alwaysExternal ResizeMutableByteArrayOp_Char -> alwaysExternal ShrinkSmallMutableArrayOp_Char -> alwaysExternal - NewArrayArrayOp -> alwaysExternal NewMutVarOp -> alwaysExternal AtomicModifyMutVar2Op -> alwaysExternal AtomicModifyMutVar_Op -> alwaysExternal @@ -1628,7 +1590,7 @@ emitPrimOp dflags primop = case primop of ReadMVarOp -> alwaysExternal TryReadMVarOp -> alwaysExternal IsEmptyMVarOp -> alwaysExternal - NewIOPortrOp -> alwaysExternal + NewIOPortOp -> alwaysExternal ReadIOPortOp -> alwaysExternal WriteIOPortOp -> alwaysExternal DelayOp -> alwaysExternal diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs index 6a65d5d383..cc09edd778 100644 --- a/compiler/GHC/Tc/Utils/Zonk.hs +++ b/compiler/GHC/Tc/Utils/Zonk.hs @@ -1828,6 +1828,9 @@ commitFlexi flexi tv zonked_kind | isRuntimeRepTy zonked_kind -> do { traceTc "Defaulting flexi tyvar to LiftedRep:" (pprTyVar tv) ; return liftedRepTy } + | isLevityTy zonked_kind + -> do { traceTc "Defaulting flexi tyvar to Lifted:" (pprTyVar tv) + ; return liftedDataConTy } | isMultiplicityTy zonked_kind -> do { traceTc "Defaulting flexi tyvar to Many:" (pprTyVar tv) ; return manyDataConTy } diff --git a/docs/users_guide/9.4.1-notes.rst b/docs/users_guide/9.4.1-notes.rst index 5cb2736547..dbe1d02cf2 100644 --- a/docs/users_guide/9.4.1-notes.rst +++ b/docs/users_guide/9.4.1-notes.rst @@ -87,21 +87,132 @@ Compiler ``ghc-prim`` library ~~~~~~~~~~~~~~~~~~~~ -- ``GHC.Exts.mkWeak#``, ``GHC.Exts.mkWeakNoFinalizer#``, ``GHC.Exts.touch#`` - and ``GHC.Exts.keepAlive#`` are now levity-polymorphic instead of +- Primitive types and functions which handle boxed values are now levity-polymorphic, + meaning that they now also work with unlifted boxed values (i.e. values whose type + has kind ``TYPE (BoxedRep Unlifted)``). + + The following type constructors are now levity-polymorphic: + + - ``Array#``, ``SmallArray#``, ``Weak#``, ``StablePtr#``, ``StableName#``, + + - ``MutableArray#``, ``SmallMutableArray#``, ``MutVar#``, + ``TVar#``, ``MVar#``, ``IOPort#``. + + For example, ``Array#`` used to have kind: :: + + Type -> UnliftedType + + but it now has kind: :: + + forall {l :: Levity}. TYPE (BoxedRep l) -> UnliftedType + + Similarly, ``MutVar#`` used to have kind: :: + + Type -> Type -> UnliftedType + + but it now has kind: :: + + forall {l :: Levity}. Type -> TYPE (BoxedRep l) -> UnliftedType + + This means that in ``Array# a``, ``MutableArray# s a``, ``MutVar# s a``, ..., + the element type ``a``, must always be boxed, but it can now either be lifted + or unlifted. + In particular, arrays and mutable variables can now be used to store + other arrays and mutable variables. + + All functions which use these updated primitive types are also levity-polymorphic: + + - all array operations (reading/writing/copying/...), for both arrays and small arrays, + mutable and immutable: + + - ``newArray#``, ``readArray#``, ``writeArray#``, ``sizeofArray#``, ``sizeofMutableArray#``, ``indexArray#``, + ``unsafeFreezeArray#``, ``unsafeThawArray#``, ``copyArray#``, ``copyMutableArray#``, ``cloneArray#``, + ``cloneMutableArray#``, ``freezeArray#``, ``thawArray#``, ``casArray#``, + + - ``newSmallArray#``, ``shrinkSmallMutableArray#``, ``readSmallArray#``, ``writeSmallArray#``, ``sizeofSmallArray#``, + ``getSizeofSmallMutableArray#``, ``indexSmallArray#``, ``unsafeFreezeSmallArray#``, + ``unsafeThawSmallArray#``, ``copySmallArray#``, ``copySmallMutableArray#``, ``cloneSmallArray#``, + ``cloneSmallMutableArray#``, ``freezeSmallArray#``, ``thawSmallArray#``, ``casSmallArray#``, + + - ``newMutVar#``,``readMutVar#``,``writeMutV#``,``casMutVar#``, + + - operations on ``MVar#`` and ``TVar#``: + + - ``newTVar#``, ``readTVar#``, ``readTVarIO#``, ``writeTVar#``, + + - ``newMVar#``, ``takeMVar#``, ``tryTakeMVar#``, ``putMVar#``, + ``tryPutMVar#``, ``readMVar#``, ``tryReadMVar#``, + + - ``STM`` operations ``atomically#``, ``retry#``, ``catchRetry#`` and ``catchSTM#``. + + - ``newIOPort#``, ``readIOPort#``, ``writeIOPort#``, + + - ``mkWeak#``, ``mkWeakNoFinalizer#``, ``addCFinalizerToWeak#``, ``deRefWeak#``, ``finalizeWeak#``, + + - ``makeStablePtr#``, ``deRefStablePtr#``, ``eqStablePtr#``, ``makeStableName#``, ``stableNameToInt#``, + + For example, the full type of ``newMutVar#`` is now: :: + + newMutVar# + :: forall s {l :: Levity} (a :: TYPE (BoxedRep l)). + a -> State# s -> (# State# s, MVar# s a #) + + and the full type of ``writeSmallArray#`` is: :: + + writeSmallArray# + :: forall s {l :: Levity} (a :: TYPE ('BoxedRep l)). + SmallMutableArray# s a -> Int# -> a -> State# s -> State# s + +- ``ArrayArray#` and ``MutableArrayArray#`` have been moved from ``GHC.Prim`` to ``GHC.Exts``. + They are deprecated, because their functionality is now subsumed by ``Array#`` + and ``MutableArray#``. + +- ``mkWeak#``, ``mkWeakNoFinalizer#``, ``touch#`` + and ``keepAlive#`` are now levity-polymorphic instead of representation-polymorphic. For instance: :: mkWeakNoFinalizer# - :: forall {l :: Levity} (a :: TYPE (BoxedRep l)) (b :: Type) - . a -> b -> State# RealWorld -> (# State# RealWorld, Weak# b #) + :: forall {l :: Levity} (a :: TYPE ('BoxedRep l)) + {k :: Levity} (b :: TYPE ('BoxedRep k)). + a -> b -> State# RealWorld -> (# State# RealWorld, Weak# b #) - That is, the type signature now quantifies over a variable of type ``GHC.Exts.Levity`` - instead of ``GHC.Exts.RuntimeRep``. In addition, this variable is now inferred, + That is, the type signature now quantifies over the ``GHC.Exts.Levity`` of ``a`` + instead of its ``GHC.Exts.RuntimeRep``. In addition, this variable is now inferred, instead of specified, meaning that it is no longer eligible for visible type application. + Note that ``b`` is now also levity-polymorphic, due to the change outlined in the + previous point. + +- Primitive functions for throwing and catching exceptions are now more polymorphic + than before. For example, ``catch#`` now has type: :: + + catch# + :: forall {r :: RuntimeRep} (a :: TYPE r) + {l :: Levity} (b :: TYPE ('BoxedRep l)). + ( State# RealWorld -> (# State# RealWorld, a #) ) + -> ( b -> State# RealWorld -> (# State# RealWorld, a #) ) + -> State# RealWorld -> (# State# RealWorld, a #) + + The following functions have been generalised in this way: + + - ``catch#``, + + - ``raise#``, ``raiseIO#``, + + - ``maskAsyncExceptions#``, ``maskUninterruptible#``, ``unmaskAsyncExceptions#``. + + Note in particular that ``raise#`` is now both representation-polymorphic + (with an inferred `RuntimeRep` argument) and levity-polymorphic, with type: :: + + raise# :: forall {l :: Levity} (a :: TYPE (BoxedRep l)) + {r :: RuntimeRep} (b :: TYPE r). + a -> b -- The ``GHC.Exts.RuntimeRep`` parameter to ``GHC.Exts.raise#`` is now inferred: :: +- ``fork#`` and ``forkOn#`` are now representation-polymorphic. For example, ``fork#`` + now has type: :: - raise# :: forall (a :: Type) {r :: RuntimeRep} (b :: TYPE r). a -> b + fork# :: forall {r :: RuntimeRep} (a :: TYPE r). + (State# RealWorld -> (# State# RealWorld, a #)) + -> (State# RealWorld -> (# State# RealWorld, a #)) - ``GHC.Exts.reallyUnsafePtrEquality#`` has been made more general, as it is now both levity-polymorphic and heterogeneous: :: diff --git a/libraries/base/GHC/ArrayArray.hs b/libraries/base/GHC/ArrayArray.hs new file mode 100644 index 0000000000..ea84f13edf --- /dev/null +++ b/libraries/base/GHC/ArrayArray.hs @@ -0,0 +1,156 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UnliftedNewtypes #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.ArrayArray +-- License : see libraries/base/LICENSE +-- +-- Maintainer : cvs-ghc@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC Extensions) +-- +-- Legacy interface for arrays of arrays. +-- Deprecated, because the 'Array#' type can now store arrays directly. +-- Consider simply using 'Array#' instead of 'ArrayArray#'. +-- +-- Use GHC.Exts instead of importing this module directly. +-- +---------------------------------------------------------------------------- + +module GHC.ArrayArray + ( ArrayArray#(..), MutableArrayArray#(..) + , newArrayArray# + , unsafeFreezeArrayArray# + , sizeofArrayArray# + , sizeofMutableArrayArray# + , indexByteArrayArray# + , indexArrayArrayArray# + , readByteArrayArray# + , readMutableByteArrayArray# + , readArrayArrayArray# + , readMutableArrayArrayArray# + , writeByteArrayArray# + , writeMutableByteArrayArray# + , writeArrayArrayArray# + , writeMutableArrayArrayArray# + , copyArrayArray# + , copyMutableArrayArray# + , sameArrayArray# + , sameMutableArrayArray# + ) + where + +import GHC.Prim +import GHC.Types ( Type, UnliftedType, isTrue# ) +import Unsafe.Coerce ( unsafeCoerce, unsafeCoerceUnlifted ) +default () + +{- ********************************************************************** +* * +* Arrays of arrays (legacy interface) * +* * +********************************************************************** -} + +type ArrayArray# :: UnliftedType +newtype ArrayArray# = ArrayArray# (Array# ByteArray#) + +type MutableArrayArray# :: Type -> UnliftedType +newtype MutableArrayArray# s = MutableArrayArray# (MutableArray# s ByteArray#) + +-- | Create a new mutable array of arrays with the specified number of elements, +-- in the specified state thread, with each element recursively referring to the +-- newly created array. +newArrayArray# :: Int# -> State# s -> (# State# s, MutableArrayArray# s #) +newArrayArray# sz s1 = + -- Create a placeholder ByteArray to initialise the underlying MutableArray#. + case newByteArray# 0# s1 of + (# s2, placeholder #) -> + -- Create a new MutableArray# holding the placeholder ByteArray# value. + case newArray# sz (unsafeCoerceUnlifted placeholder) s2 of + (# s3, arr #) -> + -- Now update the MutableArray# so that the elements refer back + -- to the mutable array itself. + case write_array_to_array arr 0# s3 of + s4 -> (# s4, MutableArrayArray# (unsafeCoerceUnlifted arr) #) + + where + write_array_to_array :: MutableArray# s ByteArray# -> Int# -> State# s -> State# s + write_array_to_array _ i s + | isTrue# (i >=# sz) + = s + write_array_to_array arr i s + = case writeArray# arr i (unsafeCoerceUnlifted arr) s of + s' -> write_array_to_array arr (i +# 1#) s' + +-- | Make a mutable array of arrays immutable, without copying. +unsafeFreezeArrayArray# :: MutableArrayArray# s -> State# s -> (# State# s, ArrayArray# #) +unsafeFreezeArrayArray# = unsafeCoerce unsafeFreezeArray# + +-- | Return the number of elements in the array. +sizeofArrayArray# :: ArrayArray# -> Int# +sizeofArrayArray# = unsafeCoerce sizeofArray# + +-- | Return the number of elements in the array. +sizeofMutableArrayArray# :: MutableArrayArray# s -> Int# +sizeofMutableArrayArray# = unsafeCoerce sizeofMutableArray# + +indexByteArrayArray# :: ArrayArray# -> Int# -> ByteArray# +indexByteArrayArray# = unsafeCoerce indexArray# + +indexArrayArrayArray# :: ArrayArray# -> Int# -> ArrayArray# +indexArrayArrayArray# = unsafeCoerce indexArray# + +readByteArrayArray# :: MutableArrayArray# s -> Int# -> State# s -> (# State# s, ByteArray# #) +readByteArrayArray# = unsafeCoerce readArray# + +readMutableByteArrayArray# :: MutableArrayArray# s -> Int# -> State# s -> (# State# s, MutableByteArray# s #) +readMutableByteArrayArray# = unsafeCoerce readArray# + +readArrayArrayArray# :: MutableArrayArray# s -> Int# -> State# s -> (# State# s, ArrayArray# #) +readArrayArrayArray# = unsafeCoerce readArray# + +readMutableArrayArrayArray# :: MutableArrayArray# s -> Int# -> State# s -> (# State# s, MutableArrayArray# s #) +readMutableArrayArrayArray# = unsafeCoerce readArray# + +writeByteArrayArray# :: MutableArrayArray# s -> Int# -> ByteArray# -> State# s -> State# s +writeByteArrayArray# = unsafeCoerce writeArray# + +writeMutableByteArrayArray# :: MutableArrayArray# s -> Int# -> MutableByteArray# s -> State# s -> State# s +writeMutableByteArrayArray# = unsafeCoerce writeArray# + +writeArrayArrayArray# :: MutableArrayArray# s -> Int# -> ArrayArray# -> State# s -> State# s +writeArrayArrayArray# = unsafeCoerce writeArray# + +writeMutableArrayArrayArray# :: MutableArrayArray# s -> Int# -> MutableArrayArray# s -> State# s -> State# s +writeMutableArrayArrayArray# = unsafeCoerce writeArray# + +-- | Copy a range of the 'ArrayArray#' to the specified region in the 'MutableArrayArray#'. +-- Both arrays must fully contain the specified ranges, but this is not checked. +-- The two arrays must not be the same array in different states, but this is not checked either. +copyArrayArray# :: ArrayArray# -> Int# -> MutableArrayArray# s -> Int# -> Int# -> State# s -> State# s +copyArrayArray# = unsafeCoerce copyArray# + +-- | Copy a range of the first MutableArrayArray# to the specified region in the second +-- MutableArrayArray#. +-- Both arrays must fully contain the specified ranges, but this is not checked. +-- The regions are allowed to overlap, although this is only possible when the same +-- array is provided as both the source and the destination. +copyMutableArrayArray# :: MutableArrayArray# s -> Int# -> MutableArrayArray# s -> Int# -> Int# -> State# s -> State# s +copyMutableArrayArray# = unsafeCoerce copyMutableArray# + +-- | Compare the underlying pointers of two arrays of arrays. +sameArrayArray# :: ArrayArray# -> ArrayArray# -> Int# +sameArrayArray# (ArrayArray# arr1) (ArrayArray# arr2) = reallyUnsafePtrEquality# arr1 arr2 + +-- | Compare the underlying pointers of two mutable arrays of arrays. +sameMutableArrayArray# :: MutableArrayArray# s -> MutableArrayArray# s -> Int# +sameMutableArrayArray# (MutableArrayArray# marr1) (MutableArrayArray# marr2 ) = reallyUnsafePtrEquality# marr1 marr2 diff --git a/libraries/base/GHC/Exts.hs b/libraries/base/GHC/Exts.hs index c03b397601..62c36cb0d5 100755 --- a/libraries/base/GHC/Exts.hs +++ b/libraries/base/GHC/Exts.hs @@ -34,6 +34,9 @@ module GHC.Exts -- ** Other primitive types module GHC.Types, + -- ** Legacy interface for arrays of arrays + module GHC.ArrayArray, + -- * Primitive operations module GHC.Prim, @@ -55,8 +58,6 @@ module GHC.Exts sameSmallMutableArray#, sameByteArray#, sameMutableByteArray#, - sameArrayArray#, - sameMutableArrayArray#, sameMVar#, sameMutVar#, sameTVar#, @@ -136,6 +137,7 @@ import GHC.Types -- GHC's internal representation of 'TyCon's, for 'Typeable' , Module, TrName, TyCon, TypeLitSort, KindRep, KindBndr ) import qualified GHC.Prim.Ext +import GHC.ArrayArray import GHC.Base hiding ( coerce ) import GHC.Ptr import GHC.Stack diff --git a/libraries/base/base.cabal b/libraries/base/base.cabal index 79d481ada6..017b97081d 100644 --- a/libraries/base/base.cabal +++ b/libraries/base/base.cabal @@ -187,6 +187,7 @@ Library Foreign.StablePtr Foreign.Storable GHC.Arr + GHC.ArrayArray GHC.Base GHC.Bits GHC.ByteOrder diff --git a/libraries/ghc-prim/GHC/Prim/PtrEq.hs b/libraries/ghc-prim/GHC/Prim/PtrEq.hs index 5e9d2e564b..5cc3e511e6 100644 --- a/libraries/ghc-prim/GHC/Prim/PtrEq.hs +++ b/libraries/ghc-prim/GHC/Prim/PtrEq.hs @@ -26,8 +26,6 @@ module GHC.Prim.PtrEq sameSmallMutableArray#, sameByteArray#, sameMutableByteArray#, - sameArrayArray#, - sameMutableArrayArray#, sameMutVar#, sameTVar#, sameMVar#, @@ -100,14 +98,6 @@ sameByteArray# = reallyUnsafePtrEquality# sameMutableByteArray# :: MutableByteArray# s -> MutableByteArray# s -> Int# sameMutableByteArray# = reallyUnsafePtrEquality# --- | Compare the underlying pointers of two arrays of arrays. -sameArrayArray# :: ArrayArray# -> ArrayArray# -> Int# -sameArrayArray# = reallyUnsafePtrEquality# - --- | Compare the underlying pointers of two mutable arrays of arrays. -sameMutableArrayArray# :: MutableArrayArray# s -> MutableArrayArray# s -> Int# -sameMutableArrayArray# = reallyUnsafePtrEquality# - -- | Compare the underlying pointers of two 'MutVar#'s. sameMutVar# :: MutVar# s a -> MutVar# s a -> Int# sameMutVar# = reallyUnsafePtrEquality# diff --git a/libraries/ghc-prim/changelog.md b/libraries/ghc-prim/changelog.md index 63f2881dcb..372018290b 100644 --- a/libraries/ghc-prim/changelog.md +++ b/libraries/ghc-prim/changelog.md @@ -20,25 +20,150 @@ Note that the explicit type applications are required, as the call to `withDict` would be ambiguous otherwise. +- Primitive types and functions which handle boxed values are now levity-polymorphic, + meaning that they now also work with unlifted boxed values (i.e. values whose type + has kind `TYPE (BoxedRep Unlifted)`). + + The following type constructors are now levity-polymorphic: + + - `Array#`, `SmallArray#`, `Weak#`, `StablePtr#`, `StableName#`, + + - `MutableArray#`, `SmallMutableArray#`, `MutVar#`, + `TVar#`, `MVar#`, `IOPort#`. + + For example, `Array#` used to have kind: + + ``` + Type -> UnliftedType + ``` + + but it now has kind: + + ``` + forall {l :: Levity}. TYPE (BoxedRep l) -> UnliftedType + ``` + + Similarly, `MutVar#` used to have kind: + + ``` + Type -> Type -> UnliftedType + ``` + + but it now has kind: + + ``` + forall {l :: Levity}. Type -> TYPE (BoxedRep l) -> UnliftedType + ``` + + This means that in `Array# a`, `MutableArray# s a`, `MutVar# s a`, ..., + the element type `a`, must always be boxed, but it can now either be lifted + or unlifted. + In particular, arrays and mutable variables can now be used to store + other arrays and mutable variables. + + All functions which use these updated primitive types are also levity-polymorphic: + + - all array operations (reading/writing/copying/...), for both arrays and small arrays, + mutable and immutable: + + - `newArray#`, `readArray#`, `writeArray#`, `sizeofArray#`, `sizeofMutableArray#`, `indexArray#`, + `unsafeFreezeArray#`, `unsafeThawArray#`, `copyArray#`, `copyMutableArray#`, `cloneArray#`, + `cloneMutableArray#`, `freezeArray#`, `thawArray#`, `casArray#`, + + - `newSmallArray#`, `shrinkSmallMutableArray#`, `readSmallArray#`, `writeSmallArray#`, `sizeofSmallArray#`, + `getSizeofSmallMutableArray#`, `indexSmallArray#`, `unsafeFreezeSmallArray#`, + `unsafeThawSmallArray#`, `copySmallArray#`, `copySmallMutableArray#`, `cloneSmallArray#`, + `cloneSmallMutableArray#`, `freezeSmallArray#`, `thawSmallArray#`, `casSmallArray#`, + + - `newMutVar#`,`readMutVar#`,`writeMutV#`,`casMutVar#`, + + - operations on `MVar#` and `TVar#`: + + - `newTVar#`, `readTVar#`, `readTVarIO#`, `writeTVar#`, + + - `newMVar#`, `takeMVar#`, `tryTakeMVar#`, `putMVar#`, + `tryPutMVar#`, `readMVar#`, `tryReadMVar#`, + + - `STM` operations `atomically#`, `retry#`, `catchRetry#` and `catchSTM#`. + + - `newIOPort#`, `readIOPort#`, `writeIOPort#`, + + - `mkWeak#`, `mkWeakNoFinalizer#`, `addCFinalizerToWeak#`, `deRefWeak#`, `finalizeWeak#`, + + - `makeStablePtr#`, `deRefStablePtr#`, `eqStablePtr#`, `makeStableName#`, `stableNameToInt#`, + + For example, the full type of `newMutVar#` is now: + + ``` + newMutVar# + :: forall s {l :: Levity} (a :: TYPE (BoxedRep l)). + a -> State# s -> (# State# s, MVar# s a #) + ``` + + and the full type of `writeSmallArray#` is: + + ``` + writeSmallArray# + :: forall s {l :: Levity} (a :: TYPE ('BoxedRep l)). + SmallMutableArray# s a -> Int# -> a -> State# s -> State# s + ``` + +- `ArrayArray#` and `MutableArrayArray#` have been moved from `GHC.Prim` to `GHC.Exts`. + They are deprecated, because their functionality is now subsumed by `Array#` + and `MutableArray#`. + - `mkWeak#`, `mkWeakNoFinalizer#`, `touch#` and `keepAlive#` are now levity-polymorphic instead of representation-polymorphic. For instance: ``` mkWeakNoFinalizer# - :: forall {l :: Levity} (a :: TYPE (BoxedRep l)) (b :: Type) - . a -> b -> State# RealWorld -> (# State# RealWorld, Weak# b #) + :: forall {l :: Levity} (a :: TYPE ('BoxedRep l)) + {k :: Levity} (b :: TYPE ('BoxedRep k)). + a -> b -> State# RealWorld -> (# State# RealWorld, Weak# b #) ``` - That is, the type signature now quantifies over a variable of type `Levity` - instead of `RuntimeRep`. In addition, this variable is now inferred, + That is, the type signature now quantifies over the `Levity` of `a` + instead of its `RuntimeRep`. In addition, this variable is now inferred, instead of specified, meaning that it is no longer eligible for visible type application. + Note that `b` is now also levity-polymorphic, due to the change outlined in the + previous point. -- The `RuntimeRep` parameter to `raise#` is now inferred: +- Primitive functions for throwing and catching exceptions are now more polymorphic + than before. For example, `catch#` now has type: ``` - raise# :: forall (a :: Type) {r :: RuntimeRep} (b :: TYPE r). a -> b + catch# + :: forall {r :: RuntimeRep} (a :: TYPE r) + {l :: Levity} (b :: TYPE ('BoxedRep l)). + ( State# RealWorld -> (# State# RealWorld, a #) ) + -> ( b -> State# RealWorld -> (# State# RealWorld, a #) ) + -> State# RealWorld -> (# State# RealWorld, a #) ``` + The following functions are concerned: + + - `catch#`, + + - `raise#`, `raiseIO#`, + + - `maskAsyncExceptions#`, `maskUninterruptible#`, `unmaskAsyncExceptions#`. + + Note in particular that `raise#` is now both representation-polymorphic + (with an inferred `RuntimeRep` argument) and levity-polymorphic, with type: + + ``` + raise# :: forall {l :: Levity} (a :: TYPE (BoxedRep l)) + {r :: RuntimeRep} (b :: TYPE r). + a -> b + ``` + +- ``fork#`` and ``forkOn#`` are now representation-polymorphic. For example, ``fork#`` + now has type: :: + + fork# :: forall {r :: RuntimeRep} (a :: TYPE r). + (State# RealWorld -> (# State# RealWorld, a #)) + -> (State# RealWorld -> (# State# RealWorld, a #)) + - `reallyUnsafePtrEquality#` has been made more general, as it is now both levity-polymorphic and heterogeneous: @@ -61,7 +186,7 @@ - `eqStableName#`. - The following functions have been added to `GHC.Exts`: - + ``` sameArray# :: Array# a -> Array# a -> Int# sameSmallArray# :: SmallArray# a -> SmallArray# a -> Int# diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm index 15f9e949b0..c5b6065ec2 100644 --- a/rts/PrimOps.cmm +++ b/rts/PrimOps.cmm @@ -391,16 +391,6 @@ stg_copyMutableArrayzh ( gcptr src, W_ src_off, gcptr dst, W_ dst_off, W_ n ) copyMutableArray(src, src_off, dst, dst_off, n) } -stg_copyArrayArrayzh ( gcptr src, W_ src_off, gcptr dst, W_ dst_off, W_ n ) -{ - copyArray(src, src_off, dst, dst_off, n) -} - -stg_copyMutableArrayArrayzh ( gcptr src, W_ src_off, gcptr dst, W_ dst_off, W_ n ) -{ - copyMutableArray(src, src_off, dst, dst_off, n) -} - stg_cloneArrayzh ( gcptr src, W_ offset, W_ n ) { cloneArray(stg_MUT_ARR_PTRS_FROZEN_CLEAN_info, src, offset, n) @@ -451,43 +441,6 @@ stg_casArrayzh ( gcptr arr, W_ ind, gcptr old, gcptr new ) } } -stg_newArrayArrayzh ( W_ n /* words */ ) -{ - W_ words, size, p; - gcptr arr; - - MAYBE_GC_N(stg_newArrayArrayzh, n); - - // the mark area contains one byte for each 2^MUT_ARR_PTRS_CARD_BITS words - // in the array, making sure we round up, and then rounding up to a whole - // number of words. - size = n + mutArrPtrsCardWords(n); - words = BYTES_TO_WDS(SIZEOF_StgMutArrPtrs) + size; - ("ptr" arr) = ccall allocateMightFail(MyCapability() "ptr",words); - if (arr == NULL) { - jump stg_raisezh(base_GHCziIOziException_heapOverflow_closure); - } - TICK_ALLOC_PRIM(SIZEOF_StgMutArrPtrs, WDS(size), 0); - - SET_HDR(arr, stg_MUT_ARR_PTRS_DIRTY_info, W_[CCCS]); - StgMutArrPtrs_ptrs(arr) = n; - StgMutArrPtrs_size(arr) = size; - - // Initialize card table to all-clean. - setCardsValue(arr, 0, n, 0); - - // Initialise all elements of the array with a pointer to the new array - p = arr + SIZEOF_StgMutArrPtrs; - for: - if (p < arr + SIZEOF_StgMutArrPtrs + WDS(n)) (likely: True) { - W_[p] = arr; - p = p + WDS(1); - goto for; - } - - return (arr); -} - /* ----------------------------------------------------------------------------- SmallArray primitives diff --git a/rts/RtsSymbols.c b/rts/RtsSymbols.c index b6440049c0..b2c85b591c 100644 --- a/rts/RtsSymbols.c +++ b/rts/RtsSymbols.c @@ -730,13 +730,10 @@ extern char **environ; SymI_HasProto(stg_newArrayzh) \ SymI_HasProto(stg_copyArrayzh) \ SymI_HasProto(stg_copyMutableArrayzh) \ - SymI_HasProto(stg_copyArrayArrayzh) \ - SymI_HasProto(stg_copyMutableArrayArrayzh) \ SymI_HasProto(stg_cloneArrayzh) \ SymI_HasProto(stg_cloneMutableArrayzh) \ SymI_HasProto(stg_freezzeArrayzh) \ SymI_HasProto(stg_thawArrayzh) \ - SymI_HasProto(stg_newArrayArrayzh) \ SymI_HasProto(stg_casArrayzh) \ SymI_HasProto(stg_newSmallArrayzh) \ SymI_HasProto(stg_unsafeThawSmallArrayzh) \ diff --git a/rts/include/stg/MiscClosures.h b/rts/include/stg/MiscClosures.h index 8c6b863d0a..e87eba0931 100644 --- a/rts/include/stg/MiscClosures.h +++ b/rts/include/stg/MiscClosures.h @@ -450,11 +450,8 @@ RTS_FUN_DECL(stg_casInt16Arrayzh); RTS_FUN_DECL(stg_casInt32Arrayzh); RTS_FUN_DECL(stg_casInt64Arrayzh); RTS_FUN_DECL(stg_newArrayzh); -RTS_FUN_DECL(stg_newArrayArrayzh); RTS_FUN_DECL(stg_copyArrayzh); RTS_FUN_DECL(stg_copyMutableArrayzh); -RTS_FUN_DECL(stg_copyArrayArrayzh); -RTS_FUN_DECL(stg_copyMutableArrayArrayzh); RTS_FUN_DECL(stg_cloneArrayzh); RTS_FUN_DECL(stg_cloneMutableArrayzh); RTS_FUN_DECL(stg_freezzeArrayzh); diff --git a/testsuite/tests/array/should_run/arr020.hs b/testsuite/tests/array/should_run/arr020.hs index 0dacf78216..dca7c2e64b 100644 --- a/testsuite/tests/array/should_run/arr020.hs +++ b/testsuite/tests/array/should_run/arr020.hs @@ -2,8 +2,7 @@ module Main where -import GHC.Prim -import GHC.Base +import GHC.Exts import GHC.ST import GHC.Word import Control.Monad diff --git a/testsuite/tests/primops/should_compile/UnliftedMutVar_Comp.hs b/testsuite/tests/primops/should_compile/UnliftedMutVar_Comp.hs new file mode 100644 index 0000000000..366cebeed2 --- /dev/null +++ b/testsuite/tests/primops/should_compile/UnliftedMutVar_Comp.hs @@ -0,0 +1,12 @@ + +{-# LANGUAGE UnboxedTuples, MagicHash #-} + +module UnliftedMutVar_Comp where + +import GHC.Exts + +readForCAS# :: MutVar# RealWorld a -> State# RealWorld -> (# State# RealWorld, a #) +readForCAS# = unsafeCoerce# readMutVar# + + -- this used to cause a panic in boxedRepDataCon, because a levity variable + -- was being defaulted to 'Any' instead of 'Lifted'. diff --git a/testsuite/tests/primops/should_compile/UnliftedStableName.hs b/testsuite/tests/primops/should_compile/UnliftedStableName.hs new file mode 100644 index 0000000000..2507646983 --- /dev/null +++ b/testsuite/tests/primops/should_compile/UnliftedStableName.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UnliftedDatatypes #-} + +module Main where + +import Data.Kind +import GHC.Exts +import GHC.IO + +type U :: UnliftedType +data U = U Int# Int# + +main :: IO () +main = do + IO \ s0 -> + case makeStableName# (U 97531# 86420#) s0 of + (# s1, nm1 #) -> + case makeStableName# (U 86420# 97531#) s1 of + (# s2, nm2 #) -> + case makeStableName# (U 97531# 86420#) s1 of + (# s3, nm3 #) -> + (# s3, () #) diff --git a/testsuite/tests/primops/should_compile/all.T b/testsuite/tests/primops/should_compile/all.T index 1613313748..023eeaedce 100644 --- a/testsuite/tests/primops/should_compile/all.T +++ b/testsuite/tests/primops/should_compile/all.T @@ -2,3 +2,5 @@ test('T6135_should_compile', normal, compile, ['']) test('T16293a', normal, compile, ['']) test('T19851', normal, compile, ['-O']) test('LevPolyPtrEquality3', normal, compile, ['']) +test('UnliftedMutVar_Comp', normal, compile, ['']) +test('UnliftedStableName', normal, compile, [''])
\ No newline at end of file diff --git a/testsuite/tests/primops/should_run/UnliftedArray1.hs b/testsuite/tests/primops/should_run/UnliftedArray1.hs new file mode 100644 index 0000000000..c8c401d8da --- /dev/null +++ b/testsuite/tests/primops/should_run/UnliftedArray1.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} + +module Main where + +import GHC.Exts +import GHC.IO + +main :: IO () +main = do + res <- IO \ s0 -> + case newArray# 4# (41 :: Int) s0 of + (# s1, marr1 #) -> + case newArray# 7# (11 :: Int) s1 of + (# s2, marr2 #) -> + case unsafeFreezeArray# marr1 s2 of + (# s3, arr1 #) -> + case unsafeFreezeArray# marr2 s3 of + (# s4, arr2 #) -> + case newArray# 3# arr1 s4 of + (# s5, marrarr #) -> + case writeArray# marrarr 2# arr2 s5 of + s6 -> + case unsafeFreezeArray# marrarr s6 of + (# s7, arrarr #) -> + case indexArray# arrarr 2# of + (# read_arr_2 #) -> + case indexArray# arrarr 0# of + (# read_arr_0 #) -> + case indexArray# read_arr_2 6# of + (# val_11 #) -> + case indexArray# read_arr_0 3# of + (# val_41 #) -> + (# s7, [I# (sizeofArray# arrarr), val_11, val_41] #) + print res diff --git a/testsuite/tests/primops/should_run/UnliftedArray1.stdout b/testsuite/tests/primops/should_run/UnliftedArray1.stdout new file mode 100644 index 0000000000..dcfcf2beb2 --- /dev/null +++ b/testsuite/tests/primops/should_run/UnliftedArray1.stdout @@ -0,0 +1 @@ +[3,11,41] diff --git a/testsuite/tests/primops/should_run/UnliftedArray2.hs b/testsuite/tests/primops/should_run/UnliftedArray2.hs new file mode 100644 index 0000000000..490d183416 --- /dev/null +++ b/testsuite/tests/primops/should_run/UnliftedArray2.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UnliftedDatatypes #-} + +module Main where + +import GHC.Exts +import GHC.IO + +type U :: UnliftedType +data U = U !Int + +main :: IO () +main = do + res <- IO \ s1 -> + case newArray# 7# (U 3) s1 of + (# s2, marr1 #) -> + case newArray# 9# (U 8) s2 of + (# s3, marr2 #) -> + case copyMutableArray# marr1 2# marr2 1# 3# s3 of + s4 -> + case writeArray# marr1 3# (U 11) s4 of + s5 -> + case freezeArray# marr2 0# 8# s5 of + (# s6, arr2 #) -> + case copyArray# arr2 1# marr2 1# 1# s6 of + s7 -> + case readArray# marr2 2# s7 of + (# s8, U val1 #) -> + case thawArray# arr2 1# 7# s8 of + (# s9, marr2' #) -> + case readArray# marr2' 5# s9 of + (# s10, U val2 #) -> + (# s10, [I# (sizeofMutableArray# marr2), val1, val2] #) + print res diff --git a/testsuite/tests/primops/should_run/UnliftedArray2.stdout b/testsuite/tests/primops/should_run/UnliftedArray2.stdout new file mode 100644 index 0000000000..386319ed6e --- /dev/null +++ b/testsuite/tests/primops/should_run/UnliftedArray2.stdout @@ -0,0 +1 @@ +[9,3,8] diff --git a/testsuite/tests/primops/should_run/UnliftedArrayCAS.hs b/testsuite/tests/primops/should_run/UnliftedArrayCAS.hs new file mode 100644 index 0000000000..2002573e5e --- /dev/null +++ b/testsuite/tests/primops/should_run/UnliftedArrayCAS.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UnliftedDatatypes #-} + +module Main where + +import GHC.Exts +import GHC.IO + +type U :: UnliftedType +data U = U Int# + +main :: IO () +main = do + let star = U 1612# + res <- IO \ s0 -> + case newArray# 10# star s0 of + (# s1, arr #) -> + case readArray# arr 7# s1 of + (# s2, U v0 #) -> + case casArray# arr 7# star (U 1728#) s2 of + (# s2, i, U f #) -> + case casArray# arr 7# star (U 1989#) s2 of + (# s3, j, U g #) -> + (# s3, [ I# v0, I# i, I# f, I# j, I# g ] #) + print res diff --git a/testsuite/tests/primops/should_run/UnliftedArrayCAS.stdout b/testsuite/tests/primops/should_run/UnliftedArrayCAS.stdout new file mode 100644 index 0000000000..98711e8b25 --- /dev/null +++ b/testsuite/tests/primops/should_run/UnliftedArrayCAS.stdout @@ -0,0 +1 @@ +[1612,0,1728,1,1728] diff --git a/testsuite/tests/primops/should_run/UnliftedIOPort.hs b/testsuite/tests/primops/should_run/UnliftedIOPort.hs new file mode 100644 index 0000000000..7bdf0dff7a --- /dev/null +++ b/testsuite/tests/primops/should_run/UnliftedIOPort.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UnliftedDatatypes #-} + +module Main where + +import Data.Kind +import GHC.Exts +import GHC.IO + +type U :: Type +data U = U Int# + +main :: IO () +main = do + res <- IO \ s0 -> + case newIOPort# s0 of + (# s1, port #) -> + case writeIOPort# port (U 17#) s1 of + (# s2, i #) -> + case catch# (writeIOPort# port (U 19#)) (\ _ s -> (# s, 3# #)) s2 of + (# s3, j #) -> + case readIOPort# port s3 of + (# s4, U r1 #) -> + case catch# (readIOPort# port) (\ _ s -> (# s, U 4# #)) s4 of + (# s5, U r2 #) -> + (# s5, [ I# i, I# j, I# r1, I# r2 ] #) + print res diff --git a/testsuite/tests/primops/should_run/UnliftedIOPort.stdout b/testsuite/tests/primops/should_run/UnliftedIOPort.stdout new file mode 100644 index 0000000000..0b8c2d48bf --- /dev/null +++ b/testsuite/tests/primops/should_run/UnliftedIOPort.stdout @@ -0,0 +1 @@ +[1,3,17,4] diff --git a/testsuite/tests/primops/should_run/UnliftedMVar.hs b/testsuite/tests/primops/should_run/UnliftedMVar.hs new file mode 100644 index 0000000000..2f4349b622 --- /dev/null +++ b/testsuite/tests/primops/should_run/UnliftedMVar.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UnliftedDatatypes #-} + +module Main where + +import Data.Kind +import GHC.Exts +import GHC.IO + +type U :: UnliftedType +data U = U Int# + +main :: IO () +main = do + res <- IO \ s0 -> + case newMVar# s0 of + (# s1, mvar #) -> + case tryTakeMVar# mvar s1 of + (# s2, i, _ #) -> + case putMVar# mvar (U 1612#) s2 of + s3 -> + case readMVar# mvar s3 of + (# s4, U r1 #) -> + case takeMVar# mvar s4 of + (# s5, U r2 #) -> + case tryReadMVar# mvar s5 of + (# s6, j, _ #) -> + case isEmptyMVar# mvar s6 of + (# s7, k #) -> + (# s6, [ I# i, I# r1, I# r2, I# j, I# k ] #) + print res diff --git a/testsuite/tests/primops/should_run/UnliftedMVar.stdout b/testsuite/tests/primops/should_run/UnliftedMVar.stdout new file mode 100644 index 0000000000..60db051318 --- /dev/null +++ b/testsuite/tests/primops/should_run/UnliftedMVar.stdout @@ -0,0 +1 @@ +[0,1612,1612,0,1] diff --git a/testsuite/tests/primops/should_run/UnliftedMutVar1.hs b/testsuite/tests/primops/should_run/UnliftedMutVar1.hs new file mode 100644 index 0000000000..12d77e6712 --- /dev/null +++ b/testsuite/tests/primops/should_run/UnliftedMutVar1.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} + +module Main where + +import GHC.Exts +import GHC.IO + +main :: IO () +main = do + res <- IO \ s0 -> + case newMutVar# (41 :: Int) s0 of + (# s1, mvar #) -> + case newMutVar# mvar s1 of + (# s2, mvarmvar #) -> + case writeMutVar# mvar (17 :: Int) s2 of + s3 -> + case readMutVar# mvarmvar s3 of + (# s4, read_mvar #) -> + readMutVar# read_mvar s4 + print res diff --git a/testsuite/tests/primops/should_run/UnliftedMutVar1.stdout b/testsuite/tests/primops/should_run/UnliftedMutVar1.stdout new file mode 100644 index 0000000000..98d9bcb75a --- /dev/null +++ b/testsuite/tests/primops/should_run/UnliftedMutVar1.stdout @@ -0,0 +1 @@ +17 diff --git a/testsuite/tests/primops/should_run/UnliftedMutVar2.hs b/testsuite/tests/primops/should_run/UnliftedMutVar2.hs new file mode 100644 index 0000000000..fe657560ea --- /dev/null +++ b/testsuite/tests/primops/should_run/UnliftedMutVar2.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UnliftedDatatypes #-} + +module Main where + +import GHC.Exts +import GHC.IO + +type U :: UnliftedType +data U = U Int# + +main :: IO () +main = do + res <- IO \ s0 -> + case newMutVar# (U 0#) s0 of + (# s1, var #) -> + sum_squares var s1 + print res + +sum_squares :: MutVar# s U -> State# s -> (# State# s, Int #) +sum_squares var s = case go s of { (# s', i #) -> (# s', I# i #) } + where + go s0 = case readMutVar# var s0 of + (# s1, U val #) + | I# val >= 1000000 + -> (# s1, val #) + | otherwise + -> let nxt = val +# 1# + in case writeMutVar# var (U (val +# nxt *# nxt)) s1 of + s2 -> go s2 diff --git a/testsuite/tests/primops/should_run/UnliftedMutVar2.stdout b/testsuite/tests/primops/should_run/UnliftedMutVar2.stdout new file mode 100644 index 0000000000..a055fad337 --- /dev/null +++ b/testsuite/tests/primops/should_run/UnliftedMutVar2.stdout @@ -0,0 +1 @@ +3263441 diff --git a/testsuite/tests/primops/should_run/UnliftedMutVar3.hs b/testsuite/tests/primops/should_run/UnliftedMutVar3.hs new file mode 100644 index 0000000000..fab8192aca --- /dev/null +++ b/testsuite/tests/primops/should_run/UnliftedMutVar3.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UnliftedDatatypes #-} + +module Main where + +import GHC.Exts +import GHC.IO + +type U :: UnliftedType +data U = X | Y + +showU :: U -> String +showU X = "X" +showU Y = "Y" + +main :: IO () +main = do + res <- IO \ s0 -> + case newMutVar# X s0 of + (# s1, mvar #) -> + case readMutVar# mvar s1 of + (# s2, r1 #) -> + case writeMutVar# mvar Y s2 of + s3 -> case readMutVar# mvar s3 of + (# s4, r2 #) -> + (# s4, [ showU r1, showU r2 ] #) + putStrLn (unwords res) diff --git a/testsuite/tests/primops/should_run/UnliftedMutVar3.stdout b/testsuite/tests/primops/should_run/UnliftedMutVar3.stdout new file mode 100644 index 0000000000..f4c2719cb7 --- /dev/null +++ b/testsuite/tests/primops/should_run/UnliftedMutVar3.stdout @@ -0,0 +1 @@ +X Y diff --git a/testsuite/tests/primops/should_run/UnliftedMutVarCAS.hs b/testsuite/tests/primops/should_run/UnliftedMutVarCAS.hs new file mode 100644 index 0000000000..9559467c6c --- /dev/null +++ b/testsuite/tests/primops/should_run/UnliftedMutVarCAS.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UnliftedDatatypes #-} + +module Main where + +import GHC.Exts +import GHC.IO + +type U :: UnliftedType +data U = U Int# + +main :: IO () +main = do + let star = U 1612# + res <- IO \ s0 -> + case newMutVar# star s0 of + (# s1, var #) -> + case readMutVar# var s1 of + (# s2, U v0 #) -> + case casMutVar# var star (U 1728#) s2 of + (# s3, i, U f #) -> + case casMutVar# var star (U 1989#) s3 of + (# s4, j, U g #) -> + (# s4, [ I# v0, I# i, I# f, I# j, I# g ] #) + print res diff --git a/testsuite/tests/primops/should_run/UnliftedMutVarCAS.stdout b/testsuite/tests/primops/should_run/UnliftedMutVarCAS.stdout new file mode 100644 index 0000000000..98711e8b25 --- /dev/null +++ b/testsuite/tests/primops/should_run/UnliftedMutVarCAS.stdout @@ -0,0 +1 @@ +[1612,0,1728,1,1728] diff --git a/testsuite/tests/primops/should_run/UnliftedSmallArray1.hs b/testsuite/tests/primops/should_run/UnliftedSmallArray1.hs new file mode 100644 index 0000000000..50556b5b54 --- /dev/null +++ b/testsuite/tests/primops/should_run/UnliftedSmallArray1.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} + +module Main where + +import GHC.Exts +import GHC.IO + +main :: IO () +main = do + res <- IO \ s0 -> + case newSmallArray# 4# (41 :: Int) s0 of + (# s1, marr1 #) -> + case newSmallArray# 7# (11 :: Int) s1 of + (# s2, marr2 #) -> + case unsafeFreezeSmallArray# marr1 s2 of + (# s3, arr1 #) -> + case unsafeFreezeSmallArray# marr2 s3 of + (# s4, arr2 #) -> + case newSmallArray# 3# arr1 s4 of + (# s5, marrarr #) -> + case writeSmallArray# marrarr 2# arr2 s5 of + s6 -> + case unsafeFreezeSmallArray# marrarr s6 of + (# s7, arrarr #) -> + case indexSmallArray# arrarr 2# of + (# read_arr_2 #) -> + case indexSmallArray# arrarr 0# of + (# read_arr_0 #) -> + case indexSmallArray# read_arr_2 6# of + (# val_11 #) -> + case indexSmallArray# read_arr_0 3# of + (# val_41 #) -> + (# s7, [I# (sizeofSmallArray# arrarr), val_11, val_41] #) + print res diff --git a/testsuite/tests/primops/should_run/UnliftedSmallArray1.stdout b/testsuite/tests/primops/should_run/UnliftedSmallArray1.stdout new file mode 100644 index 0000000000..dcfcf2beb2 --- /dev/null +++ b/testsuite/tests/primops/should_run/UnliftedSmallArray1.stdout @@ -0,0 +1 @@ +[3,11,41] diff --git a/testsuite/tests/primops/should_run/UnliftedSmallArray2.hs b/testsuite/tests/primops/should_run/UnliftedSmallArray2.hs new file mode 100644 index 0000000000..34f894c07f --- /dev/null +++ b/testsuite/tests/primops/should_run/UnliftedSmallArray2.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UnliftedDatatypes #-} + +module Main where + +import GHC.Exts +import GHC.IO + +type U :: UnliftedType +data U = U !Int + +main :: IO () +main = do + res <- IO \ s1 -> + case newSmallArray# 7# (U 3) s1 of + (# s2, marr1 #) -> + case newSmallArray# 9# (U 8) s2 of + (# s3, marr2 #) -> + case copySmallMutableArray# marr1 2# marr2 1# 3# s3 of + s4 -> + case writeSmallArray# marr1 3# (U 11) s4 of + s5 -> + case freezeSmallArray# marr2 0# 8# s5 of + (# s6, arr2 #) -> + case copySmallArray# arr2 1# marr2 1# 1# s6 of + s7 -> + case readSmallArray# marr2 2# s7 of + (# s8, U val1 #) -> + case thawSmallArray# arr2 1# 7# s8 of + (# s9, marr2' #) -> + case shrinkSmallMutableArray# marr2' 6# s9 of + s10 -> + case readSmallArray# marr2' 5# s10 of + (# s11, U val2 #) -> + case getSizeofSmallMutableArray# marr2' s11 of + (# s12, sz #) -> + (# s12, [I# sz, val1, val2] #) + print res diff --git a/testsuite/tests/primops/should_run/UnliftedSmallArray2.stdout b/testsuite/tests/primops/should_run/UnliftedSmallArray2.stdout new file mode 100644 index 0000000000..750263349e --- /dev/null +++ b/testsuite/tests/primops/should_run/UnliftedSmallArray2.stdout @@ -0,0 +1 @@ +[6,3,8] diff --git a/testsuite/tests/primops/should_run/UnliftedStablePtr.hs b/testsuite/tests/primops/should_run/UnliftedStablePtr.hs new file mode 100644 index 0000000000..1b973ead87 --- /dev/null +++ b/testsuite/tests/primops/should_run/UnliftedStablePtr.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UnliftedDatatypes #-} + +module Main where + +import Data.Kind +import System.Mem (performGC) +import GHC.Exts +import GHC.IO + +type U :: UnliftedType +data U = U Int# Int# + +main :: IO () +main = do + res <- IO \ s0 -> + let u :: U + u = U 97531# 86420# + in + case makeStablePtr# u s0 of + (# s1, ptr #) -> + case unIO performGC s1 of + (# s3, _ #) -> + case deRefStablePtr# ptr s3 of + (# s4, U i j #) -> + case makeStablePtr# (U 123# 456#) s4 of + (# s5, ptr' #) -> + (# s5, [ I# i, I# j, I# (eqStablePtr# ptr ptr), I# (eqStablePtr# ptr ptr') ] #) + print res diff --git a/testsuite/tests/primops/should_run/UnliftedStablePtr.stdout b/testsuite/tests/primops/should_run/UnliftedStablePtr.stdout new file mode 100644 index 0000000000..4a9e91e841 --- /dev/null +++ b/testsuite/tests/primops/should_run/UnliftedStablePtr.stdout @@ -0,0 +1 @@ +[97531,86420,1,0] diff --git a/testsuite/tests/primops/should_run/UnliftedTVar1.hs b/testsuite/tests/primops/should_run/UnliftedTVar1.hs new file mode 100644 index 0000000000..a576d11f9a --- /dev/null +++ b/testsuite/tests/primops/should_run/UnliftedTVar1.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UnliftedDatatypes #-} + +module Main where + +import Data.Kind +import GHC.Exts +import GHC.IO + +type U :: UnliftedType +data U = U Int# + +main :: IO () +main = do + res <- IO \ s0 -> + case newTVar# (U 1612#) s0 of + (# s1, tvar #) -> + case atomically# (readAndWrite tvar) s1 of + (# s2, U r #) -> + case readTVarIO# tvar s2 of + (# s3, U res #) -> + (# s3, [ I# r, I# res ] #) + print res + +readAndWrite :: TVar# s U -> State# s -> (# State# s, U #) +readAndWrite tvar = go + where + go s0 = + case readTVar# tvar s0 of + (# s1, U i #) -> + case writeTVar# tvar (U (i *# 100#)) s1 of + s2 -> (# s2, U i #) diff --git a/testsuite/tests/primops/should_run/UnliftedTVar1.stdout b/testsuite/tests/primops/should_run/UnliftedTVar1.stdout new file mode 100644 index 0000000000..d27bb7d2e8 --- /dev/null +++ b/testsuite/tests/primops/should_run/UnliftedTVar1.stdout @@ -0,0 +1 @@ +[1612,161200] diff --git a/testsuite/tests/primops/should_run/UnliftedTVar2.hs b/testsuite/tests/primops/should_run/UnliftedTVar2.hs new file mode 100644 index 0000000000..70cbce18a8 --- /dev/null +++ b/testsuite/tests/primops/should_run/UnliftedTVar2.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UnliftedDatatypes #-} + +module Main where + +import Data.Kind +import GHC.Exts +import GHC.IO + +type U :: UnliftedType +data U = U Int# + +main :: IO () +main = do + (x,y) <- IO \ s0 -> + case newTVar# (U 0#) s0 of + (# s1, tvar #) -> + case fork# (increment tvar) s1 of + (# s2, t_id #) -> + case atomically# (readUntil tvar) s2 of + (# s3, U r #) -> + case killThread# t_id 13 s3 of + s4 -> + case readTVarIO# tvar s4 of + (# s5, U res #) -> + (# s5, ( I# r, I# res ) #) + print (x == y, x > 100000) + +increment :: TVar# RealWorld U -> State# RealWorld -> (# State# RealWorld, Int #) +increment tvar = go + where + go :: State# RealWorld -> (# State# RealWorld, Int #) + go s0 = case atomically# inc s0 of + (# s1, res #) -> go s1 + + inc :: State# RealWorld -> (# State# RealWorld, Int #) + inc s0 = + case readTVar# tvar s0 of + (# s1, U v #) -> + case writeTVar# tvar (U (v +# 1#)) s1 of + s2 -> (# s2, I# v #) + +readUntil :: TVar# RealWorld U -> State# RealWorld -> (# State# RealWorld, U #) +readUntil tvar = go + where + go s0 = + case readTVar# tvar s0 of + (# s1, r@(U i) #) + | I# i >= 100000 + -> (# s1, r #) + | otherwise + -> retry# s1 diff --git a/testsuite/tests/primops/should_run/UnliftedTVar2.stdout b/testsuite/tests/primops/should_run/UnliftedTVar2.stdout new file mode 100644 index 0000000000..1fa0b54b36 --- /dev/null +++ b/testsuite/tests/primops/should_run/UnliftedTVar2.stdout @@ -0,0 +1 @@ +(True,True) diff --git a/testsuite/tests/primops/should_run/UnliftedWeakPtr.hs b/testsuite/tests/primops/should_run/UnliftedWeakPtr.hs new file mode 100644 index 0000000000..d957485eba --- /dev/null +++ b/testsuite/tests/primops/should_run/UnliftedWeakPtr.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UnliftedDatatypes #-} + +module Main where + +import Data.Kind +import System.Mem (performGC) +import GHC.Exts +import GHC.IO + +type U :: UnliftedType +data U = U Int# + +main :: IO () +main = do + res <- IO \ s0 -> + case newMVar# s0 of + (# s1, mvar #) -> + case newMutVar# False s1 of + (# s2, val_var #) -> + case keepAlive# val_var s2 (inner mvar val_var) of + (# s3, wk, strs #) -> + case unIO performGC s3 of + (# s4, _ #) -> + case deRefWeak# wk s4 of + (# s5, j, _ #) -> + case takeMVar# mvar s5 of + (# s6, r #) -> + (# s6, strs ++ [ show (I# j), r ] #) + print res + +inner :: MVar# RealWorld String + -> MutVar# RealWorld Bool + -> State# RealWorld + -> (# State# RealWorld, Weak# U, [String] #) +inner mvar u s0 = + case mkWeak# u (U 42#) (finalise mvar) s0 of + (# s1, wk #) -> + case deRefWeak# wk s1 of + (# s2, i, U u #) -> (# s2, wk, [ show (I# i), show (I# u) ] #) + +finalise :: MVar# RealWorld String -> State# RealWorld -> (# State# RealWorld, () #) +finalise mvar s0 = + case putMVar# mvar "finalised!" s0 of + s1 -> (# s1, () #) diff --git a/testsuite/tests/primops/should_run/UnliftedWeakPtr.stdout b/testsuite/tests/primops/should_run/UnliftedWeakPtr.stdout new file mode 100644 index 0000000000..327ad4fa74 --- /dev/null +++ b/testsuite/tests/primops/should_run/UnliftedWeakPtr.stdout @@ -0,0 +1 @@ +["1","42","0","finalised!"] diff --git a/testsuite/tests/primops/should_run/all.T b/testsuite/tests/primops/should_run/all.T index ef046f34ae..b4a4b1f612 100644 --- a/testsuite/tests/primops/should_run/all.T +++ b/testsuite/tests/primops/should_run/all.T @@ -41,3 +41,19 @@ test('Sized', normal, compile_and_run, ['']) test('LevPolyPtrEquality1', normal, compile_and_run, ['']) test('LevPolyPtrEquality2', normal, compile_and_run, ['']) + +test('UnliftedArray1', normal, compile_and_run, ['']) +test('UnliftedArray2', normal, compile_and_run, ['']) +test('UnliftedArrayCAS', normal, compile_and_run, ['']) +test('UnliftedIOPort', normal, compile_and_run, ['']) +test('UnliftedMutVar1', normal, compile_and_run, ['']) +test('UnliftedMutVar2', normal, compile_and_run, ['']) +test('UnliftedMutVar3', normal, compile_and_run, ['']) +test('UnliftedMutVarCAS', normal, compile_and_run, ['']) +test('UnliftedMVar', normal, compile_and_run, ['']) +test('UnliftedSmallArray1', normal, compile_and_run, ['']) +test('UnliftedSmallArray2', normal, compile_and_run, ['']) +test('UnliftedStablePtr', normal, compile_and_run, ['']) +test('UnliftedTVar1', normal, compile_and_run, ['']) +test('UnliftedTVar2', normal, compile_and_run, ['']) +test('UnliftedWeakPtr', normal, compile_and_run, ['']) |