basement 0.0.4 → 0.0.5

raw patch · 21 files changed

+807/−87 lines, 21 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• Basement/Alg/XorShift.hs +64/−0
• Basement/Bindings/Memory.hs +1/−1
• Basement/Block.hs +37/−6
• Basement/Block/Base.hs +111/−12
• Basement/Block/Mutable.hs +52/−16
• Basement/Compat/C/Types.hs +23/−0
• Basement/Compat/NumLiteral.hs +63/−10
• Basement/Compat/Primitive.hs +2/−1
• Basement/Exception.hs +2/−0
• Basement/NormalForm.hs +1/−1
• Basement/Numerical/Additive.hs +108/−5
• Basement/Numerical/Multiplicative.hs +145/−0
• Basement/Numerical/Number.hs +58/−1
• Basement/Numerical/Subtractive.hs +89/−1
• Basement/PrimType.hs +1/−1
• Basement/Types/OffsetSize.hs +1/−1
• Basement/Types/Ptr.hs +1/−1
• Basement/UArray.hs +33/−11
• Basement/UArray/Base.hs +5/−1
• Basement/UArray/Mutable.hs +5/−17
• basement.cabal +5/−1

@@ -0,0 +1,64 @@+-- |+-- Module      : Foundation.Random.XorShift+-- License     : BSD-style+--+-- XorShift variant: Xoroshiro128++-- <https://en.wikipedia.org/wiki/Xoroshiro128%2B>+--+-- Xoroshiro128+ is a PRNG that uses a shift/rotate-based linear transformation.+-- This is lar+--+-- C implementation at:+-- <http://xoroshiro.di.unimi.it/xoroshiro128plus.c>+--+module Basement.Alg.XorShift+    ( State(..)+    , next+    , nextDouble+    , jump+    ) where++import           Data.Word+import           Data.Bits+import           Basement.Compat.Base+import           Basement.Floating (wordToDouble)+import           Basement.Numerical.Additive+import           Basement.Numerical.Subtractive++-- | State of Xoroshiro128 plus+data State = State {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64++-- | Given a state, call the function 'f' with the generated Word64 and the next State+next :: State -> (Word64 -> State -> a) -> a+next (State s0 s1prev) f = f ran stNext+  where+    !stNext = State s0' s1'+    !ran    = s0 + s1prev+    !s1     = s0 `xor` s1prev+    s0'     = (s0 `rotateL` 55) `xor` s1 `xor` (s1 `unsafeShiftL` 14)+    s1'     = (s1 `rotateL` 36)++-- | Same as 'next' but give a random value of type Double in the range of [0.0 .. 1.0]+nextDouble :: State -> (Double -> State -> a) -> a+nextDouble st f = next st $ \w -> f (toDouble w)+  where+    -- generate a number in the interval [1..2[ by bit manipulation.+    -- this generate double with a ~2^52+    toDouble w = wordToDouble (upperMask .|. (w .&. lowerMask)) - 1.0+      where+        upperMask = 0x3FF0000000000000+        lowerMask = 0x000FFFFFFFFFFFFF++-- | Jump the state by 2^64 calls of next+jump :: State -> State+jump (State s0 s1) = withK 0xd86b048b86aa9922+                   $ withK 0xbeac0467eba5facb+                   $ (State 0 0)+  where+    withK :: Word64 -> State -> State+    withK !k = loop 0+      where+        loop !i st@(State c0 c1)+            | i == 64     = st+            | testBit k i = loop (i+1) (State (c0 `xor` s0) (c1 `xor` s1))+            | otherwise   = st

@@ -7,7 +7,7 @@ import GHC.IO import GHC.Prim import GHC.Word-import Foreign.C.Types+import Basement.Compat.C.Types import Foreign.Ptr import Basement.Types.OffsetSize 

@@ -28,6 +28,8 @@     , thaw     , freeze     , copy+    , unsafeCast+    , cast     -- * safer api     , create     , isPinned@@ -61,6 +63,7 @@     , intersperse     -- * Foreign interfaces     , unsafeCopyToPtr+    , withPtr     ) where  import           GHC.Prim@@ -80,6 +83,7 @@ import           Basement.Block.Base import           Basement.Numerical.Additive import           Basement.Numerical.Subtractive+import           Basement.Numerical.Multiplicative import qualified Basement.Alg.Native.Prim as Prim import qualified Basement.Alg.Mutable as MutAlg import qualified Basement.Alg.Class as Alg@@ -115,12 +119,6 @@         M.iterSet initializer mb         unsafeFreeze mb -isPinned :: Block ty -> PinnedStatus-isPinned (Block ba) = toPinnedStatus# (compatIsByteArrayPinned# ba)--isMutablePinned :: MutableBlock s ty -> PinnedStatus-isMutablePinned (MutableBlock mba) = toPinnedStatus# (compatIsMutableByteArrayPinned# mba)- singleton :: PrimType ty => ty -> Block ty singleton ty = create 1 (const ty) @@ -138,6 +136,10 @@     pure ma {-# INLINE thaw #-} +-- | Freeze a MutableBlock into a Block, copying all the data+--+-- If the data is modified in the mutable block after this call, then+-- the immutable Block resulting is not impacted. freeze :: (PrimType ty, PrimMonad prim) => MutableBlock ty (PrimState prim) -> prim (Block ty) freeze ma = do     ma' <- unsafeNew Unpinned len@@ -394,3 +396,32 @@                 unsafeWrite mb o     (unsafeIndex blk i)                 unsafeWrite mb (o+1) sep                 loop (o+2) (i+1)++-- | Unsafely recast an UArray containing 'a' to an UArray containing 'b'+--+-- The offset and size are converted from units of 'a' to units of 'b',+-- but no check are performed to make sure this is compatible.+--+-- use 'cast' if unsure.+unsafeCast :: PrimType b => Block a -> Block b+unsafeCast (Block ba) = Block ba++-- | Cast a Block of 'a' to a Block of 'b'+--+-- The requirement is that the size of type 'a' need to be a multiple or+-- dividend of the size of type 'b'.+--+-- If this requirement is not met, the InvalidRecast exception is thrown+cast :: forall a b . (PrimType a, PrimType b) => Block a -> Block b+cast blk@(Block ba)+    | aTypeSize == bTypeSize || bTypeSize == 1 = unsafeCast blk+    | missing   == 0                           = unsafeCast blk+    | otherwise                                =+        throw $ InvalidRecast (RecastSourceSize alen) (RecastDestinationSize $ alen + missing)+  where+    (CountOf alen) = lengthBytes blk++    aTypeSize = primSizeInBytes (Proxy :: Proxy a)+    bTypeSize@(CountOf bs) = primSizeInBytes (Proxy :: Proxy b)++    missing = alen `mod` bs

