packages feed

primitive-unlifted 1.0.0.0 → 2.0.0.0

raw patch · 17 files changed

+202/−156 lines, 17 filesdep ~basedep ~bytestringdep ~primitive

Dependency ranges changed: base, bytestring, primitive

Files

CHANGELOG.md view
@@ -4,6 +4,11 @@ The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/) and this project adheres to the [Haskell Package Versioning Policy](https://pvp.haskell.org/). +## 2.0.0.0 -- 2023-06-27++* Use legitimate unlifted primitive types and operations, only supporting+  GHC 9.4 and newer.+ ## 1.0.0.0 -- 2020-11-02  * Redo everything. This uses `unsafeCoerce#` a lot to coerce between
primitive-unlifted.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.2 name: primitive-unlifted-version: 1.0.0.0+version: 2.0.0.0 synopsis: Primitive GHC types with unlifted types inside description:   Primitive GHC types with unlifted types inside. There used@@ -19,7 +19,7 @@ copyright: 2019 Andrew Martin category: Data extra-source-files: CHANGELOG.md-tested-with: GHC == 8.10.1+tested-with: GHC == 9.4.5  library   exposed-modules:@@ -41,10 +41,11 @@     Data.Primitive.Unlifted.MVar     Data.Primitive.Unlifted.MVar.ST     Data.Primitive.Unlifted.MVar.Primops+    Data.Primitive.Unlifted.Type   build-depends:-    , base >=4.14.0.0 && <5-    , bytestring >=0.10.8.2 && <0.11-    , primitive >= 0.7 && <0.8+    , base >=4.17.1.0 && <5+    , bytestring >=0.10.8.2 && <0.12+    , primitive >= 0.7 && <0.10     , text-short >=0.1.3 && <0.2     , array   hs-source-dirs: src
src/Data/Primitive/Unlifted/Array/Primops.hs view
@@ -3,7 +3,10 @@ {-# language RoleAnnotations #-} {-# language UnliftedNewtypes #-} {-# language KindSignatures #-}+{-# language StandaloneKindSignatures #-} {-# language ScopedTypeVariables #-}+{-# language DataKinds #-}+{-# language UnliftedDatatypes #-}  -- Oh what a mess this is! See UnsafeCoercions.md for an explanation -- of the hodgepodge in this module.@@ -13,12 +16,8 @@ -- primops for manipulating them. module Data.Primitive.Unlifted.Array.Primops   ( -- * Types-    UnliftedArray#-  , MutableUnliftedArray#-    -- We don't export the newtype constructors because they're bogus and-    -- because there's basically no reason they'd ever be used. This module-    -- contains a wrapped version of every Array# primop.  Eventually, all this-    -- stuff will be supported by GHC.Prim using BoxedRep.+    UnliftedArray#(..)+  , MutableUnliftedArray#(..)      -- * Operations   , newUnliftedArray#@@ -41,37 +40,36 @@   , casUnliftedArray#   ) where -import GHC.Exts ( Int#, State#, ArrayArray#, MutableArrayArray#-                , TYPE, RuntimeRep (UnliftedRep), unsafeCoerce#)+import Data.Coerce (coerce)+import GHC.Exts ( Int#, State#, Array#, MutableArray# ) import qualified GHC.Exts as Exts -unsafeCoerceUnlifted :: forall (a :: TYPE 'UnliftedRep) (b :: TYPE 'UnliftedRep). a -> b-{-# INLINE unsafeCoerceUnlifted #-}-unsafeCoerceUnlifted a = unsafeCoerce# a--unsafeCoerceUnliftedST :: forall s (a :: TYPE 'UnliftedRep) (b :: TYPE 'UnliftedRep). (# State# s, a #) -> (# State# s, b #)-{-# INLINE unsafeCoerceUnliftedST #-}-unsafeCoerceUnliftedST a = unsafeCoerce# a+import Data.Primitive.Unlifted.Type+import Unsafe.Coerce (unsafeCoerceUnlifted) -newtype UnliftedArray# (a :: TYPE 'UnliftedRep) = UnliftedArray# ArrayArray#+newtype UnliftedArray# (a :: UnliftedType) = UnliftedArray# (Array# a) type role UnliftedArray# representational -newtype MutableUnliftedArray# s (a :: TYPE 'UnliftedRep) = MutableUnliftedArray# (MutableArrayArray# s)+newtype MutableUnliftedArray# s (a :: UnliftedType) = MutableUnliftedArray# (MutableArray# s a) type role MutableUnliftedArray# nominal representational  newUnliftedArray# :: Int# -> a -> State# s -> (# State# s, MutableUnliftedArray# s a #)-newUnliftedArray# sz a s = unsafeCoerceUnliftedST (Exts.newArray# sz (unsafeCoerce# a) s)-{-# NOINLINE newUnliftedArray# #-}+newUnliftedArray# sz a s = coerce (Exts.newArray# sz a s)+{-# INLINE newUnliftedArray# #-}  -- | Create a 'MutableUnliftedArray#' whose entries contain some unspecified -- static value. This may be more convenient than 'newUnliftedArray#' if there -- is no value on hand with which to initialize the array. Each entry must be -- initialized before being read and used. This condition is not checked. unsafeNewUnliftedArray# :: Int# -> State# s -> (# State# s, MutableUnliftedArray# s a #)-unsafeNewUnliftedArray# sz s = case Exts.newArrayArray# sz s of-  (# s', mary #) -> (# s', MutableUnliftedArray# mary #)+unsafeNewUnliftedArray# sz s+  | (# s', mary #) <- Exts.newArray# sz (unsafeCoerceUnlifted Nonsense) s+  = (# s', MutableUnliftedArray# mary #) {-# INLINE unsafeNewUnliftedArray# #-} +type Nonsense :: UnliftedType+data Nonsense = Nonsense+ -- This represents a *statically allocated* value, preferably in a *read-only* -- segment of memory. --@@ -108,80 +106,80 @@  sameMutableUnliftedArray# :: MutableUnliftedArray# s a -> MutableUnliftedArray# s a -> Int# sameMutableUnliftedArray# (MutableUnliftedArray# ar1) (MutableUnliftedArray# ar2)-  = Exts.sameMutableArrayArray# ar1 ar2+  = Exts.reallyUnsafePtrEquality# ar1 ar2 {-# INLINE sameMutableUnliftedArray# #-}  readUnliftedArray# :: MutableUnliftedArray# s a -> Int# -> State# s -> (# State# s, a #) readUnliftedArray# (MutableUnliftedArray# mary) i s-  = unsafeCoerceUnliftedST (Exts.readArrayArrayArray# mary i s)+  = coerce (Exts.readArray# mary i s) {-# INLINE readUnliftedArray# #-}  writeUnliftedArray# :: MutableUnliftedArray# s a -> Int# -> a -> State# s -> State# s writeUnliftedArray# (MutableUnliftedArray# mary) i a s-  = Exts.writeArrayArrayArray# mary i (unsafeCoerceUnlifted a) s+  = Exts.writeArray# mary i a s {-# INLINE writeUnliftedArray# #-}  sizeofUnliftedArray# :: UnliftedArray# a -> Int#-sizeofUnliftedArray# (UnliftedArray# ary) = Exts.sizeofArrayArray# ary+sizeofUnliftedArray# (UnliftedArray# ary) = Exts.sizeofArray# ary {-# INLINE sizeofUnliftedArray# #-}  sizeofMutableUnliftedArray# :: MutableUnliftedArray# s a -> Int# sizeofMutableUnliftedArray# (MutableUnliftedArray# mary)-  = Exts.sizeofMutableArrayArray# mary+  = Exts.sizeofMutableArray# mary {-# INLINE sizeofMutableUnliftedArray# #-}  indexUnliftedArray# :: UnliftedArray# a -> Int# -> a indexUnliftedArray# (UnliftedArray# ary) i-  = unsafeCoerceUnlifted (Exts.indexArrayArrayArray# ary i)+  = case Exts.indexArray# ary i of (# a #) -> a {-# INLINE indexUnliftedArray# #-}  unsafeFreezeUnliftedArray# :: MutableUnliftedArray# s a -> State# s -> (# State# s, UnliftedArray# a #) unsafeFreezeUnliftedArray# (MutableUnliftedArray# mary) s-  = case Exts.unsafeFreezeArrayArray# mary s of+  = case Exts.unsafeFreezeArray# mary s of       (# s', ary #) -> (# s', UnliftedArray# ary #) {-# INLINE unsafeFreezeUnliftedArray# #-}  unsafeThawUnliftedArray# :: UnliftedArray# a -> State# s -> (# State# s, MutableUnliftedArray# s a #) unsafeThawUnliftedArray# (UnliftedArray# ary) s-  = case Exts.unsafeThawArray# (unsafeCoerceUnlifted ary) s of-     (# s', mary #) -> (# s', MutableUnliftedArray# (unsafeCoerceUnlifted mary) #)+  = case Exts.unsafeThawArray# ary s of+     (# s', mary #) -> (# s', MutableUnliftedArray# mary #) {-# INLINE unsafeThawUnliftedArray# #-}  copyUnliftedArray# :: UnliftedArray# a -> Int# -> MutableUnliftedArray# s a -> Int# -> Int# -> State# s -> State# s copyUnliftedArray# (UnliftedArray# ary) i1 (MutableUnliftedArray# mary) i2 n s-  = Exts.copyArrayArray# ary i1 mary i2 n s+  = Exts.copyArray# ary i1 mary i2 n s {-# INLINE copyUnliftedArray# #-}  copyMutableUnliftedArray# :: MutableUnliftedArray# s a -> Int# -> MutableUnliftedArray# s a -> Int# -> Int# -> State# s -> State# s copyMutableUnliftedArray# (MutableUnliftedArray# mary1) i1 (MutableUnliftedArray# mary2) i2 n s-  = Exts.copyMutableArrayArray# mary1 i1 mary2 i2 n s+  = Exts.copyMutableArray# mary1 i1 mary2 i2 n s {-# INLINE copyMutableUnliftedArray# #-}  cloneUnliftedArray# :: UnliftedArray# a -> Int# -> Int# -> UnliftedArray# a cloneUnliftedArray# (UnliftedArray# ary) i n-  = UnliftedArray# (unsafeCoerceUnlifted (Exts.cloneArray# (unsafeCoerceUnlifted ary) i n))+  = UnliftedArray# (Exts.cloneArray# ary i n) {-# INLINE cloneUnliftedArray# #-}  cloneMutableUnliftedArray# :: MutableUnliftedArray# s a -> Int# -> Int# -> State# s   -> (# State# s, MutableUnliftedArray# s a #) cloneMutableUnliftedArray# (MutableUnliftedArray# mary) i n s-  = case Exts.cloneMutableArray# (unsafeCoerceUnlifted mary) i n s of-      (# s', mary' #) -> (# s', MutableUnliftedArray# (unsafeCoerceUnlifted mary') #)+  = case Exts.cloneMutableArray# mary i n s of+      (# s', mary' #) -> (# s', MutableUnliftedArray# mary' #) {-# INLINE cloneMutableUnliftedArray# #-}  freezeUnliftedArray# :: MutableUnliftedArray# s a -> Int# -> Int# -> State# s -> (# State# s, UnliftedArray# a #) freezeUnliftedArray# (MutableUnliftedArray# mary) i n s-  = case Exts.freezeArray# (unsafeCoerceUnlifted mary) i n s of-      (# s', ary #) -> (# s', UnliftedArray# (unsafeCoerceUnlifted ary) #)+  = case Exts.freezeArray# mary i n s of+      (# s', ary #) -> (# s', UnliftedArray# ary #) {-# INLINE freezeUnliftedArray# #-}  thawUnliftedArray# :: UnliftedArray# a -> Int# -> Int# -> State# s -> (# State# s, MutableUnliftedArray# s a #) thawUnliftedArray# (UnliftedArray# ary) i n s-  = case Exts.thawArray# (unsafeCoerceUnlifted ary) i n s of-      (# s', mary #) -> (# s', MutableUnliftedArray# (unsafeCoerceUnlifted mary) #)+  = case Exts.thawArray# ary i n s of+      (# s', mary #) -> (# s', MutableUnliftedArray# mary #) {-# INLINE thawUnliftedArray# #-}  casUnliftedArray# :: MutableUnliftedArray# s a -> Int# -> a -> a -> State# s -> (# State# s, Int#, a #) casUnliftedArray# (MutableUnliftedArray# mary) i x y s-  = unsafeCoerce# (Exts.casArray# (unsafeCoerceUnlifted mary) i (unsafeCoerce# x) (unsafeCoerce# y) s)-{-# NOINLINE casUnliftedArray# #-}+  = coerce (Exts.casArray# mary i x y s)+{-# INLINE casUnliftedArray# #-}
src/Data/Primitive/Unlifted/Array/ST.hs view
@@ -3,6 +3,7 @@ {-# language RankNTypes #-} {-# language ScopedTypeVariables #-} {-# language TypeFamilies #-}+{-# language TypeOperators #-} {-# language UnboxedTuples #-} {-# language RoleAnnotations #-}
src/Data/Primitive/Unlifted/Box.hs view
@@ -1,12 +1,37 @@ {-# language KindSignatures #-} {-# language TypeFamilies #-} {-# language MagicHash #-}+{-# language DataKinds #-} +-- | Traditionally, there were only a few basic unlifted types available in+-- GHC, all of them primitive. Now, with the @UnliftedNewtypes@ and+-- @UnliftedDatatypes@ extensions, users are free to create as many as they+-- like. However, many essential facilities, like the 'Monad' class, still work+-- only with lifted types, so users must wrap their unlifted types into lifted+-- ones to use those. If the wrapped version of a type is likely to be used+-- heavily on its own, it often makes sense to write a custom wrapper type for+-- it. This module exports a general box for situations where the focus should+-- be on the unlifted type rather than its wrapper. module Data.Primitive.Unlifted.Box where-import GHC.Exts (TYPE, RuntimeRep (UnliftedRep))+ import Data.Primitive.Unlifted.Class+import Data.Primitive.Unlifted.Type -data Box (a :: TYPE 'UnliftedRep) = Box# { unBox# :: a }+-- | Turn an arbitrary unlifted type into a lifted one with a 'PrimUnlifted'+-- instance. For example, given+--+-- @+-- data UnliftedMaybe a :: UnliftedType where+--   UnliftedNothing :: UnliftedMaybe a+--   UnliftedJust :: a -> UnliftedMaybe a+-- @+--+-- we have+--+-- @+-- Box (UnliftedMaybe a) :: Type+-- @+data Box (a :: UnliftedType) = Box# { unBox# :: a }  instance PrimUnlifted (Box a) where   {-# INLINE toUnlifted# #-}
src/Data/Primitive/Unlifted/Class.hs view
@@ -2,6 +2,7 @@ {-# language UnboxedTuples #-} {-# language TypeFamilies #-} {-# language ScopedTypeVariables #-}+{-# language DataKinds #-}  module Data.Primitive.Unlifted.Class   ( PrimUnlifted(..)@@ -24,15 +25,15 @@ import GHC.Exts (MutableByteArray#,ByteArray#                 ,Array#,MutableArray#,SmallArray#,SmallMutableArray#                 ,Weak#,TVar#,ThreadId#,StableName#)-import GHC.Exts (RuntimeRep(UnliftedRep)) import GHC.Exts (MVar#,MutVar#,RealWorld)-import GHC.Exts (TYPE)  import qualified Data.Primitive.MVar as PM import qualified GHC.Exts as Exts +import Data.Primitive.Unlifted.Type+ class PrimUnlifted a where-  type Unlifted a :: TYPE 'UnliftedRep+  type Unlifted a :: UnliftedType   toUnlifted# :: a -> Unlifted a   fromUnlifted# :: Unlifted a -> a
src/Data/Primitive/Unlifted/MVar.hs view
@@ -3,6 +3,7 @@ {-# language RoleAnnotations #-} {-# language ScopedTypeVariables #-} {-# language TypeFamilies #-}+{-# language TypeOperators #-} {-# language MagicHash #-} {-# language RankNTypes #-} {-# language PatternSynonyms #-}
src/Data/Primitive/Unlifted/MVar/Primops.hs view
@@ -19,9 +19,12 @@   , sameUnliftedMVar#   , isEmptyUnliftedMVar#   ) where-import GHC.Exts -newtype UnliftedMVar# s (a :: TYPE 'UnliftedRep) = UnliftedMVar# (MVar# s Any)+import GHC.Exts (MVar#, State#, Int#, newMVar#, takeMVar#, tryTakeMVar#, putMVar#, tryPutMVar#, readMVar#, tryReadMVar#, reallyUnsafePtrEquality#, isEmptyMVar#)++import Data.Primitive.Unlifted.Type++newtype UnliftedMVar# s (a :: UnliftedType) = UnliftedMVar# (MVar# s a) type role UnliftedMVar# nominal representational  newUnliftedMVar# :: State# s -> (# State# s, UnliftedMVar# s a #)@@ -30,41 +33,39 @@   (# s', mv #) -> (# s', UnliftedMVar# mv #)  takeUnliftedMVar# :: UnliftedMVar# s a -> State# s -> (# State# s, a #)-{-# NOINLINE takeUnliftedMVar# #-}-takeUnliftedMVar# (UnliftedMVar# mv) s = unsafeCoerce# (takeMVar# mv s)+{-# INLINE takeUnliftedMVar# #-}+takeUnliftedMVar# (UnliftedMVar# mv) s = takeMVar# mv s  tryTakeUnliftedMVar# :: UnliftedMVar# s a -> State# s -> (# State# s, (# (##) | a #) #)-{-# NOINLINE tryTakeUnliftedMVar# #-}+{-# INLINE tryTakeUnliftedMVar# #-} tryTakeUnliftedMVar# (UnliftedMVar# mv) s =-  case unsafeCoerce# (tryTakeMVar# mv s) of+  case tryTakeMVar# mv s of     (# s', 0#, _ #) -> (# s', (#(##)| #)#)     (# s', _, a #) -> (# s', (#|a #) #)  putUnliftedMVar# :: UnliftedMVar# s a -> a -> State# s -> State# s-{-# NOINLINE putUnliftedMVar# #-}-putUnliftedMVar# (UnliftedMVar# mv) a s-  = putMVar# mv (unsafeCoerce# a) s+{-# INLINE putUnliftedMVar# #-}+putUnliftedMVar# (UnliftedMVar# mv) a s = putMVar# mv a s  tryPutUnliftedMVar# :: UnliftedMVar# s a -> a -> State# s -> (# State# s, Int# #)-{-# NOINLINE tryPutUnliftedMVar# #-}-tryPutUnliftedMVar# (UnliftedMVar# mv) a s-  = tryPutMVar# mv (unsafeCoerce# a) s+{-# INLINE tryPutUnliftedMVar# #-}+tryPutUnliftedMVar# (UnliftedMVar# mv) a s = tryPutMVar# mv a s  readUnliftedMVar# :: UnliftedMVar# s a -> State# s -> (# State# s, a #)-{-# NOINLINE readUnliftedMVar# #-}-readUnliftedMVar# (UnliftedMVar# mv) s = unsafeCoerce# (readMVar# mv s)+{-# INLINE readUnliftedMVar# #-}+readUnliftedMVar# (UnliftedMVar# mv) s = readMVar# mv s  tryReadUnliftedMVar# :: UnliftedMVar# s a -> State# s -> (# State# s, (# (##) | a #) #)-{-# NOINLINE tryReadUnliftedMVar# #-}+{-# INLINE tryReadUnliftedMVar# #-} tryReadUnliftedMVar# (UnliftedMVar# mv) s =-  case unsafeCoerce# (tryReadMVar# mv s) of+  case tryReadMVar# mv s of     (# s', 0#, _ #) -> (# s', (#(##)| #)#)     (# s', _, a #) -> (# s', (#|a #) #)  sameUnliftedMVar# :: UnliftedMVar# s a -> UnliftedMVar# s a -> Int# {-# INLINE sameUnliftedMVar# #-} sameUnliftedMVar# (UnliftedMVar# mv1) (UnliftedMVar# mv2)-  = sameMVar# mv1 mv2+  = reallyUnsafePtrEquality# mv1 mv2  isEmptyUnliftedMVar# :: UnliftedMVar# s a -> State# s -> (# State# s, Int# #) {-# INLINE isEmptyUnliftedMVar# #-}
src/Data/Primitive/Unlifted/MVar/ST.hs view
@@ -3,6 +3,7 @@ {-# language RoleAnnotations #-} {-# language ScopedTypeVariables #-} {-# language TypeFamilies #-}+{-# language TypeOperators #-} {-# language MagicHash #-} {-# language RankNTypes #-} {-# language PatternSynonyms #-}
src/Data/Primitive/Unlifted/MutVar/Primops.hs view
@@ -4,10 +4,7 @@ {-# language ScopedTypeVariables #-} {-# language RoleAnnotations #-} {-# language KindSignatures #-}---- See UnsafeCoercions.md for an explanation of why we coerce--- things the way we do here, and why some operations are marked--- NOINLINE.+{-# language DataKinds #-}   module Data.Primitive.Unlifted.MutVar.Primops@@ -19,33 +16,35 @@   , casUnliftedMutVar#   , atomicSwapUnliftedMutVar#   ) where-import GHC.Exts +import GHC.Exts (MutVar#, State#, Int#, newMutVar#, readMutVar#, writeMutVar#, reallyUnsafePtrEquality#, casMutVar#)++import Data.Primitive.Unlifted.Type+import Data.Coerce+ -- | An @UnliftedMutVar#@ behaves like a single-element mutable array.-newtype UnliftedMutVar# s (a :: TYPE 'UnliftedRep) = UnliftedMutVar# (MutVar# s Any)+newtype UnliftedMutVar# s (a :: UnliftedType) = UnliftedMutVar# (MutVar# s a) type role UnliftedMutVar# nominal representational  newUnliftedMutVar# :: a -> State# s -> (# State# s, UnliftedMutVar# s a #)-{-# NOINLINE newUnliftedMutVar# #-}-newUnliftedMutVar# a s = case newMutVar# (unsafeCoerce# a) s of-  (# s', mv #) -> (# s', UnliftedMutVar# mv #)+{-# INLINE newUnliftedMutVar# #-}+newUnliftedMutVar# a s = coerce (newMutVar# a s)  readUnliftedMutVar# :: UnliftedMutVar# s a -> State# s -> (# State# s, a #)-{-# NOINLINE readUnliftedMutVar# #-}-readUnliftedMutVar# (UnliftedMutVar# mv) s-  = unsafeCoerce# (readMutVar# mv s)+{-# INLINE readUnliftedMutVar# #-}+readUnliftedMutVar# (UnliftedMutVar# mv) s = readMutVar# mv s  writeUnliftedMutVar# :: UnliftedMutVar# s a -> a -> State# s -> State# s-{-# NOINLINE writeUnliftedMutVar# #-}+{-# INLINE writeUnliftedMutVar# #-} writeUnliftedMutVar# (UnliftedMutVar# mv) a s-  = writeMutVar# mv (unsafeCoerce# a) s+  = writeMutVar# mv a s  -- | Check whether two 'UnliftedMutVar#'es refer to the same mutable -- variable. This is a check on object identity, and not on contents. sameUnliftedMutVar# :: UnliftedMutVar# s a -> UnliftedMutVar# s a -> Int# {-# INLINE sameUnliftedMutVar# #-} sameUnliftedMutVar# (UnliftedMutVar# mv1) (UnliftedMutVar# mv2)-  = sameMutVar# mv1 mv2+  = reallyUnsafePtrEquality# mv1 mv2  -- Note: it's impossible to implement analogues of atomicModifyMutVar2# -- or atomicModifyMutVar_# because those rely on being able to store@@ -63,9 +62,9 @@   -> a -- ^ The expected value   -> a -- ^ The new value to install if the 'UnliftedMutVar# contains the expected value   -> State# s -> (# State# s, Int#, a #)-{-# NOINLINE casUnliftedMutVar# #-}+{-# INLINE casUnliftedMutVar# #-} casUnliftedMutVar# (UnliftedMutVar# mv) old new s-  = unsafeCoerce# (casMutVar# mv (unsafeCoerce# old) (unsafeCoerce# new) s)+  = coerce (casMutVar# mv old new s)  -- | Atomically replace the value in an 'UnliftedMutVar#' with the given one, -- returning the old value.@@ -75,12 +74,12 @@ -- we implement it as a CAS loop. atomicSwapUnliftedMutVar#   :: UnliftedMutVar# s a -> a -> State# s -> (# State# s, a #)-{-# NOINLINE atomicSwapUnliftedMutVar# #-}+{-# INLINE atomicSwapUnliftedMutVar# #-} atomicSwapUnliftedMutVar# (UnliftedMutVar# mv) a s-  = unsafeCoerce# (atomicSwapMutVar# mv (unsafeCoerce# a) s)+  = atomicSwapMutVar# mv a s  atomicSwapMutVar#-  :: MutVar# s a -> a -> State# s -> (# State# s, a #)+  :: forall s (a :: UnliftedType). MutVar# s a -> a -> State# s -> (# State# s, a #) -- We don't bother inlining this because it's kind of slow regardless; -- there doesn't seem to be much point. We don't use the "latest" -- value reported by casUnliftedMutVar# because I'm told chances of
src/Data/Primitive/Unlifted/MutVar/ST.hs view
@@ -3,6 +3,7 @@ {-# language MagicHash #-} {-# language UnboxedTuples #-} {-# language TypeFamilies #-}+{-# language TypeOperators #-}  module Data.Primitive.Unlifted.MutVar.ST   ( UnliftedMutVar_ (..)
src/Data/Primitive/Unlifted/SmallArray/Primops.hs view
@@ -4,11 +4,9 @@ {-# language UnliftedNewtypes #-} {-# language KindSignatures #-} {-# language ScopedTypeVariables #-}-{- OPTIONS_GHC -ddump-simpl #-}---- See UnsafeCoercions.md for an explanation of why we coerce--- things the way we do here, and why some operations are marked--- NOINLINE.+{-# language StandaloneKindSignatures #-}+{-# language DataKinds #-}+{-# language UnliftedDatatypes #-}  -- | -- Primitive types representing unlifted arrays and the@@ -44,19 +42,22 @@   , casSmallUnliftedArray#   ) where -import GHC.Exts (Int#,State#,SmallArray#,SmallMutableArray#,Any,TYPE,RuntimeRep(UnliftedRep),unsafeCoerce#)+import Data.Coerce (coerce)+import GHC.Exts (Int#,State#,SmallArray#,SmallMutableArray#) import qualified GHC.Exts as Exts -newtype SmallUnliftedArray# (a :: TYPE 'UnliftedRep) = SmallUnliftedArray# (SmallArray# Any)+import Data.Primitive.Unlifted.Type+import Unsafe.Coerce (unsafeCoerceUnlifted)++newtype SmallUnliftedArray# (a :: UnliftedType) = SmallUnliftedArray# (SmallArray# a) type role SmallUnliftedArray# representational -newtype SmallMutableUnliftedArray# s (a :: TYPE 'UnliftedRep) = SmallMutableUnliftedArray# (SmallMutableArray# s Any)+newtype SmallMutableUnliftedArray# s (a :: UnliftedType) = SmallMutableUnliftedArray# (SmallMutableArray# s a) type role SmallMutableUnliftedArray# nominal representational  newSmallUnliftedArray# :: forall a s. Int# -> a -> State# s -> (# State# s, SmallMutableUnliftedArray# s a #)-newSmallUnliftedArray# sz a s = case Exts.newSmallArray# sz (unsafeCoerce# a) s of-  (# s', mary #) -> (# s', SmallMutableUnliftedArray# mary #)-{-# NOINLINE newSmallUnliftedArray# #-}+newSmallUnliftedArray# sz a s = coerce (Exts.newSmallArray# sz a s)+{-# INLINE newSmallUnliftedArray# #-}  -- | Create a 'SmallMutableUnliftedArray#' whose entries contain some unspecified -- static value. This may be more convenient than 'newUnliftedArray#' if there@@ -68,10 +69,11 @@ -- can understand and isn't something that might otherwise be released as garbage. -- There's no point trying to stick an `error` in there, because there's no -- code anywhere to force the error thunk.-unsafeNewSmallUnliftedArray# sz s = case Exts.newSmallArray# sz (unsafeCoerce# Nonsense) s of+unsafeNewSmallUnliftedArray# sz s = case Exts.newSmallArray# sz (unsafeCoerceUnlifted Nonsense) s of   (# s', mary #) -> (# s', SmallMutableUnliftedArray# mary #)-{-# NOINLINE unsafeNewSmallUnliftedArray# #-}+{-# INLINE unsafeNewSmallUnliftedArray# #-} +type Nonsense :: UnliftedType data Nonsense = Nonsense  @@ -88,7 +90,7 @@ empty_small_unlifted_array = SULA   (Exts.runRW# $ \s ->     case Exts.noDuplicate# s of { s' ->-    case Exts.newSmallArray# 0# (unsafeCoerce# Nonsense) s' of { (# s'', mary #) ->+    case Exts.newSmallArray# 0# (unsafeCoerceUnlifted Nonsense) s' of { (# s'', mary #) ->     case Exts.unsafeFreezeSmallArray# mary s'' of { (# _, ary #) ->       SmallUnliftedArray# ary }}}) {-# NOINLINE empty_small_unlifted_array #-}@@ -111,7 +113,7 @@  sameSmallMutableUnliftedArray# :: SmallMutableUnliftedArray# s a -> SmallMutableUnliftedArray# s a -> Int# sameSmallMutableUnliftedArray# (SmallMutableUnliftedArray# ar1) (SmallMutableUnliftedArray# ar2)-  = Exts.sameSmallMutableArray# ar1 ar2+  = Exts.reallyUnsafePtrEquality# ar1 ar2 {-# INLINE sameSmallMutableUnliftedArray# #-}  shrinkSmallMutableUnliftedArray# :: SmallMutableUnliftedArray# s a -> Int# -> State# s -> State# s@@ -121,13 +123,13 @@  readSmallUnliftedArray# :: SmallMutableUnliftedArray# s a -> Int# -> State# s -> (# State# s, a #) readSmallUnliftedArray# (SmallMutableUnliftedArray# mary) i s-  = unsafeCoerce# (Exts.readSmallArray# mary i s)-{-# NOINLINE readSmallUnliftedArray# #-}+  = Exts.readSmallArray# mary i s+{-# INLINE readSmallUnliftedArray# #-}  writeSmallUnliftedArray# :: SmallMutableUnliftedArray# s a -> Int# -> a -> State# s -> State# s writeSmallUnliftedArray# (SmallMutableUnliftedArray# mary) i a s-  = Exts.writeSmallArray# mary i (unsafeCoerce# a) s-{-# NOINLINE writeSmallUnliftedArray# #-}+  = Exts.writeSmallArray# mary i a s+{-# INLINE writeSmallUnliftedArray# #-}  sizeofSmallUnliftedArray# :: SmallUnliftedArray# a -> Int# sizeofSmallUnliftedArray# (SmallUnliftedArray# ary) = Exts.sizeofSmallArray# ary@@ -148,19 +150,18 @@  indexSmallUnliftedArray# :: SmallUnliftedArray# a -> Int# -> a indexSmallUnliftedArray# (SmallUnliftedArray# ary) i-  = unsafeCoerce# (Exts.indexSmallArray# ary i)-{-# NOINLINE indexSmallUnliftedArray# #-}+  | (# a #) <- Exts.indexSmallArray# ary i+  = a+{-# INLINE indexSmallUnliftedArray# #-}  unsafeFreezeSmallUnliftedArray# :: SmallMutableUnliftedArray# s a -> State# s -> (# State# s, SmallUnliftedArray# a #) unsafeFreezeSmallUnliftedArray# (SmallMutableUnliftedArray# mary) s-  = case Exts.unsafeFreezeSmallArray# mary s of-      (# s', ary #) -> (# s', SmallUnliftedArray# ary #)+  = coerce (Exts.unsafeFreezeSmallArray# mary s) {-# INLINE unsafeFreezeSmallUnliftedArray# #-}  unsafeThawSmallUnliftedArray# :: SmallUnliftedArray# a -> State# s -> (# State# s, SmallMutableUnliftedArray# s a #) unsafeThawSmallUnliftedArray# (SmallUnliftedArray# ary) s-  = case Exts.unsafeThawSmallArray# ary s of-     (# s', mary #) -> (# s', SmallMutableUnliftedArray# mary #)+  = coerce (Exts.unsafeThawSmallArray# ary s) {-# INLINE unsafeThawSmallUnliftedArray# #-}  copySmallUnliftedArray# :: SmallUnliftedArray# a -> Int# -> SmallMutableUnliftedArray# s a -> Int# -> Int# -> State# s -> State# s@@ -181,23 +182,20 @@ cloneSmallMutableUnliftedArray# :: SmallMutableUnliftedArray# s a -> Int# -> Int# -> State# s   -> (# State# s, SmallMutableUnliftedArray# s a #) cloneSmallMutableUnliftedArray# (SmallMutableUnliftedArray# mary) i n s-  = case Exts.cloneSmallMutableArray# mary i n s of-      (# s', mary' #) -> (# s', SmallMutableUnliftedArray# mary' #)+  = coerce (Exts.cloneSmallMutableArray# mary i n s) {-# INLINE cloneSmallMutableUnliftedArray# #-}  freezeSmallUnliftedArray# :: SmallMutableUnliftedArray# s a -> Int# -> Int# -> State# s -> (# State# s, SmallUnliftedArray# a #) freezeSmallUnliftedArray# (SmallMutableUnliftedArray# mary) i n s-  = case Exts.freezeSmallArray# mary i n s of-      (# s', ary #) -> (# s', SmallUnliftedArray# ary #)+  = coerce (Exts.freezeSmallArray# mary i n s) {-# INLINE freezeSmallUnliftedArray# #-}  thawSmallUnliftedArray# :: SmallUnliftedArray# a -> Int# -> Int# -> State# s -> (# State# s, SmallMutableUnliftedArray# s a #) thawSmallUnliftedArray# (SmallUnliftedArray# ary) i n s-  = case Exts.thawSmallArray# ary i n s of-      (# s', mary #) -> (# s', SmallMutableUnliftedArray# mary #)+  = coerce (Exts.thawSmallArray# ary i n s) {-# INLINE thawSmallUnliftedArray# #-}  casSmallUnliftedArray# :: SmallMutableUnliftedArray# s a -> Int# -> a -> a -> State# s -> (# State# s, Int#, a #) casSmallUnliftedArray# (SmallMutableUnliftedArray# mary) i x y s-  = unsafeCoerce# (Exts.casSmallArray# mary i (unsafeCoerce# x) (unsafeCoerce# y) s)-{-# NOINLINE casSmallUnliftedArray# #-}+  = Exts.casSmallArray# mary i x y s+{-# INLINE casSmallUnliftedArray# #-}
src/Data/Primitive/Unlifted/SmallArray/ST.hs view
@@ -3,6 +3,7 @@ {-# language RankNTypes #-} {-# language ScopedTypeVariables #-} {-# language TypeFamilies #-}+{-# language TypeOperators #-} {-# language UnboxedTuples #-} {-# language RoleAnnotations #-}
+ src/Data/Primitive/Unlifted/Type.hs view
@@ -0,0 +1,15 @@+{-# language CPP #-}++module Data.Primitive.Unlifted.Type+  ( UnliftedType+  ) where++#if !MIN_VERSION_base(4,16,0)+import GHC.Exts (TYPE, RuntimeRep(UnliftedRep))+#else+import GHC.Exts (UnliftedType)+#endif++#if !MIN_VERSION_base(4,16,0)+type UnliftedType = TYPE 'UnliftedRep+#endif
src/Data/Primitive/Unlifted/Weak.hs view
@@ -1,9 +1,11 @@ {-# language MagicHash #-} {-# language UnboxedTuples #-}-{-# language TypeInType #-}+{-# language DataKinds #-}+{-# language PolyKinds #-} {-# language RoleAnnotations #-} {-# language ScopedTypeVariables #-} {-# language TypeFamilies #-}+{-# language TypeOperators #-}  -- | "System.Mem.Weak" provides weak references from lifted keys to lifted -- values. "Data.IORef", "Control.Concurrent.MVar", and
src/Data/Primitive/Unlifted/Weak/IO.hs view
@@ -1,10 +1,12 @@ {-# language MagicHash #-} {-# language UnboxedTuples #-}-{-# language TypeInType #-}+{-# language DataKinds #-}+{-# language PolyKinds #-} {-# language RoleAnnotations #-} {-# language ScopedTypeVariables #-} {-# language TypeFamilies #-}-{- OPTIONS_GHC -ddump-simpl #-}+{-# language TypeOperators #-}+{-# language DataKinds #-}  -- | A version of "Data.Primitive.Unlifted.Weak" specialized to the 'IO' type. module Data.Primitive.Unlifted.Weak.IO@@ -21,8 +23,8 @@   , addCFinalizerToUnliftedWeak2   , touchUnlifted   ) where-import GHC.Exts ( TYPE, RuntimeRep (UnliftedRep)-                , mkWeak#, mkWeakNoFinalizer# )++import GHC.Exts ( mkWeak#, mkWeakNoFinalizer# ) import Data.Primitive.Unlifted.Class (PrimUnlifted (..)) import Data.Primitive.Unlifted.Weak.Primops import GHC.IO (IO (..))@@ -30,13 +32,15 @@ import GHC.Ptr (Ptr (..), FunPtr (..)) import qualified GHC.Exts as Exts +import Data.Primitive.Unlifted.Type+ -- | A weak pointer from a key (which may be lifted or unlifted) -- to an unlifted value. In @UnliftedWeak_ a unlifted_a@, it is generally -- expected that @unlifted_a ~ 'Unlifted' a@, but enforcing that here -- would lead to unfortunate type roles. See "System.Mem.Weak" for detailed -- information about weak references, including the notes at the end of that -- module.-data UnliftedWeak_ a (unlifted_a :: TYPE 'UnliftedRep) = UnliftedWeak (UnliftedWeak# unlifted_a)+data UnliftedWeak_ a (unlifted_a :: UnliftedType) = UnliftedWeak (UnliftedWeak# unlifted_a) type role UnliftedWeak_ phantom representational  -- | A type synonym for an 'UnliftedWeak_' containing lifted values of
src/Data/Primitive/Unlifted/Weak/Primops.hs view
@@ -1,16 +1,13 @@ {-# language MagicHash #-} {-# language UnboxedTuples #-} {-# language UnboxedSums #-}-{-# language TypeInType #-}+{-# language DataKinds #-}+{-# language PolyKinds #-} {-# language RoleAnnotations #-} {-# language ScopedTypeVariables #-} {-# language TypeFamilies #-} {-# language UnliftedNewtypes #-} --- See UnsafeCoercions.md for an explanation of why we coerce--- things the way we do here, and why some operations are marked--- NOINLINE.- -- | "Primops" for weak references from (lifted or unlifted) values -- to unlifted values. Several of these use a slightly different -- interface than the underlying GHC primops. I have a GHC proposal@@ -29,14 +26,17 @@   , deRefUnliftedWeak#   , finalizeUnliftedWeak#   ) where+import Data.Coerce (coerce) import GHC.Exts-  ( TYPE, RuntimeRep (UnliftedRep), Any, unsafeCoerce#, RealWorld, State#+  ( RealWorld, State#   , Weak#, mkWeak#, mkWeakNoFinalizer#, deRefWeak#, finalizeWeak#, Addr#   , Int#, nullAddr#, addCFinalizerToWeak#) +import Data.Primitive.Unlifted.Type+ -- | A weak pointer from a key (which may be lifted or unlifted) -- to an unlifted value.-newtype UnliftedWeak# (a :: TYPE 'UnliftedRep) = UnliftedWeak# (Weak# Any)+newtype UnliftedWeak# (a :: UnliftedType) = UnliftedWeak# (Weak# a) type role UnliftedWeak# representational  -- The primops in GHC.Prim are "open kinded". They don't care if the@@ -47,43 +47,35 @@ -- from an unlifted value @k@ to some unlifted value @v@. If @k@ is still alive -- then @v@ can be retrieved using @deRefUnliftedWeak#@. mkWeakFromUnliftedToUnlifted#-  :: forall (k :: TYPE 'UnliftedRep) (v :: TYPE 'UnliftedRep) c.+  :: forall (k :: UnliftedType) (v :: UnliftedType) c.      k -> v -> (State# RealWorld -> (# State# RealWorld, c #))   -> State# RealWorld -> (# State# RealWorld, UnliftedWeak# v #)-{-# NOINLINE mkWeakFromUnliftedToUnlifted# #-}-mkWeakFromUnliftedToUnlifted# k v finalizer s =-  case mkWeak# k (unsafeCoerce# v) finalizer s of-    (# s', w #) -> (# s', UnliftedWeak# w #)+{-# INLINE mkWeakFromUnliftedToUnlifted# #-}+mkWeakFromUnliftedToUnlifted# k v finalizer s = coerce (mkWeak# k v finalizer s)  -- | The same as 'mkWeakFromUnliftedToUnlifted#' but without a finalizer. mkWeakFromUnliftedToUnliftedNoFinalizer#-  :: forall (k :: TYPE 'UnliftedRep) (v :: TYPE 'UnliftedRep).+  :: forall (k :: UnliftedType) (v :: UnliftedType).      k -> v -> State# RealWorld -> (# State# RealWorld, UnliftedWeak# v #)-{-# NOINLINE mkWeakFromUnliftedToUnliftedNoFinalizer# #-}-mkWeakFromUnliftedToUnliftedNoFinalizer# k v s =-  case mkWeakNoFinalizer# k (unsafeCoerce# v) s of-    (# s', w #) -> (# s', UnliftedWeak# w #)+{-# INLINE mkWeakFromUnliftedToUnliftedNoFinalizer# #-}+mkWeakFromUnliftedToUnliftedNoFinalizer# k v s = coerce (mkWeakNoFinalizer# k v s)  -- | @mkWeakToUnlifted# k v finalizer s@ creates a weak reference from a lifted -- value @k@ to some unlifted value @v@. If @k@ is still alive then @v@ can be -- retrieved using @deRefUnliftedWeak#@. mkWeakToUnlifted#-  :: forall k (v :: TYPE 'UnliftedRep) c.+  :: forall k (v :: UnliftedType) c.      k -> v -> (State# RealWorld -> (# State# RealWorld, c #))   -> State# RealWorld -> (# State# RealWorld, UnliftedWeak# v #)-{-# NOINLINE mkWeakToUnlifted# #-}-mkWeakToUnlifted# k v finalizer s =-  case mkWeak# k (unsafeCoerce# v) finalizer s of-    (# s', w #) -> (# s', UnliftedWeak# w #)+{-# INLINE mkWeakToUnlifted# #-}+mkWeakToUnlifted# k v finalizer s = coerce (mkWeak# k v finalizer s)  -- | The same as 'mkWeakToUnlifted#' but without a finalizer. mkWeakToUnliftedNoFinalizer#-  :: forall k (v :: TYPE 'UnliftedRep).+  :: forall k (v :: UnliftedType).      k -> v -> State# RealWorld -> (# State# RealWorld, UnliftedWeak# v #)-{-# NOINLINE mkWeakToUnliftedNoFinalizer# #-}-mkWeakToUnliftedNoFinalizer# k v s =-  case mkWeakNoFinalizer# k (unsafeCoerce# v) s of-    (# s', w #) -> (# s', UnliftedWeak# w #)+{-# INLINE mkWeakToUnliftedNoFinalizer# #-}+mkWeakToUnliftedNoFinalizer# k v s = coerce (mkWeakNoFinalizer# k v s)  -- | @addCFinalizerToUnliftedWeak1# fptr ptr w@ attaches a C function pointer -- @fptr@ to a weak pointer @w@ as a finalizer. @ptr@ is an argument to be@@ -112,9 +104,9 @@   :: UnliftedWeak# v   -> State# RealWorld   -> (# State# RealWorld, (# (##) | v #) #)-{-# NOINLINE deRefUnliftedWeak# #-}+{-# INLINE deRefUnliftedWeak# #-} deRefUnliftedWeak# (UnliftedWeak# w) s =-  case unsafeCoerce# (deRefWeak# w s) of+  case deRefWeak# w s of     (# s', flag, p #) -> case flag of                            0# -> (# s', (# (##) | #) #)                            _  -> (# s', (# | p #) #)