primitive-checked 0.6.4.1 → 0.6.4.2

raw patch · 6 files changed

+101/−12 lines, 6 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• primitive-checked.cabal +3/−2
• src/Data/Primitive/Array.hs +19/−1
• src/Data/Primitive/ByteArray.hs +3/−0
• src/Data/Primitive/PrimArray.hs +26/−3
• src/Data/Primitive/SmallArray.hs +21/−1
• src/Data/Primitive/UnliftedArray.hs +29/−5

@@ -1,6 +1,6 @@ cabal-version: 2.0 name: primitive-checked-version: 0.6.4.1+version: 0.6.4.2 synopsis: primitive functions with bounds-checking homepage: https://github.com/andrewthad/primitive-checked#readme bug-reports: https://github.com/andrewthad/primitive-checked/issues@@ -29,7 +29,6 @@   This packages deviates slightly from the PVP in that functions   can be added to the API with only a bump to the fourth digit. - extra-source-files:   README.md @@ -55,6 +54,8 @@     , Data.Primitive.Addr     , Data.Primitive.MachDeps     , Data.Primitive.MutVar+    , Data.Primitive.MVar+    , Data.Primitive.Ptr     , Data.Primitive.Types   default-language: Haskell2010 

@@ -1,3 +1,4 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE PackageImports #-}  module Data.Primitive.Array@@ -10,7 +11,7 @@   , indexArrayM   , freezeArray   , thawArray-  , A.unsafeFreezeArray+  , unsafeFreezeArray   , A.unsafeThawArray   , A.sameMutableArray   , copyArray@@ -54,6 +55,23 @@ indexArrayM arr i = check "indexArrayM: index of out bounds"     (i>=0 && i<A.sizeofArray arr)     (A.indexArrayM arr i)++{-# NOINLINE errorUnsafeFreeze #-}+errorUnsafeFreeze :: a+errorUnsafeFreeze =+  error "Data.Primitive.Array.Checked.unsafeFreeze:\nAttempted to read from an array after unsafely freezing it."++unsafeFreezeArray :: (HasCallStack, PrimMonad m)+  => MutableArray (PrimState m) a+  -> m (Array a)+unsafeFreezeArray marr = do+  let sz = A.sizeofMutableArray marr+  arr <- A.freezeArray marr 0 sz+  let go !ix = if ix < sz+        then A.writeArray marr ix errorUnsafeFreeze >> go (ix + 1)+        else return ()+  go 0+  return arr  freezeArray   :: (HasCallStack, PrimMonad m)

@@ -32,9 +32,12 @@   -- * Information   , A.sizeofByteArray   , A.sizeofMutableByteArray+  , A.getSizeofMutableByteArray   , A.sameMutableByteArray   , A.byteArrayContents   , A.mutableByteArrayContents+  , A.isByteArrayPinned+  , A.isMutableByteArrayPinned   ) where  import Control.Monad.Primitive (PrimMonad,PrimState)

@@ -24,7 +24,7 @@   , writePrimArray   , indexPrimArray     -- * Freezing and Thawing-  , A.unsafeFreezePrimArray+  , unsafeFreezePrimArray   , A.unsafeThawPrimArray     -- * Block Operations   , copyPrimArray@@ -75,7 +75,8 @@  import Control.Monad.Primitive (PrimMonad,PrimState) import Control.Exception (throw, ArrayException(..))-import Data.Primitive.Types (Prim)+import Data.Primitive.Types (Prim,sizeOf)+import Data.Word (Word8) import "primitive" Data.Primitive.PrimArray (PrimArray,MutablePrimArray) import qualified "primitive" Data.Primitive.PrimArray as A import GHC.Stack@@ -88,11 +89,33 @@ newPrimArray :: forall m a. (HasCallStack, PrimMonad m, Prim a) => Int -> m (MutablePrimArray (PrimState m) a) newPrimArray n = check "newPrimArray: negative size" (n>=0) (A.newPrimArray n) +-- | After a call to resizeMutablePrimArray, the original reference to+-- the mutable array should not be used again. This cannot truly be enforced+-- except by linear types. To attempt to enforce this, we always make a+-- copy of the mutable byte array and intentionally corrupt the original+-- of the original one. The strategy used here to corrupt the array is+-- simply to write 1 to every bit. resizeMutablePrimArray :: forall m a. (HasCallStack, PrimMonad m, Prim a)   => MutablePrimArray (PrimState m) a   -> Int -- ^ new size   -> m (MutablePrimArray (PrimState m) a)-resizeMutablePrimArray marr n = check "resizeMutablePrimArray: negative size" (n>=0) (A.resizeMutablePrimArray marr n)+resizeMutablePrimArray marr@(A.MutablePrimArray x) n = check "resizeMutablePrimArray: negative size" (n>=0) $ do+  sz <- A.getSizeofMutablePrimArray marr+  marr' <- A.newPrimArray n+  A.copyMutablePrimArray marr' 0 marr 0 (min sz n)+  A.setPrimArray (A.MutablePrimArray x) 0 (sz * sizeOf (undefined :: a)) (0xFF :: Word8)+  return marr'++-- | This corrupts the contents of the mutable argument array.+unsafeFreezePrimArray :: forall m a. (HasCallStack, PrimMonad m, Prim a)+  => MutablePrimArray (PrimState m) a+  -> m (PrimArray a)+unsafeFreezePrimArray marr@(A.MutablePrimArray x) = do+  sz <- A.getSizeofMutablePrimArray marr+  marr' <- A.newPrimArray sz+  A.copyMutablePrimArray marr' 0 marr 0 sz+  A.setPrimArray (A.MutablePrimArray x) 0 (sz * sizeOf (undefined :: a)) (0xFF :: Word8)+  A.unsafeFreezePrimArray marr'  #if __GLASGOW_HASKELL__ >= 710 shrinkMutablePrimArray :: forall m a. (HasCallStack, PrimMonad m, Prim a)

