diff --git a/primitive-checked.cabal b/primitive-checked.cabal --- a/primitive-checked.cabal +++ b/primitive-checked.cabal @@ -1,13 +1,13 @@ -cabal-version: 2.0 +cabal-version: 2.2 name: primitive-checked -version: 0.6.4.2 +version: 0.7.0.0 synopsis: primitive functions with bounds-checking homepage: https://github.com/andrewthad/primitive-checked#readme bug-reports: https://github.com/andrewthad/primitive-checked/issues author: Andrew Martin maintainer: andrew.thaddeus@gmail.com copyright: 2018 Andrew Martin -license: BSD3 +license: BSD-3-Clause license-file: LICENSE build-type: Simple category: Array @@ -41,21 +41,20 @@ src build-depends: base >=4.9.1.0 && <5 - , primitive == 0.6.4.* + , primitive == 0.7.0.* exposed-modules: Data.Primitive Data.Primitive.Array Data.Primitive.SmallArray Data.Primitive.ByteArray Data.Primitive.PrimArray - Data.Primitive.UnliftedArray reexported-modules: Control.Monad.Primitive - , Data.Primitive.Addr , Data.Primitive.MachDeps , Data.Primitive.MutVar , Data.Primitive.MVar , Data.Primitive.Ptr , Data.Primitive.Types default-language: Haskell2010 + ghc-options: -Wall diff --git a/src/Data/Primitive.hs b/src/Data/Primitive.hs --- a/src/Data/Primitive.hs +++ b/src/Data/Primitive.hs @@ -2,18 +2,14 @@ module Data.Primitive.Types, module Data.Primitive.Array, module Data.Primitive.ByteArray, - module Data.Primitive.Addr, module Data.Primitive.PrimArray, module Data.Primitive.SmallArray, - module Data.Primitive.UnliftedArray, module Data.Primitive.MutVar ) where -import Data.Primitive.Addr import Data.Primitive.Array import Data.Primitive.ByteArray import Data.Primitive.MutVar import Data.Primitive.PrimArray import Data.Primitive.SmallArray import Data.Primitive.Types -import Data.Primitive.UnliftedArray diff --git a/src/Data/Primitive/ByteArray.hs b/src/Data/Primitive/ByteArray.hs --- a/src/Data/Primitive/ByteArray.hs +++ b/src/Data/Primitive/ByteArray.hs @@ -29,6 +29,7 @@ , moveByteArray , setByteArray , fillByteArray + , A.copyMutableByteArrayToAddr -- * Information , A.sizeofByteArray , A.sizeofMutableByteArray @@ -56,19 +57,14 @@ elementSizeofByteArray :: forall a. Prim a => Proxy a -> ByteArray -> Int elementSizeofByteArray _ arr = div (A.sizeofByteArray arr) (sizeOf (undefined :: a)) -elementSizeofByteArrayPermissive :: forall a. Prim a => Proxy a -> ByteArray -> Int -elementSizeofByteArrayPermissive _ arr = - div (A.sizeofByteArray arr) (sizeOf (undefined :: a)) + - ( if rem (A.sizeofByteArray arr) (sizeOf (undefined :: a)) == 0 - then 0 - else 1 - ) - elementSizeofMutableByteArray :: forall s a. Prim a => Proxy a -> MutableByteArray s -> Int elementSizeofMutableByteArray _ arr = div (A.sizeofMutableByteArray arr) (sizeOf (undefined :: a)) newByteArray :: (HasCallStack, PrimMonad m) => Int -> m (MutableByteArray (PrimState m)) -newByteArray n = check "newByteArray: negative size" (n>=0) (A.newByteArray n) +newByteArray n = + check "newByteArray: negative size" (n>=0) + $ check ("newByteArray: reqeusted " ++ show n ++ " bytes") (n<1024*1024*1024) + $ (A.newByteArray n) newPinnedByteArray :: (HasCallStack, PrimMonad m) => Int -> m (MutableByteArray (PrimState m)) newPinnedByteArray n = check "newPinnedByteArray: negative size" (n>=0) (A.newPinnedByteArray n) @@ -94,7 +90,7 @@ -- the last machine word of the byte array. indexByteArray :: forall a. (HasCallStack, Prim a) => ByteArray -> Int -> a indexByteArray arr i = check "indexByteArray: index of out bounds" - (i>=0 && i< elementSizeofByteArrayPermissive (Proxy :: Proxy a) arr) + (i>=0 && i< elementSizeofByteArray (Proxy :: Proxy a) arr) (A.indexByteArray arr i) copyByteArray :: forall m. (HasCallStack, PrimMonad m) @@ -153,8 +149,8 @@ -> Int -- ^ number of values to fill -> a -- ^ value to fill with -> m () -setByteArray dst doff sz x = - check "copyMutableByteArray: index range of out bounds" +setByteArray dst doff sz x = + check "setByteArray: index range of out bounds" (doff>=0 && (doff+sz)<=elementSizeofMutableByteArray (Proxy :: Proxy a) dst) (A.setByteArray dst doff sz x) diff --git a/src/Data/Primitive/PrimArray.hs b/src/Data/Primitive/PrimArray.hs --- a/src/Data/Primitive/PrimArray.hs +++ b/src/Data/Primitive/PrimArray.hs @@ -87,7 +87,12 @@ check errMsg False _ = throw (IndexOutOfBounds $ "Data.Primitive.PrimArray." ++ errMsg ++ "\n" ++ prettyCallStack callStack) 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) +newPrimArray n = + check "newPrimArray: negative size" (n>=0) + $ check ("newPrimArray: requested " ++ show n ++ " elements of size " ++ show elemSz) (n * elemSz < 1024*1024*1024) + $ A.newPrimArray n + where + elemSz = sizeOf (undefined :: a) -- | After a call to resizeMutablePrimArray, the original reference to -- the mutable array should not be used again. This cannot truly be enforced @@ -106,7 +111,7 @@ A.setPrimArray (A.MutablePrimArray x) 0 (sz * sizeOf (undefined :: a)) (0xFF :: Word8) return marr' --- | This corrupts the contents of the mutable argument array. +-- | This corrupts the contents of the argument array. unsafeFreezePrimArray :: forall m a. (HasCallStack, PrimMonad m, Prim a) => MutablePrimArray (PrimState m) a -> m (PrimArray a) diff --git a/src/Data/Primitive/SmallArray.hs b/src/Data/Primitive/SmallArray.hs --- a/src/Data/Primitive/SmallArray.hs +++ b/src/Data/Primitive/SmallArray.hs @@ -26,12 +26,15 @@ , A.smallArrayFromListN ) where -import Control.Monad.Primitive (PrimMonad,PrimState) -import Control.Exception (throw, ArrayException(..), Exception, toException) +import "primitive" Data.Primitive (sizeOf) import "primitive" Data.Primitive.SmallArray (SmallArray,SmallMutableArray) -import qualified "primitive" Data.Primitive.SmallArray as A + +import Control.Exception (throw, ArrayException(..), Exception, toException) +import Control.Monad.Primitive (PrimMonad,PrimState) import GHC.Exts (raise#) import GHC.Stack + +import qualified "primitive" Data.Primitive.SmallArray as A import qualified Data.List as L check :: HasCallStack => String -> Bool -> a -> a @@ -46,7 +49,12 @@ throwUnary e = raise# (toException e) newSmallArray :: (HasCallStack, PrimMonad m) => Int -> a -> m (SmallMutableArray (PrimState m) a) -newSmallArray n x = check "newSmallArray: negative size" (n>=0) (A.newSmallArray n x) +newSmallArray n x = + check "newSmallArray: negative size" (n>=0) + $ check ("newSmallArray: requested " ++ show n ++ " elements") (n * ptrSz < 1024*1024*1024) + $ A.newSmallArray n x + where + ptrSz = sizeOf (undefined :: Int) readSmallArray :: (HasCallStack, PrimMonad m) => SmallMutableArray (PrimState m) a -> Int -> m a readSmallArray marr i = do @@ -100,6 +108,8 @@ errorUnsafeFreeze = error "Data.Primitive.Array.Checked.unsafeFreeze:\nAttempted to read from an array after unsafely freezing it." +-- | This installs error thunks in the argument array so that +-- any attempt to use it after an unsafeFreeze will fail. unsafeFreezeSmallArray :: (HasCallStack, PrimMonad m) => SmallMutableArray (PrimState m) a -> m (SmallArray a) diff --git a/src/Data/Primitive/UnliftedArray.hs b/src/Data/Primitive/UnliftedArray.hs deleted file mode 100644 --- a/src/Data/Primitive/UnliftedArray.hs +++ /dev/null @@ -1,162 +0,0 @@ -{-# LANGUAGE PackageImports #-} - -module Data.Primitive.UnliftedArray - ( UnliftedArray(..) - , MutableUnliftedArray(..) - , PrimUnlifted(..) - , unsafeNewUnliftedArray - , newUnliftedArray - , A.setUnliftedArray - , A.sizeofUnliftedArray - , A.sizeofMutableUnliftedArray - , readUnliftedArray - , writeUnliftedArray - , indexUnliftedArray - , indexUnliftedArrayM - , A.unsafeFreezeUnliftedArray - , freezeUnliftedArray - , thawUnliftedArray - , A.sameMutableUnliftedArray - , copyUnliftedArray - , copyMutableUnliftedArray - , cloneUnliftedArray - , cloneMutableUnliftedArray - , A.mapUnliftedArray - , A.foldrUnliftedArray - , A.foldlUnliftedArray - , A.foldrUnliftedArray' - , A.foldlUnliftedArray' - , A.unliftedArrayFromList - ) where - -import Control.Monad.Primitive (PrimMonad,PrimState) -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 -check _ True x = x -check errMsg False _ = throw (IndexOutOfBounds $ "Data.Primitive.UnliftedArray.Checked." ++ errMsg ++ "\n" ++ prettyCallStack callStack) - -newUnliftedArray :: (HasCallStack, PrimMonad m, PrimUnlifted a) => Int -> a -> m (MutableUnliftedArray (PrimState m) a) -newUnliftedArray n x = check "newUnliftedArray: negative size" (n>=0) (A.newUnliftedArray n x) - -unsafeNewUnliftedArray :: (HasCallStack, PrimMonad m) => Int -> m (MutableUnliftedArray (PrimState m) a) -unsafeNewUnliftedArray n = check "unsafeNewUnliftedArray: negative size" (n>=0) (A.unsafeNewUnliftedArray n) - -readUnliftedArray :: (HasCallStack, PrimMonad m, PrimUnlifted a) => MutableUnliftedArray (PrimState m) a -> Int -> m a -readUnliftedArray marr i = do - let siz = A.sizeofMutableUnliftedArray marr - explain = L.concat - [ "[size: " - , show siz - , ", index: " - , show i - , "]" - ] - check ("readUnliftedArray: index of out bounds " ++ explain) (i>=0 && i MutableUnliftedArray (PrimState m) a -> Int -> a -> m () -writeUnliftedArray marr i x = do - let siz = A.sizeofMutableUnliftedArray marr - explain = L.concat - [ "[size: " - , show siz - , ", index: " - , show i - , "]" - ] - check ("writeUnliftedArray: index of out bounds " ++ explain) (i>=0 && i UnliftedArray a -> Int -> a -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 UnliftedArray a -> Int -> m a -indexUnliftedArrayM arr i = check "indexUnliftedArrayM: index of out bounds" - (i>=0 && i MutableUnliftedArray (PrimState m) a -- ^ source - -> Int -- ^ offset - -> Int -- ^ length - -> m (UnliftedArray a) -freezeUnliftedArray marr s l = do - let siz = A.sizeofMutableUnliftedArray marr - check "freezeUnliftedArray: index range of out bounds" - (s>=0 && l>=0 && (s+l)<=siz) - (A.freezeUnliftedArray marr s l) - -thawUnliftedArray - :: (HasCallStack, PrimMonad m) - => UnliftedArray a -- ^ source - -> Int -- ^ offset - -> Int -- ^ length - -> m (MutableUnliftedArray (PrimState m) a) -thawUnliftedArray arr s l = check "thawArr: index range of out bounds" - (s>=0 && l>=0 && (s+l)<=A.sizeofUnliftedArray arr) - (A.thawUnliftedArray arr s l) - -copyUnliftedArray :: (HasCallStack, PrimMonad m) - => MutableUnliftedArray (PrimState m) a -- ^ destination array - -> Int -- ^ offset into destination array - -> UnliftedArray a -- ^ source array - -> Int -- ^ offset into source array - -> Int -- ^ number of elements to copy - -> m () -copyUnliftedArray marr s1 arr s2 l = do - let siz = A.sizeofMutableUnliftedArray marr - check "copyUnliftedArray: index range of out bounds" - (s1>=0 && s2>=0 && l>=0 && (s2+l)<=A.sizeofUnliftedArray arr && (s1+l)<=siz) - (A.copyUnliftedArray marr s1 arr s2 l) - - -copyMutableUnliftedArray :: (HasCallStack, PrimMonad m) - => MutableUnliftedArray (PrimState m) a -- ^ destination array - -> Int -- ^ offset into destination array - -> MutableUnliftedArray (PrimState m) a -- ^ source array - -> Int -- ^ offset into source array - -> Int -- ^ number of elements to copy - -> m () -copyMutableUnliftedArray marr1 s1 marr2 s2 l = do - let siz1 = A.sizeofMutableUnliftedArray marr1 - let siz2 = A.sizeofMutableUnliftedArray marr2 - check "copyMutableUnliftedArray: index range of out bounds" - (s1>=0 && s2>=0 && l>=0 && (s2+l)<=siz2 && (s1+l)<=siz1) - (A.copyMutableUnliftedArray marr1 s1 marr2 s2 l) - - -cloneUnliftedArray :: HasCallStack - => UnliftedArray a -- ^ source array - -> Int -- ^ offset into destination array - -> Int -- ^ number of elements to copy - -> UnliftedArray a -cloneUnliftedArray arr s l = check "cloneUnliftedArray: index range of out bounds" - (s>=0 && l>=0 && (s+l)<=A.sizeofUnliftedArray arr) - (A.cloneUnliftedArray arr s l) - -cloneMutableUnliftedArray :: (HasCallStack, PrimMonad m) - => MutableUnliftedArray (PrimState m) a -- ^ source array - -> Int -- ^ offset into destination array - -> Int -- ^ number of elements to copy - -> m (MutableUnliftedArray (PrimState m) a) -cloneMutableUnliftedArray marr s l = do - let siz = A.sizeofMutableUnliftedArray marr - check "cloneMutableUnliftedArray: index range of out bounds" - (s>=0 && l>=0 && (s+l)<=siz) - (A.cloneMutableUnliftedArray marr s l) -