@@ -18,11 +18,17 @@     -- * Properties     , length     , lengthBytes+    , isPinned+    , isMutablePinned+    , mutableLength+    , mutableLengthBytes     -- * Other methods     , mutableEmpty     , new     , newPinned     , withPtr+    , withMutablePtr+    , withMutablePtrHint     , mutableWithPtr     ) where @@ -76,6 +82,15 @@     fromList = internalFromList     toList = internalToList +-- | A Mutable block of memory containing unpacked bytes representing values of type 'ty'+data MutableBlock ty st = MutableBlock (MutableByteArray# st)++isPinned :: Block ty -> PinnedStatus+isPinned (Block ba) = toPinnedStatus# (compatIsByteArrayPinned# ba)++isMutablePinned :: MutableBlock s ty -> PinnedStatus+isMutablePinned (MutableBlock mba) = toPinnedStatus# (compatIsMutableByteArrayPinned# mba)+ length :: forall ty . PrimType ty => Block ty -> CountOf ty length (Block ba) =     case primShiftToBytes (Proxy :: Proxy ty) of@@ -88,6 +103,17 @@ lengthBytes (Block ba) = CountOf (I# (sizeofByteArray# ba)) {-# INLINE[1] lengthBytes #-} +-- | Return the length of a Mutable Block+--+-- note: we don't allow resizing yet, so this can remain a pure function+mutableLength :: forall ty st . PrimType ty => MutableBlock ty st -> CountOf ty+mutableLength mb = sizeRecast $ mutableLengthBytes mb+{-# INLINE[1] mutableLength #-}++mutableLengthBytes :: MutableBlock ty st -> CountOf Word8+mutableLengthBytes (MutableBlock mba) = CountOf (I# (sizeofMutableByteArray# mba))+{-# INLINE[1] mutableLengthBytes #-}+ -- | Create an empty block of memory empty :: Block ty empty = Block ba where !(Block ba) = empty_@@ -226,9 +252,6 @@         doCopy r (i `offsetPlusE` lx) xs       where !lx = lengthBytes x --- | A Mutable block of memory containing unpacked bytes representing values of type 'ty'-data MutableBlock ty st = MutableBlock (MutableByteArray# st)- -- | Freeze a mutable block into a block. -- -- If the mutable block is still use after freeze,@@ -261,10 +284,14 @@     Unpinned -> primitive $ \s1 -> case newByteArray# bytes s1 of { (# s2, mba #) -> (# s2, MutableBlock mba #) }     _        -> primitive $ \s1 -> case newAlignedPinnedByteArray# bytes 8# s1 of { (# s2, mba #) -> (# s2, MutableBlock mba #) } --- | Create a new mutable block of a specific N size of 'ty' elements+-- | Create a new unpinned mutable block of a specific N size of 'ty' elements+--+-- If the size exceeds a GHC-defined threshold, then the memory will be+-- pinned. To be certain about pinning status with small size, use 'newPinned' new :: forall prim ty . (PrimMonad prim, PrimType ty) => CountOf ty -> prim (MutableBlock ty (PrimState prim)) new n = unsafeNew Unpinned (sizeOfE (primSizeInBytes (Proxy :: Proxy ty)) n) +-- | Create a new pinned mutable block of a specific N size of 'ty' elements newPinned :: forall prim ty . (PrimMonad prim, PrimType ty) => CountOf ty -> prim (MutableBlock ty (PrimState prim)) newPinned n = unsafeNew Pinned (sizeOfE (primSizeInBytes (Proxy :: Proxy ty)) n) @@ -337,16 +364,28 @@ unsafeWrite (MutableBlock mba) i v = primMbaWrite mba i v {-# INLINE unsafeWrite #-} --- | Use the 'Ptr' to a block in a safer construct+-- | Get a Ptr pointing to the data in the Block. ----- If the block is not pinned, this is a _dangerous_ operation+-- Since a Block is immutable, this Ptr shouldn't be+-- to use to modify the contents+--+-- If the Block is pinned, then its address is returned as is,+-- however if it's unpinned, a pinned copy of the UArray is made+-- before getting the address. withPtr :: PrimMonad prim         => Block ty         -> (Ptr ty -> prim a)         -> prim a-withPtr x@(Block ba) f = do-    let addr = Ptr (byteArrayContents# ba)-    f addr <* touch x+withPtr x@(Block ba) f+    | isPinned x == Pinned = f (Ptr (byteArrayContents# ba)) <* touch x+    | otherwise            = do+        arr@(Block arrBa) <- makeTrampoline+        f (Ptr (byteArrayContents# arrBa)) <* touch arr+  where+    makeTrampoline = do+        trampoline <- unsafeNew Pinned (lengthBytes x)+        unsafeCopyBytesRO trampoline 0 x 0 (lengthBytes x)+        unsafeFreeze trampoline  touch :: PrimMonad prim => Block ty -> prim () touch (Block ba) =@@ -359,6 +398,66 @@                 => MutableBlock ty (PrimState prim)                 -> (Ptr ty -> prim a)                 -> prim a-mutableWithPtr mb f = do-    b <- unsafeFreeze mb-    withPtr b f+mutableWithPtr = withMutablePtr+{-# DEPRECATED mutableWithPtr "use withMutablePtr" #-}++-- | Create a pointer on the beginning of the MutableBlock+-- and call a function 'f'.+--+-- The mutable block can be mutated by the 'f' function+-- and the change will be reflected in the mutable block+--+-- If the mutable block is unpinned, a trampoline buffer+-- is created and the data is only copied when 'f' return.+--+-- it is all-in-all highly inefficient as this cause 2 copies+withMutablePtr :: PrimMonad prim+               => MutableBlock ty (PrimState prim)+               -> (Ptr ty -> prim a)+               -> prim a+withMutablePtr = withMutablePtrHint False False+++-- | Same as 'withMutablePtr' but allow to specify 2 optimisations+-- which is only useful when the MutableBlock is unpinned and need+-- a pinned trampoline to be called safely.+--+-- If skipCopy is True, then the first copy which happen before+-- the call to 'f', is skipped. The Ptr is now effectively+-- pointing to uninitialized data in a new mutable Block.+--+-- If skipCopyBack is True, then the second copy which happen after+-- the call to 'f', is skipped. Then effectively in the case of a+-- trampoline being used the memory changed by 'f' will not+-- be reflected in the original Mutable Block.+--+-- If using the wrong parameters, it will lead to difficult to+-- debug issue of corrupted buffer which only present themselves+-- with certain Mutable Block that happened to have been allocated+-- unpinned.+--+-- If unsure use 'withMutablePtr', which default to *not* skip+-- any copy.+withMutablePtrHint :: forall ty prim a . PrimMonad prim+                   => Bool -- ^ hint that the buffer doesn't need to have the same value as the mutable block when calling f+                   -> Bool -- ^ hint that the buffer is not supposed to be modified by call of f+                   -> MutableBlock ty (PrimState prim)+                   -> (Ptr ty -> prim a)+                   -> prim a+withMutablePtrHint skipCopy skipCopyBack mb f+    | isMutablePinned mb == Pinned = callWithPtr mb+    | otherwise                    = do+        trampoline <- unsafeNew Pinned vecSz+        if not skipCopy+            then unsafeCopyBytes trampoline 0 mb 0 vecSz+            else pure ()+        r <- callWithPtr trampoline+        if not skipCopyBack+            then unsafeCopyBytes mb 0 trampoline 0 vecSz+            else pure ()+        pure r+  where+    vecSz = mutableLengthBytes mb+    callWithPtr pinnedMb = do+        b@(Block ba) <- unsafeFreeze pinnedMb+        f (Ptr (byteArrayContents# ba)) <* touch b

@@ -38,8 +38,11 @@     ( Block(..)     , MutableBlock(..)     , mutableLengthSize+    , mutableLength     , mutableLengthBytes     , mutableWithPtr+    , withMutablePtr+    , withMutablePtrHint     , new     , newPinned     , mutableEmpty@@ -55,11 +58,15 @@     , unsafeCopyElementsRO     , unsafeCopyBytes     , unsafeCopyBytesRO+    -- * Foreign+    , copyFromPtr+    , copyToPtr     ) where  import           GHC.Prim import           GHC.Types import           Basement.Compat.Base+import           Basement.Compat.Primitive (compatCopyByteArrayToAddr#) import           Data.Proxy import           Basement.Exception import           Basement.Types.OffsetSize@@ -68,20 +75,6 @@ import           Basement.PrimType import           Basement.Block.Base --- | Return the length of a Mutable Block------ note: we don't allow resizing yet, so this can remain a pure function-mutableLengthSize :: forall ty st . PrimType ty => MutableBlock ty st -> CountOf ty-mutableLengthSize (MutableBlock mba) =-    let !(CountOf (I# szBits)) = primSizeInBytes (Proxy :: Proxy ty)-        !elems              = quotInt# (sizeofMutableByteArray# mba) szBits-     in CountOf (I# elems)-{-# INLINE[1] mutableLengthSize #-}--mutableLengthBytes :: MutableBlock ty st -> CountOf Word8-mutableLengthBytes (MutableBlock mba) = CountOf (I# (sizeofMutableByteArray# mba))-{-# INLINE[1] mutableLengthBytes #-}- -- | Set all mutable block element to a value iterSet :: (PrimType ty, PrimMonad prim)         => (Offset ty -> ty)@@ -89,12 +82,16 @@         -> prim () iterSet f ma = loop 0   where-    !sz = mutableLengthSize ma+    !sz = mutableLength ma     loop i         | i .==# sz = pure ()         | otherwise = unsafeWrite ma i (f i) >> loop (i+1)     {-# INLINE loop #-} +mutableLengthSize :: PrimType ty => MutableBlock ty st -> CountOf ty+mutableLengthSize = mutableLength+{-# DEPRECATED mutableLengthSize "use mutableLength" #-}+ -- | read a cell in a mutable array. -- -- If the index is out of bounds, an error is raised.@@ -102,7 +99,7 @@ read array n     | isOutOfBound n len = primOutOfBound OOB_Read n len     | otherwise          = unsafeRead array n-  where len = mutableLengthSize array+  where len = mutableLength array {-# INLINE read #-}  -- | Write to a cell in a mutable array.@@ -115,3 +112,42 @@   where     len = mutableLengthSize array {-# INLINE write #-}++-- | Copy from a pointer, @count@ elements, into the Mutable Block at a starting offset @ofs@+--+-- if the source pointer is invalid (size or bad allocation), bad things will happen+--+copyFromPtr :: forall prim ty . (PrimMonad prim, PrimType ty)+            => Ptr ty                           -- ^ Source Ptr of 'ty' to start of memory+            -> MutableBlock ty (PrimState prim) -- ^ Destination mutable block+            -> Offset ty                        -- ^ Start offset in the destination mutable block+            -> CountOf ty                       -- ^ Number of 'ty' elements+            -> prim ()+copyFromPtr src@(Ptr src#) mb@(MutableBlock mba) ofs count+    | end > sizeAsOffset arrSz = primOutOfBound OOB_MemCopy end arrSz+    | otherwise                = primitive $ \st -> (# copyAddrToByteArray# src# mba od# bytes# st, () #)+  where+    end = od `offsetPlusE` arrSz++    sz = primSizeInBytes (Proxy :: Proxy ty)+    !arrSz@(CountOf (I# bytes#)) = sizeOfE sz count+    !od@(Offset (I# od#)) = offsetOfE sz ofs++-- | Copy all the block content to the memory starting at the destination address+--+-- If the destination pointer is invalid (size or bad allocation), bad things will happen+copyToPtr :: forall ty prim . (PrimType ty, PrimMonad prim)+          => MutableBlock ty (PrimState prim) -- ^ The source mutable block to copy+          -> Offset ty                        -- ^ The source offset in the mutable block+          -> Ptr ty                           -- ^ The destination address where the copy is going to start+          -> CountOf ty                       -- ^ The number of bytes+          -> prim ()+copyToPtr mb@(MutableBlock mba) ofs dst@(Ptr dst#) count+    | srcEnd > sizeAsOffset arrSz = primOutOfBound OOB_MemCopy srcEnd arrSz+    | otherwise                = do+        (Block ba) <- unsafeFreeze mb+        primitive $ \s1 -> (# compatCopyByteArrayToAddr# ba os# dst# szBytes# s1, () #)+  where+    srcEnd = os `offsetPlusE` arrSz+    !os@(Offset (I# os#)) = offsetInBytes ofs+    !arrSz@(CountOf (I# szBytes#)) = mutableLengthBytes mb

@@ -0,0 +1,23 @@+{-# Language CPP #-}+-- |+-- Module      : Basement.Compat.C.Types+-- License     : BSD-style+-- Maintainer  : Foundation+--+-- Literal support for Integral and Fractional+-- {-# LANGUAGE TypeSynonymInstances #-}+-- {-# LANGUAGE FlexibleInstances #-}+module Basement.Compat.C.Types+    ( CChar(..), CSChar(..), CUChar(..)+    , CShort(..), CUShort(..), CInt(..), CUInt(..), CLong(..), CULong(..)+    , CPtrdiff(..), CSize(..), CWchar(..), CSigAtomic(..), CLLong(..), CULLong(..)+#if MIN_VERSION_base(4,10,0)+    , CBool(..)+#endif+    , CIntPtr(..), CUIntPtr(..), CIntMax(..), CUIntMax(..)+    , CClock(..), CTime(..), CUSeconds(..), CSUSeconds(..), CFloat(..), CDouble+    , COff(..), CMode(..)+    ) where++import Foreign.C.Types+import System.Posix.Types

@@ -1,3 +1,4 @@+{-# Language CPP #-} -- | -- Module      : Basement.Compat.NumLiteral -- License     : BSD-style@@ -15,11 +16,10 @@ import           Prelude (Int, Integer, Rational, Float, Double) import           Data.Word (Word8, Word16, Word32, Word64, Word) import           Data.Int (Int8, Int16, Int32, Int64)+import           Basement.Compat.C.Types import qualified Prelude import           Basement.Compat.Natural-import           Foreign.C.Types import           Foreign.Ptr (IntPtr)-import           System.Posix.Types  -- | Integral Literal support --@@ -67,8 +67,18 @@     fromInteger a = Prelude.fromInteger a instance Integral IntPtr where     fromInteger a = Prelude.fromInteger a-instance Integral CSize where++instance Integral Float where     fromInteger a = Prelude.fromInteger a+instance Integral Double where+    fromInteger a = Prelude.fromInteger a++instance Integral CChar where+    fromInteger a = Prelude.fromInteger a+instance Integral CSChar where+    fromInteger a = Prelude.fromInteger a+instance Integral CUChar where+    fromInteger a = Prelude.fromInteger a instance Integral CShort where     fromInteger a = Prelude.fromInteger a instance Integral CUShort where@@ -81,17 +91,40 @@     fromInteger a = Prelude.fromInteger a instance Integral CULong where     fromInteger a = Prelude.fromInteger a-instance Integral COff where+instance Integral CPtrdiff where     fromInteger a = Prelude.fromInteger a-instance Integral CUIntPtr where+instance Integral CSize where     fromInteger a = Prelude.fromInteger a+instance Integral CWchar where+    fromInteger a = Prelude.fromInteger a+instance Integral CSigAtomic where+    fromInteger a = Prelude.fromInteger a+instance Integral CLLong where+    fromInteger a = Prelude.fromInteger a+instance Integral CULLong where+    fromInteger a = Prelude.fromInteger a+#if MIN_VERSION_base(4, 10, 0)+instance Integral CBool where+    fromInteger a = Prelude.fromInteger a+#endif instance Integral CIntPtr where     fromInteger a = Prelude.fromInteger a--instance Integral Float where+instance Integral CUIntPtr where     fromInteger a = Prelude.fromInteger a-instance Integral Double where+instance Integral CIntMax where     fromInteger a = Prelude.fromInteger a+instance Integral CUIntMax where+    fromInteger a = Prelude.fromInteger a+instance Integral CClock where+    fromInteger a = Prelude.fromInteger a+instance Integral CTime where+    fromInteger a = Prelude.fromInteger a+instance Integral CUSeconds where+    fromInteger a = Prelude.fromInteger a+instance Integral CSUSeconds where+    fromInteger a = Prelude.fromInteger a+instance Integral COff where+    fromInteger a = Prelude.fromInteger a instance Integral CFloat where     fromInteger a = Prelude.fromInteger a instance Integral CDouble where@@ -119,12 +152,31 @@     negate = Prelude.negate instance HasNegation Word64 where     negate = Prelude.negate-instance HasNegation CInt where-    negate = Prelude.negate+ instance HasNegation Float where     negate = Prelude.negate instance HasNegation Double where     negate = Prelude.negate++instance HasNegation CChar where+    negate = Prelude.negate+instance HasNegation CSChar where+    negate = Prelude.negate+instance HasNegation CShort where+    negate = Prelude.negate+instance HasNegation CInt where+    negate = Prelude.negate+instance HasNegation CLong where+    negate = Prelude.negate+instance HasNegation CPtrdiff where+    negate = Prelude.negate+instance HasNegation CWchar where+    negate = Prelude.negate+instance HasNegation CLLong where+    negate = Prelude.negate+instance HasNegation CIntMax where+    negate = Prelude.negate+ instance HasNegation CFloat where     negate = Prelude.negate instance HasNegation CDouble where@@ -136,6 +188,7 @@     fromRational a = Prelude.fromRational a instance Fractional Double where     fromRational a = Prelude.fromRational a+ instance Fractional CFloat where     fromRational a = Prelude.fromRational a instance Fractional CDouble where

@@ -26,6 +26,7 @@     ) where  import qualified Prelude+import           GHC.Exts import           GHC.Prim import           GHC.Word #if __GLASGOW_HASKELL__ >= 800@@ -53,7 +54,7 @@ -- Since GHC 7.8, boolean primitive don't return Bool but Int#. #if MIN_VERSION_base(4,7,0) bool# :: Int# -> Prelude.Bool-bool# v = tagToEnum# v+bool# v = isTrue# v #else bool# :: Prelude.Bool -> Prelude.Bool bool# v = v

@@ -29,6 +29,8 @@ -- * OOB_Index: reading an immutable vector -- * OOB_Read: reading a mutable vector -- * OOB_Write: write a mutable vector+-- * OOB_MemCopy: copying a vector+-- * OOB_MemSet: initializing a mutable vector data OutOfBoundOperation = OOB_Read | OOB_Write | OOB_MemSet | OOB_MemCopy | OOB_Index     deriving (Show,Eq,Typeable) 

@@ -5,6 +5,7 @@     ) where  import Basement.Compat.Base+import Basement.Compat.C.Types import Basement.Compat.Natural import Basement.Types.OffsetSize import Basement.Types.Char7@@ -12,7 +13,6 @@ import Basement.Types.Word256 (Word256) import Basement.Bounded import Basement.Endianness-import Foreign.C.Types  -- | Data that can be fully evaluated in Normal Form --

@@ -9,6 +9,7 @@ #include "MachDeps.h"  import           Basement.Compat.Base+import           Basement.Compat.C.Types import           Basement.Compat.Natural import           Basement.Numerical.Number import qualified Prelude@@ -16,7 +17,6 @@ import           GHC.Prim import           GHC.Int import           GHC.Word-import           Foreign.C.Types import           Basement.Bounded import           Basement.Nat import           Basement.Types.Word128 (Word128)@@ -120,16 +120,119 @@     azero = 0.0     (D# a) + (D# b) = D# (a +## b)     scale = scaleNum-instance Additive CSize where-    azero = 0-    (+) = (Prelude.+)-    scale = scaleNum+ instance (KnownNat n, NatWithinBound Word64 n) => Additive (Zn64 n) where     azero = zn64 0     (+) = (Prelude.+)     scale = scaleNum instance KnownNat n => Additive (Zn n) where     azero = zn 0+    (+) = (Prelude.+)+    scale = scaleNum++instance Additive CChar where+    azero = 0+    (+) = (Prelude.+)+    scale = scaleNum+instance Additive CSChar where+    azero = 0+    (+) = (Prelude.+)+    scale = scaleNum+instance Additive CUChar where+    azero = 0+    (+) = (Prelude.+)+    scale = scaleNum+instance Additive CShort where+    azero = 0+    (+) = (Prelude.+)+    scale = scaleNum+instance Additive CUShort where+    azero = 0+    (+) = (Prelude.+)+    scale = scaleNum+instance Additive CInt where+    azero = 0+    (+) = (Prelude.+)+    scale = scaleNum+instance Additive CUInt where+    azero = 0+    (+) = (Prelude.+)+    scale = scaleNum+instance Additive CLong where+    azero = 0+    (+) = (Prelude.+)+    scale = scaleNum+instance Additive CULong where+    azero = 0+    (+) = (Prelude.+)+    scale = scaleNum+instance Additive CPtrdiff where+    azero = 0+    (+) = (Prelude.+)+    scale = scaleNum+instance Additive CSize where+    azero = 0+    (+) = (Prelude.+)+    scale = scaleNum+instance Additive CWchar where+    azero = 0+    (+) = (Prelude.+)+    scale = scaleNum+instance Additive CSigAtomic where+    azero = 0+    (+) = (Prelude.+)+    scale = scaleNum+instance Additive CLLong where+    azero = 0+    (+) = (Prelude.+)+    scale = scaleNum+instance Additive CULLong where+    azero = 0+    (+) = (Prelude.+)+    scale = scaleNum+instance Additive CIntPtr where+    azero = 0+    (+) = (Prelude.+)+    scale = scaleNum+instance Additive CUIntPtr where+    azero = 0+    (+) = (Prelude.+)+    scale = scaleNum+instance Additive CIntMax where+    azero = 0+    (+) = (Prelude.+)+    scale = scaleNum+instance Additive CUIntMax where+    azero = 0+    (+) = (Prelude.+)+    scale = scaleNum+instance Additive CClock where+    azero = 0+    (+) = (Prelude.+)+    scale = scaleNum+instance Additive CTime where+    azero = 0+    (+) = (Prelude.+)+    scale = scaleNum+instance Additive CUSeconds where+    azero = 0+    (+) = (Prelude.+)+    scale = scaleNum+instance Additive CSUSeconds where+    azero = 0+    (+) = (Prelude.+)+    scale = scaleNum+instance Additive COff where+    azero = 0+    (+) = (Prelude.+)+    scale = scaleNum++instance Additive CFloat where+    azero = 0+    (+) = (Prelude.+)+    scale = scaleNum+instance Additive CDouble where+    azero = 0     (+) = (Prelude.+)     scale = scaleNum 

@@ -8,6 +8,7 @@     ) where  import           Basement.Compat.Base+import           Basement.Compat.C.Types import           Basement.Compat.Natural import           Basement.Numerical.Number import           Basement.Numerical.Additive@@ -102,6 +103,7 @@ instance Multiplicative Word256 where     midentity = 1     (*) = (Word256.*)+ instance Multiplicative Prelude.Float where     midentity = 1.0     (*) = (Prelude.*)@@ -112,6 +114,86 @@     midentity = 1.0     (*) = (Prelude.*) +instance Multiplicative CChar where+    midentity = 1+    (*) = (Prelude.*)+instance Multiplicative CSChar where+    midentity = 1+    (*) = (Prelude.*)+instance Multiplicative CUChar where+    midentity = 1+    (*) = (Prelude.*)+instance Multiplicative CShort where+    midentity = 1+    (*) = (Prelude.*)+instance Multiplicative CUShort where+    midentity = 1+    (*) = (Prelude.*)+instance Multiplicative CInt where+    midentity = 1+    (*) = (Prelude.*)+instance Multiplicative CUInt where+    midentity = 1+    (*) = (Prelude.*)+instance Multiplicative CLong where+    midentity = 1+    (*) = (Prelude.*)+instance Multiplicative CULong where+    midentity = 1+    (*) = (Prelude.*)+instance Multiplicative CPtrdiff where+    midentity = 1+    (*) = (Prelude.*)+instance Multiplicative CSize where+    midentity = 1+    (*) = (Prelude.*)+instance Multiplicative CWchar where+    midentity = 1+    (*) = (Prelude.*)+instance Multiplicative CSigAtomic where+    midentity = 1+    (*) = (Prelude.*)+instance Multiplicative CLLong where+    midentity = 1+    (*) = (Prelude.*)+instance Multiplicative CULLong where+    midentity = 1+    (*) = (Prelude.*)+instance Multiplicative CIntPtr where+    midentity = 1+    (*) = (Prelude.*)+instance Multiplicative CUIntPtr where+    midentity = 1+    (*) = (Prelude.*)+instance Multiplicative CIntMax where+    midentity = 1+    (*) = (Prelude.*)+instance Multiplicative CUIntMax where+    midentity = 1+    (*) = (Prelude.*)+instance Multiplicative CClock where+    midentity = 1+    (*) = (Prelude.*)+instance Multiplicative CTime where+    midentity = 1+    (*) = (Prelude.*)+instance Multiplicative CUSeconds where+    midentity = 1+    (*) = (Prelude.*)+instance Multiplicative CSUSeconds where+    midentity = 1+    (*) = (Prelude.*)+instance Multiplicative COff where+    midentity = 1+    (*) = (Prelude.*)++instance Multiplicative CFloat where+    midentity = 1.0+    (*) = (Prelude.*)+instance Multiplicative CDouble where+    midentity = 1.0+    (*) = (Prelude.*)+ instance IDivisible Integer where     div = Prelude.div     mod = Prelude.mod@@ -155,11 +237,74 @@     div = Word256.quot     mod = Word256.rem +instance IDivisible CChar where+    div = Prelude.quot+    mod = Prelude.rem+instance IDivisible CSChar where+    div = Prelude.quot+    mod = Prelude.rem+instance IDivisible CUChar where+    div = Prelude.quot+    mod = Prelude.rem+instance IDivisible CShort where+    div = Prelude.quot+    mod = Prelude.rem+instance IDivisible CUShort where+    div = Prelude.quot+    mod = Prelude.rem+instance IDivisible CInt where+    div = Prelude.quot+    mod = Prelude.rem+instance IDivisible CUInt where+    div = Prelude.quot+    mod = Prelude.rem+instance IDivisible CLong where+    div = Prelude.quot+    mod = Prelude.rem+instance IDivisible CULong where+    div = Prelude.quot+    mod = Prelude.rem+instance IDivisible CPtrdiff where+    div = Prelude.quot+    mod = Prelude.rem+instance IDivisible CSize where+    div = Prelude.quot+    mod = Prelude.rem+instance IDivisible CWchar where+    div = Prelude.quot+    mod = Prelude.rem+instance IDivisible CSigAtomic where+    div = Prelude.quot+    mod = Prelude.rem+instance IDivisible CLLong where+    div = Prelude.quot+    mod = Prelude.rem+instance IDivisible CULLong where+    div = Prelude.quot+    mod = Prelude.rem+instance IDivisible CIntPtr where+    div = Prelude.quot+    mod = Prelude.rem+instance IDivisible CUIntPtr where+    div = Prelude.quot+    mod = Prelude.rem+instance IDivisible CIntMax where+    div = Prelude.quot+    mod = Prelude.rem+instance IDivisible CUIntMax where+    div = Prelude.quot+    mod = Prelude.rem+ instance Divisible Prelude.Rational where     (/) = (Prelude./) instance Divisible Float where     (/) = (Prelude./) instance Divisible Double where+    (/) = (Prelude./)++instance Divisible CFloat where+    (/) = (Prelude./)+instance Divisible CDouble where     (/) = (Prelude./)  recip :: Divisible a => a -> a

@@ -1,13 +1,14 @@+{-# Language CPP #-} module Basement.Numerical.Number     ( IsIntegral(..)     , IsNatural(..)     ) where  import           Basement.Compat.Base+import           Basement.Compat.C.Types import           Basement.Compat.Natural import           Data.Bits import qualified Prelude-import           Foreign.C.Types  -- | Number literals, convertible through the generic Integer type. --@@ -46,8 +47,49 @@     toInteger i = Prelude.toInteger i instance IsIntegral Word64 where     toInteger i = Prelude.toInteger i++instance IsIntegral CChar where+    toInteger i = Prelude.toInteger i+instance IsIntegral CSChar where+    toInteger i = Prelude.toInteger i+instance IsIntegral CUChar where+    toInteger i = Prelude.toInteger i+instance IsIntegral CShort where+    toInteger i = Prelude.toInteger i+instance IsIntegral CUShort where+    toInteger i = Prelude.toInteger i+instance IsIntegral CInt where+    toInteger i = Prelude.toInteger i+instance IsIntegral CUInt where+    toInteger i = Prelude.toInteger i+instance IsIntegral CLong where+    toInteger i = Prelude.toInteger i+instance IsIntegral CULong where+    toInteger i = Prelude.toInteger i+instance IsIntegral CPtrdiff where+    toInteger i = Prelude.toInteger i instance IsIntegral CSize where     toInteger i = Prelude.toInteger i+instance IsIntegral CWchar where+    toInteger i = Prelude.toInteger i+instance IsIntegral CSigAtomic where+    toInteger i = Prelude.toInteger i+instance IsIntegral CLLong where+    toInteger i = Prelude.toInteger i+instance IsIntegral CULLong where+    toInteger i = Prelude.toInteger i+#if MIN_VERSION_base(4,10,0)+instance IsIntegral CBool where+    toInteger i = Prelude.toInteger i+#endif+instance IsIntegral CIntPtr where+    toInteger i = Prelude.toInteger i+instance IsIntegral CUIntPtr where+    toInteger i = Prelude.toInteger i+instance IsIntegral CIntMax where+    toInteger i = Prelude.toInteger i+instance IsIntegral CUIntMax where+    toInteger i = Prelude.toInteger i  instance IsNatural Natural where     toNatural i = i@@ -61,5 +103,20 @@     toNatural i = Prelude.fromIntegral i instance IsNatural Word64 where     toNatural i = Prelude.fromIntegral i++instance IsNatural CUChar where+    toNatural i = Prelude.fromIntegral i+instance IsNatural CUShort where+    toNatural i = Prelude.fromIntegral i+instance IsNatural CUInt where+    toNatural i = Prelude.fromIntegral i+instance IsNatural CULong where+    toNatural i = Prelude.fromIntegral i instance IsNatural CSize where+    toNatural i = Prelude.fromIntegral i+instance IsNatural CULLong where+    toNatural i = Prelude.fromIntegral i+instance IsNatural CUIntPtr where+    toNatural i = Prelude.fromIntegral i+instance IsNatural CUIntMax where     toNatural i = Prelude.fromIntegral i

@@ -1,9 +1,10 @@-{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE CPP, UndecidableInstances #-} module Basement.Numerical.Subtractive     ( Subtractive(..)     ) where  import           Basement.Compat.Base+import           Basement.Compat.C.Types import           Basement.Compat.Natural import           Basement.IntegralConv import           Basement.Bounded@@ -76,12 +77,14 @@ instance Subtractive Word256 where     type Difference Word256 = Word256     (-) = (Word256.-)+ instance Subtractive Prelude.Float where     type Difference Prelude.Float = Prelude.Float     (-) = (Prelude.-) instance Subtractive Prelude.Double where     type Difference Prelude.Double = Prelude.Double     (-) = (Prelude.-)+ instance Subtractive Prelude.Char where     type Difference Prelude.Char = Prelude.Int     (-) a b = (Prelude.-) (charToInt a) (charToInt b)@@ -91,3 +94,88 @@ instance KnownNat n => Subtractive (Zn n) where     type Difference (Zn n) = Zn n     (-) a b = (Prelude.-) a b++instance Subtractive CChar where+    type Difference CChar = CChar+    (-) = (Prelude.-)+instance Subtractive CSChar where+    type Difference CSChar = CSChar+    (-) = (Prelude.-)+instance Subtractive CUChar where+    type Difference CUChar = CUChar+    (-) = (Prelude.-)+instance Subtractive CShort where+    type Difference CShort = CShort+    (-) = (Prelude.-)+instance Subtractive CUShort where+    type Difference CUShort = CUShort+    (-) = (Prelude.-)+instance Subtractive CInt where+    type Difference CInt = CInt+    (-) = (Prelude.-)+instance Subtractive CUInt where+    type Difference CUInt = CUInt+    (-) = (Prelude.-)+instance Subtractive CLong where+    type Difference CLong = CLong+    (-) = (Prelude.-)+instance Subtractive CULong where+    type Difference CULong = CULong+    (-) = (Prelude.-)+instance Subtractive CPtrdiff where+    type Difference CPtrdiff = CPtrdiff+    (-) = (Prelude.-)+instance Subtractive CSize where+    type Difference CSize = CSize+    (-) = (Prelude.-)+instance Subtractive CWchar where+    type Difference CWchar = CWchar+    (-) = (Prelude.-)+instance Subtractive CSigAtomic where+    type Difference CSigAtomic = CSigAtomic+    (-) = (Prelude.-)+instance Subtractive CLLong where+    type Difference CLLong = CLLong+    (-) = (Prelude.-)+instance Subtractive CULLong where+    type Difference CULLong = CULLong+    (-) = (Prelude.-)+#if MIN_VERSION_base(4,10,0)+instance Subtractive CBool where+    type Difference CBool = CBool+    (-) = (Prelude.-)+#endif+instance Subtractive CIntPtr where+    type Difference CIntPtr = CIntPtr+    (-) = (Prelude.-)+instance Subtractive CUIntPtr where+    type Difference CUIntPtr = CUIntPtr+    (-) = (Prelude.-)+instance Subtractive CIntMax where+    type Difference CIntMax = CIntMax+    (-) = (Prelude.-)+instance Subtractive CUIntMax where+    type Difference CUIntMax = CUIntMax+    (-) = (Prelude.-)+instance Subtractive CClock where+    type Difference CClock = CClock+    (-) = (Prelude.-)+instance Subtractive CTime where+    type Difference CTime = CTime+    (-) = (Prelude.-)+instance Subtractive CUSeconds where+    type Difference CUSeconds = CUSeconds+    (-) = (Prelude.-)+instance Subtractive CSUSeconds where+    type Difference CSUSeconds = CSUSeconds+    (-) = (Prelude.-)+instance Subtractive COff where+    type Difference COff = COff+    (-) = (Prelude.-)++instance Subtractive CFloat where+    type Difference CFloat = CFloat+    (-) = (Prelude.-)+instance Subtractive CDouble where+    type Difference CDouble = CDouble+    (-) = (Prelude.-)

@@ -39,9 +39,9 @@ import           GHC.Types import           GHC.Word import           Data.Bits-import           Foreign.C.Types import           Data.Proxy import           Basement.Compat.Base+import           Basement.Compat.C.Types import           Basement.Numerical.Subtractive import           Basement.Types.OffsetSize import           Basement.Types.Char7 (Char7(..))

@@ -51,10 +51,10 @@ import GHC.Word import GHC.Int import GHC.Prim-import Foreign.C.Types import System.Posix.Types (CSsize (..)) import Data.Bits import Basement.Compat.Base+import Basement.Compat.C.Types import Basement.Compat.Semigroup import Data.Proxy import Basement.Numerical.Number

@@ -12,11 +12,11 @@     ) where  import           Basement.Compat.Base+import           Basement.Compat.C.Types import           Basement.Types.OffsetSize import           GHC.Ptr import           GHC.Prim import           GHC.Types-import           Foreign.C.Types  data Addr = Addr Addr#     deriving (Eq,Ord)

@@ -159,6 +159,12 @@            -> UArray ty foreignMem fptr nb = UArray (Offset 0) nb (UArrayAddr fptr) +-- | Create a foreign UArray from foreign memory and given offset/size+--+-- No check are performed to make sure this is valid, so this is unsafe.+--+-- This is particularly useful when dealing with foreign memory and+-- 'ByteString' fromForeignPtr :: PrimType ty                => (ForeignPtr ty, Int, Int) -- ForeignPtr, an offset in prim elements, a size in prim elements                -> UArray ty@@ -188,6 +194,10 @@             | otherwise  = do f v' i r'                               fill (i + 1) r' +-- | Freeze a MUArray into a UArray by copying all the content is a pristine new buffer+--+-- The MUArray in parameter can be still be used after the call without+-- changing the resulting frozen data. freeze :: (PrimType ty, PrimMonad prim) => MUArray ty (PrimState prim) -> prim (UArray ty) freeze ma = do     ma' <- new len@@ -195,8 +205,13 @@     unsafeFreeze ma'   where len = mutableLength ma +-- | Just like 'freeze' but copy only the first n bytes+--+-- The size requested need to be smaller or equal to the length+-- of the MUArray, otherwise a Out of Bounds exception is raised freezeShrink :: (PrimType ty, PrimMonad prim) => MUArray ty (PrimState prim) -> CountOf ty -> prim (UArray ty) freezeShrink ma n = do+    when (n > mutableLength ma) $ primOutOfBound OOB_MemCopy (sizeAsOffset n) (mutableLength ma)     ma' <- new n     copyAt ma' (Offset 0) ma (Offset 0) n     unsafeFreeze ma'@@ -292,21 +307,22 @@     copyBa (Block ba) = primitive $ \s1 -> (# compatCopyByteArrayToAddr# ba os# dst# szBytes# s1, () #)     copyPtr fptr = unsafePrimFromIO $ withFinalPtr fptr $ \ptr -> copyBytes dst (ptr `plusPtr` os) szBytes +-- | Get a Ptr pointing to the data in the UArray.+--+-- Since a UArray is immutable, this Ptr shouldn't be+-- to use to modify the contents+--+-- If the UArray is pinned, then its address is returned as is,+-- however if it's unpinned, a pinned copy of the UArray is made+-- before getting the address. withPtr :: forall ty prim a . (PrimMonad prim, PrimType ty)         => UArray ty         -> (Ptr ty -> prim a)         -> prim a-withPtr a f-    | isPinned a == Pinned =-        onBackendPrim (\blk  -> BLK.withPtr  blk  $ \ptr -> f (ptr `plusPtr` os))-                      (\fptr -> withFinalPtr fptr $ \ptr -> f (ptr `plusPtr` os))-                      a-    | otherwise = do-        arr <- do-            trampoline <- newPinned (length a)-            unsafeCopyAtRO trampoline 0 a 0 (length a)-            unsafeFreeze trampoline-        withPtr arr f+withPtr a f =+    onBackendPrim (\blk  -> BLK.withPtr  blk  $ \ptr -> f (ptr `plusPtr` os))+                  (\fptr -> withFinalPtr fptr $ \ptr -> f (ptr `plusPtr` os))+                  a   where     !sz          = primSizeInBytes (Proxy :: Proxy ty)     !(Offset os) = offsetOfE sz $ offset a@@ -329,6 +345,12 @@     (CountOf alen) = sizeInBytes (length array)     missing = alen `mod` bs +-- | Unsafely recast an UArray containing 'a' to an UArray containing 'b'+--+-- The offset and size are converted from units of 'a' to units of 'b',+-- but no check are performed to make sure this is compatible.+--+-- use 'recast' if unsure. unsafeRecast :: (PrimType a, PrimType b) => UArray a -> UArray b unsafeRecast (UArray start len backend) = UArray (primOffsetRecast start) (sizeRecast len) $     case backend of

@@ -61,6 +61,7 @@ import           Basement.Monad import           Basement.PrimType import           Basement.Compat.Base+import           Basement.Compat.C.Types import           Basement.Compat.Semigroup import qualified Basement.Runtime as Runtime import           Data.Proxy@@ -74,7 +75,6 @@ import qualified Basement.Block.Mutable as MBLK import           Basement.Numerical.Additive import           Basement.Bindings.Memory-import           Foreign.C.Types import           System.IO.Unsafe (unsafeDupablePerformIO)  -- | A Mutable array of types built on top of GHC primitive.@@ -171,6 +171,10 @@ newPinned :: forall prim ty . (PrimMonad prim, PrimType ty) => CountOf ty -> prim (MUArray ty (PrimState prim)) newPinned n = MUArray 0 n . MUArrayMBA <$> MBLK.newPinned n +-- | Create a new unpinned mutable array of size @n elements.+--+-- If the size exceeds a GHC-defined threshold, then the memory will be+-- pinned. To be certain about pinning status with small size, use 'newPinned' newUnpinned :: forall prim ty . (PrimMonad prim, PrimType ty) => CountOf ty -> prim (MUArray ty (PrimState prim)) newUnpinned n = MUArray 0 n . MUArrayMBA <$> MBLK.new n 

@@ -36,6 +36,7 @@     , write     , read     , withMutablePtr+    , withMutablePtrHint     ) where  import           GHC.Prim@@ -119,26 +120,13 @@                    -> MUArray ty (PrimState prim)                    -> (Ptr ty -> prim a)                    -> prim a-withMutablePtrHint _ _ (MUArray start _ (MUArrayAddr fptr))  f =-    withFinalPtr fptr (\ptr -> f (ptr `plusPtr` os))+withMutablePtrHint skipCopy skipCopyBack (MUArray start _ back) f =+    case back of+        MUArrayAddr fptr -> withFinalPtr fptr (\ptr -> f (ptr `plusPtr` os))+        MUArrayMBA mb    -> MBLK.withMutablePtrHint skipCopy skipCopyBack mb $ \ptr -> f (ptr `plusPtr` os)   where     sz           = primSizeInBytes (Proxy :: Proxy ty)     !(Offset os) = offsetOfE sz start-withMutablePtrHint skipCopy skipCopyBack vec@(MUArray start vecSz (MUArrayMBA mb)) f-    | BLK.isMutablePinned mb == Pinned = MBLK.mutableWithPtr mb (\ptr -> f (ptr `plusPtr` os))-    | otherwise                        = do-        trampoline <- newPinned vecSz-        if not skipCopy-            then copyAt trampoline 0 vec 0 vecSz-            else pure ()-        r <- withMutablePtr trampoline f-        if not skipCopyBack-            then copyAt vec 0 trampoline 0 vecSz-            else pure ()-        pure r-  where-    !(Offset os) = offsetOfE sz start-    sz           = primSizeInBytes (Proxy :: Proxy ty)  -- | Create a pointer on the beginning of the mutable array -- and call a function 'f'.

@@ -1,5 +1,5 @@ name:                basement-version:             0.0.4+version:             0.0.5 synopsis:            Foundation scrap box of array & string description:         Foundation most basic primitives without any dependencies homepage:            https://github.com/haskell-foundation/foundation#readme@@ -73,10 +73,14 @@                      Basement.Numerical.Multiplicative                      Basement.Bounded +                     -- exported algorithms+                     Basement.Alg.XorShift+                      -- compat / base redefinition                      Basement.Compat.Base                      Basement.Compat.Bifunctor                      Basement.Compat.CallStack+                     Basement.Compat.C.Types                      Basement.Compat.ExtList                      Basement.Compat.IsList                      Basement.Compat.Identity