@@ -1,3 +1,4 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE UnboxedTuples #-}@@ -13,7 +14,7 @@   , indexSmallArrayM   , freezeSmallArray   , thawSmallArray-  , A.unsafeFreezeSmallArray+  , unsafeFreezeSmallArray   , A.unsafeThawSmallArray   , copySmallArray   , copySmallMutableArray@@ -21,6 +22,8 @@   , cloneSmallMutableArray   , A.sizeofSmallArray   , A.sizeofSmallMutableArray+  , A.smallArrayFromList+  , A.smallArrayFromListN   ) where  import Control.Monad.Primitive (PrimMonad,PrimState)@@ -91,6 +94,23 @@ indexSmallArrayM arr i = check "indexSmallArrayM: index of out bounds"     (i>=0 && i<A.sizeofSmallArray arr)     (A.indexSmallArrayM arr i)++{-# NOINLINE errorUnsafeFreeze #-}+errorUnsafeFreeze :: a+errorUnsafeFreeze =+  error "Data.Primitive.Array.Checked.unsafeFreeze:\nAttempted to read from an array after unsafely freezing it."++unsafeFreezeSmallArray :: (HasCallStack, PrimMonad m)+  => SmallMutableArray (PrimState m) a+  -> m (SmallArray a)+unsafeFreezeSmallArray marr = do+  let sz = A.sizeofSmallMutableArray marr+  arr <- A.freezeSmallArray marr 0 sz+  let go !ix = if ix < sz+        then A.writeSmallArray marr ix errorUnsafeFreeze >> go (ix + 1)+        else return ()+  go 0+  return arr  freezeSmallArray   :: (HasCallStack, PrimMonad m)

@@ -33,6 +33,7 @@ import Control.Exception (throw, ArrayException(..)) import "primitive" Data.Primitive.UnliftedArray (UnliftedArray,MutableUnliftedArray,PrimUnlifted) import qualified "primitive" Data.Primitive.UnliftedArray as A+import qualified Data.List as L import GHC.Stack  check :: HasCallStack => String -> Bool -> a -> a@@ -48,17 +49,40 @@ readUnliftedArray :: (HasCallStack, PrimMonad m, PrimUnlifted a) => MutableUnliftedArray (PrimState m) a -> Int -> m a readUnliftedArray marr i = do   let siz = A.sizeofMutableUnliftedArray marr-  check "readUnliftedArray: index of out bounds" (i>=0 && i<siz) (A.readUnliftedArray marr i)+      explain = L.concat+        [ "[size: "+        , show siz+        , ", index: "+        , show i+        , "]"+        ]+  check ("readUnliftedArray: index of out bounds " ++ explain) (i>=0 && i<siz) (A.readUnliftedArray marr i)  writeUnliftedArray :: (HasCallStack, PrimMonad m, PrimUnlifted a) => MutableUnliftedArray (PrimState m) a -> Int -> a -> m () writeUnliftedArray marr i x = do   let siz = A.sizeofMutableUnliftedArray marr-  check "writeUnliftedArray: index of out bounds" (i>=0 && i<siz) (A.writeUnliftedArray marr i x)+      explain = L.concat+        [ "[size: "+        , show siz+        , ", index: "+        , show i+        , "]"+        ]+  check ("writeUnliftedArray: index of out bounds " ++ explain) (i>=0 && i<siz) (A.writeUnliftedArray marr i x)  indexUnliftedArray :: (HasCallStack, PrimUnlifted a) => UnliftedArray a -> Int -> a-indexUnliftedArray arr i = check "indexUnliftedArray: index of out bounds"-  (i>=0 && i<A.sizeofUnliftedArray arr)-  (A.indexUnliftedArray arr i)+indexUnliftedArray arr i =+  let sz = A.sizeofUnliftedArray arr+      explain = L.concat+        [ "[size: "+        , show sz+        , ", index: "+        , show i+        , "]"+        ]+   in check ("indexUnliftedArray: index of out bounds " ++ explain)+        (i>=0 && i<sz)+        (A.indexUnliftedArray arr i)  indexUnliftedArrayM :: (HasCallStack, Monad m, PrimUnlifted a) => UnliftedArray a -> Int -> m a indexUnliftedArrayM arr i = check "indexUnliftedArrayM: index of out bounds"