primitive-0.6.2.0/0000755000000000000000000000000013014454612012053 5ustar0000000000000000primitive-0.6.2.0/primitive.cabal0000644000000000000000000000375013014454612015054 0ustar0000000000000000Name: primitive Version: 0.6.2.0 License: BSD3 License-File: LICENSE Author: Roman Leshchinskiy Maintainer: libraries@haskell.org Copyright: (c) Roman Leshchinskiy 2009-2012 Homepage: https://github.com/haskell/primitive Bug-Reports: https://github.com/haskell/primitive/issues Category: Data Synopsis: Primitive memory-related operations Cabal-Version: >= 1.10 Build-Type: Simple Description: This package provides various primitive memory-related operations. Extra-Source-Files: changelog.md Tested-With: GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1 Library Default-Language: Haskell2010 Other-Extensions: BangPatterns, CPP, DeriveDataTypeable, MagicHash, TypeFamilies, UnboxedTuples, UnliftedFFITypes Exposed-Modules: Control.Monad.Primitive Data.Primitive Data.Primitive.MachDeps Data.Primitive.Types Data.Primitive.Array Data.Primitive.ByteArray Data.Primitive.SmallArray Data.Primitive.UnliftedArray Data.Primitive.Addr Data.Primitive.MutVar Other-Modules: Data.Primitive.Internal.Compat Data.Primitive.Internal.Operations Build-Depends: base >= 4.5 && < 4.10 , ghc-prim >= 0.2 && < 0.6 , transformers >= 0.2 && < 0.6 Ghc-Options: -O2 -Wall Include-Dirs: cbits Install-Includes: primitive-memops.h includes: primitive-memops.h c-sources: cbits/primitive-memops.c cc-options: -O3 -fomit-frame-pointer -Wall if !os(solaris) cc-options: -ftree-vectorize if arch(i386) || arch(x86_64) cc-options: -msse2 test-suite test Default-Language: Haskell2010 hs-source-dirs: test main-is: main.hs type: exitcode-stdio-1.0 build-depends: base , ghc-prim , primitive ghc-options: -O2 source-repository head type: git location: https://github.com/haskell/primitive primitive-0.6.2.0/changelog.md0000644000000000000000000000501513014454612014325 0ustar0000000000000000## Changes in version 0.6.2.0 * Drop support for GHCs before 7.4 * `SmallArray` support * `ArrayArray#` based support for more efficient arrays of unlifted pointer types * Make `Array` and the like instances of various classes for convenient use * Add `Prim` instances for Ptr and FunPtr * Add `ioToPrim`, `stToPrim` and unsafe counterparts for situations that would otherwise require type ascriptions on `primToPrim` * Add `evalPrim` * Add `PrimBase` instance for `IdentityT` ## Changes in version 0.6.1.0 * Use more appropriate types in internal memset functions, which prevents overflows/segfaults on 64-bit systems. * Fixed a warning on GHC 7.10 * Worked around a -dcore-lint bug in GHC 7.6/7.7 ## Changes in version 0.6 * Split PrimMonad into two classes to allow automatic lifting of primitive operations into monad transformers. The `internal` operation has moved to the `PrimBase` class. * Fixed the test suite on older GHCs ## Changes in version 0.5.4.0 * Changed primitive_ to work around an oddity with GHC's code generation on certain versions that led to side effects not happening when used in conjunction with certain very unsafe IO performers. * Allow primitive to build on GHC 7.9 ## Changes in version 0.5.3.0 * Implement `cloneArray` and `cloneMutableArray` primitives (with fall-back implementations for GHCs prior to version 7.2.1) ## Changes in version 0.5.2.1 * Add strict variants of `MutVar` modification functions `atomicModifyMutVar'` and `modifyMutVar'` * Fix compilation on Solaris 10 with GNU C 3.4.3 ## Changes in version 0.5.1.0 * Add support for GHC 7.7's new primitive `Bool` representation ## Changes in version 0.5.0.1 * Disable array copying primitives for GHC 7.6.* and earlier ## Changes in version 0.5 * New in `Data.Primitive.MutVar`: `atomicModifyMutVar` * Efficient block fill operations: `setByteArray`, `setAddr` ## Changes in version 0.4.1 * New module `Data.Primitive.MutVar` ## Changes in version 0.4.0.1 * Critical bug fix in `fillByteArray` ## Changes in version 0.4 * Support for GHC 7.2 array copying primitives * New in `Data.Primitive.ByteArray`: `copyByteArray`, `copyMutableByteArray`, `moveByteArray`, `fillByteArray` * Deprecated in `Data.Primitive.ByteArray`: `memcpyByteArray`, `memcpyByteArray'`, `memmoveByteArray`, `memsetByteArray` * New in `Data.Primitive.Array`: `copyArray`, `copyMutableByteArray` * New in `Data.Primitive.Addr`: `copyAddr`, `moveAddr` * Deprecated in `Data.Primitive.Addr`: `memcpyAddr` primitive-0.6.2.0/LICENSE0000644000000000000000000000301613014454612013060 0ustar0000000000000000Copyright (c) 2008-2009, Roman Leshchinskiy All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - Neither name of the University nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. primitive-0.6.2.0/Setup.hs0000644000000000000000000000005713014454612013511 0ustar0000000000000000import Distribution.Simple main = defaultMain primitive-0.6.2.0/Data/0000755000000000000000000000000013014454612012724 5ustar0000000000000000primitive-0.6.2.0/Data/Primitive.hs0000644000000000000000000000157513014454612015240 0ustar0000000000000000{-# LANGUAGE MagicHash #-} {-# OPTIONS_GHC -fno-warn-duplicate-exports #-} -- | -- Module : Data.Primitive -- Copyright : (c) Roman Leshchinskiy 2009-2012 -- License : BSD-style -- -- Maintainer : Roman Leshchinskiy -- Portability : non-portable -- -- Reexports all primitive operations -- module Data.Primitive ( module Data.Primitive.Types, module Data.Primitive.Array, module Data.Primitive.ByteArray, module Data.Primitive.Addr, sizeOf, alignment ) where import Data.Primitive.Types import Data.Primitive.Array import Data.Primitive.ByteArray import Data.Primitive.Addr import GHC.Base ( Int(..) ) -- | Size of values of type @a@. The argument is not used. sizeOf :: Prim a => a -> Int sizeOf x = I# (sizeOf# x) -- | Alignment of values of type @a@. The argument is not used. alignment :: Prim a => a -> Int alignment x = I# (alignment# x) primitive-0.6.2.0/Data/Primitive/0000755000000000000000000000000013014454612014674 5ustar0000000000000000primitive-0.6.2.0/Data/Primitive/Array.hs0000644000000000000000000004676313014454612016326 0ustar0000000000000000{-# LANGUAGE CPP, MagicHash, UnboxedTuples, DeriveDataTypeable, BangPatterns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} -- | -- Module : Data.Primitive.Array -- Copyright : (c) Roman Leshchinskiy 2009-2012 -- License : BSD-style -- -- Maintainer : Roman Leshchinskiy -- Portability : non-portable -- -- Primitive arrays of boxed values. -- module Data.Primitive.Array ( Array(..), MutableArray(..), newArray, readArray, writeArray, indexArray, indexArrayM, freezeArray, thawArray, unsafeFreezeArray, unsafeThawArray, sameMutableArray, copyArray, copyMutableArray, cloneArray, cloneMutableArray, sizeofArray, sizeofMutableArray, fromListN, fromList ) where import Control.Monad.Primitive import GHC.Base ( Int(..) ) import GHC.Prim import qualified GHC.Exts as Exts #if (MIN_VERSION_base(4,7,0)) import GHC.Exts (fromListN, fromList) #endif import Data.Typeable ( Typeable ) import Data.Data (Data(..), DataType, mkDataType, Constr, mkConstr, Fixity(..), constrIndex) import Data.Primitive.Internal.Compat ( isTrue#, mkNoRepType ) import Control.Monad.ST(ST,runST) import Control.Applicative import Control.Monad (MonadPlus(..)) import Control.Monad.Fix #if MIN_VERSION_base(4,4,0) import Control.Monad.Zip #endif import Data.Foldable (Foldable(..), toList) #if !(MIN_VERSION_base(4,8,0)) import Data.Traversable (Traversable(..)) import Data.Monoid #endif import Text.ParserCombinators.ReadP -- | Boxed arrays data Array a = Array { array# :: Array# a #if (__GLASGOW_HASKELL__ < 702) , sizeofArray :: {-# UNPACK #-} !Int #endif } deriving ( Typeable ) -- | Mutable boxed arrays associated with a primitive state token. data MutableArray s a = MutableArray { marray# :: MutableArray# s a #if (__GLASGOW_HASKELL__ < 702) , sizeofMutableArray :: {-# UNPACK #-} !Int #endif } deriving ( Typeable ) #if (__GLASGOW_HASKELL__ >= 702) sizeofArray :: Array a -> Int sizeofArray a = I# (sizeofArray# (array# a)) {-# INLINE sizeofArray #-} sizeofMutableArray :: MutableArray s a -> Int sizeofMutableArray a = I# (sizeofMutableArray# (marray# a)) {-# INLINE sizeofMutableArray #-} #endif -- | Create a new mutable array of the specified size and initialise all -- elements with the given value. newArray :: PrimMonad m => Int -> a -> m (MutableArray (PrimState m) a) {-# INLINE newArray #-} newArray (I# n#) x = primitive (\s# -> case newArray# n# x s# of (# s'#, arr# #) -> let ma = MutableArray arr# #if (__GLASGOW_HASKELL__ < 702) (I# n#) #endif in (# s'# , ma #)) -- | Read a value from the array at the given index. readArray :: PrimMonad m => MutableArray (PrimState m) a -> Int -> m a {-# INLINE readArray #-} readArray arr (I# i#) = primitive (readArray# (marray# arr) i#) -- | Write a value to the array at the given index. writeArray :: PrimMonad m => MutableArray (PrimState m) a -> Int -> a -> m () {-# INLINE writeArray #-} writeArray arr (I# i#) x = primitive_ (writeArray# (marray# arr) i# x) -- | Read a value from the immutable array at the given index. indexArray :: Array a -> Int -> a {-# INLINE indexArray #-} indexArray arr (I# i#) = case indexArray# (array# arr) i# of (# x #) -> x -- | Monadically read a value from the immutable array at the given index. -- This allows us to be strict in the array while remaining lazy in the read -- element which is very useful for collective operations. Suppose we want to -- copy an array. We could do something like this: -- -- > copy marr arr ... = do ... -- > writeArray marr i (indexArray arr i) ... -- > ... -- -- But since primitive arrays are lazy, the calls to 'indexArray' will not be -- evaluated. Rather, @marr@ will be filled with thunks each of which would -- retain a reference to @arr@. This is definitely not what we want! -- -- With 'indexArrayM', we can instead write -- -- > copy marr arr ... = do ... -- > x <- indexArrayM arr i -- > writeArray marr i x -- > ... -- -- Now, indexing is executed immediately although the returned element is -- still not evaluated. -- indexArrayM :: Monad m => Array a -> Int -> m a {-# INLINE indexArrayM #-} indexArrayM arr (I# i#) = case indexArray# (array# arr) i# of (# x #) -> return x -- | Create an immutable copy of a slice of an array. -- -- This operation makes a copy of the specified section, so it is safe to -- continue using the mutable array afterward. freezeArray :: PrimMonad m => MutableArray (PrimState m) a -- ^ source -> Int -- ^ offset -> Int -- ^ length -> m (Array a) {-# INLINE freezeArray #-} #if (__GLASGOW_HASKELL__ >= 702) freezeArray (MutableArray ma#) (I# off#) (I# len#) = primitive $ \s -> case freezeArray# ma# off# len# s of (# s', a# #) -> (# s', Array a# #) #else freezeArray src off len = do dst <- newArray len (die "freezeArray" "impossible") copyMutableArray dst 0 src off len unsafeFreezeArray dst #endif -- | Convert a mutable array to an immutable one without copying. The -- array should not be modified after the conversion. unsafeFreezeArray :: PrimMonad m => MutableArray (PrimState m) a -> m (Array a) {-# INLINE unsafeFreezeArray #-} unsafeFreezeArray arr = primitive (\s# -> case unsafeFreezeArray# (marray# arr) s# of (# s'#, arr'# #) -> let a = Array arr'# #if (__GLASGOW_HASKELL__ < 702) (sizeofMutableArray arr) #endif in (# s'#, a #)) -- | Create a mutable array from a slice of an immutable array. -- -- This operation makes a copy of the specified slice, so it is safe to use the -- immutable array afterward. thawArray :: PrimMonad m => Array a -- ^ source -> Int -- ^ offset -> Int -- ^ length -> m (MutableArray (PrimState m) a) {-# INLINE thawArray #-} #if (__GLASGOW_HASKELL__ >= 702) thawArray (Array a#) (I# off#) (I# len#) = primitive $ \s -> case thawArray# a# off# len# s of (# s', ma# #) -> (# s', MutableArray ma# #) #else thawArray src off len = do dst <- newArray len (die "thawArray" "impossible") copyArray dst 0 src off len return dst #endif -- | Convert an immutable array to an mutable one without copying. The -- immutable array should not be used after the conversion. unsafeThawArray :: PrimMonad m => Array a -> m (MutableArray (PrimState m) a) {-# INLINE unsafeThawArray #-} unsafeThawArray a = primitive (\s# -> case unsafeThawArray# (array# a) s# of (# s'#, arr'# #) -> let ma = MutableArray arr'# #if (__GLASGOW_HASKELL__ < 702) (sizeofArray a) #endif in (# s'#, ma #)) -- | Check whether the two arrays refer to the same memory block. sameMutableArray :: MutableArray s a -> MutableArray s a -> Bool {-# INLINE sameMutableArray #-} sameMutableArray arr brr = isTrue# (sameMutableArray# (marray# arr) (marray# brr)) -- | Copy a slice of an immutable array to a mutable array. copyArray :: PrimMonad m => MutableArray (PrimState m) a -- ^ destination array -> Int -- ^ offset into destination array -> Array a -- ^ source array -> Int -- ^ offset into source array -> Int -- ^ number of elements to copy -> m () {-# INLINE copyArray #-} #if __GLASGOW_HASKELL__ > 706 -- NOTE: copyArray# and copyMutableArray# are slightly broken in GHC 7.6.* and earlier copyArray (MutableArray dst#) (I# doff#) (Array src#) (I# soff#) (I# len#) = primitive_ (copyArray# src# soff# dst# doff# len#) #else copyArray !dst !doff !src !soff !len = go 0 where go i | i < len = do x <- indexArrayM src (soff+i) writeArray dst (doff+i) x go (i+1) | otherwise = return () #endif -- | Copy a slice of a mutable array to another array. The two arrays may -- not be the same. copyMutableArray :: PrimMonad m => MutableArray (PrimState m) a -- ^ destination array -> Int -- ^ offset into destination array -> MutableArray (PrimState m) a -- ^ source array -> Int -- ^ offset into source array -> Int -- ^ number of elements to copy -> m () {-# INLINE copyMutableArray #-} #if __GLASGOW_HASKELL__ >= 706 -- NOTE: copyArray# and copyMutableArray# are slightly broken in GHC 7.6.* and earlier copyMutableArray (MutableArray dst#) (I# doff#) (MutableArray src#) (I# soff#) (I# len#) = primitive_ (copyMutableArray# src# soff# dst# doff# len#) #else copyMutableArray !dst !doff !src !soff !len = go 0 where go i | i < len = do x <- readArray src (soff+i) writeArray dst (doff+i) x go (i+1) | otherwise = return () #endif -- | Return a newly allocated Array with the specified subrange of the -- provided Array. The provided Array should contain the full subrange -- specified by the two Ints, but this is not checked. cloneArray :: Array a -- ^ source array -> Int -- ^ offset into destination array -> Int -- ^ number of elements to copy -> Array a {-# INLINE cloneArray #-} #if __GLASGOW_HASKELL__ >= 702 cloneArray (Array arr#) (I# off#) (I# len#) = case cloneArray# arr# off# len# of arr'# -> Array arr'# #else cloneArray arr off len = runST $ do marr2 <- newArray len $ die "cloneArray" "impossible" copyArray marr2 0 arr off len unsafeFreezeArray marr2 #endif -- | Return a newly allocated MutableArray. with the specified subrange of -- the provided MutableArray. The provided MutableArray should contain the -- full subrange specified by the two Ints, but this is not checked. cloneMutableArray :: PrimMonad m => MutableArray (PrimState m) a -- ^ source array -> Int -- ^ offset into destination array -> Int -- ^ number of elements to copy -> m (MutableArray (PrimState m) a) {-# INLINE cloneMutableArray #-} #if __GLASGOW_HASKELL__ >= 702 cloneMutableArray (MutableArray arr#) (I# off#) (I# len#) = primitive (\s# -> case cloneMutableArray# arr# off# len# s# of (# s'#, arr'# #) -> (# s'#, MutableArray arr'# #)) #else cloneMutableArray marr off len = do marr2 <- newArray len $ die "cloneMutableArray" "impossible" let go !i !j c | c >= len = return marr2 | otherwise = do b <- readArray marr i writeArray marr2 j b go (i+1) (j+1) (c+1) go off 0 0 #endif emptyArray :: Array a emptyArray = runST $ newArray 0 (die "emptyArray" "impossible") >>= unsafeFreezeArray {-# NOINLINE emptyArray #-} createArray :: Int -> a -> (forall s. MutableArray s a -> ST s ()) -> Array a createArray 0 _ _ = emptyArray createArray n x f = runST $ do ma <- newArray n x f ma unsafeFreezeArray ma die :: String -> String -> a die fun problem = error $ "Data.Primitive.Array." ++ fun ++ ": " ++ problem instance Eq a => Eq (Array a) where a1 == a2 = sizeofArray a1 == sizeofArray a2 && loop (sizeofArray a1 - 1) where loop i | i < 0 = True | otherwise = indexArray a1 i == indexArray a2 i && loop (i-1) instance Eq (MutableArray s a) where ma1 == ma2 = isTrue# (sameMutableArray# (marray# ma1) (marray# ma2)) instance Ord a => Ord (Array a) where compare a1 a2 = loop 0 where mn = sizeofArray a1 `min` sizeofArray a2 loop i | i < mn = compare (indexArray a1 i) (indexArray a2 i) `mappend` loop (i+1) | otherwise = compare (sizeofArray a1) (sizeofArray a2) instance Foldable Array where foldr f z a = go 0 where go i | i < sizeofArray a = f (indexArray a i) (go $ i+1) | otherwise = z {-# INLINE foldr #-} foldl f z a = go (sizeofArray a - 1) where go i | i < 0 = z | otherwise = f (go $ i-1) (indexArray a i) {-# INLINE foldl #-} foldr1 f a | sz < 0 = die "foldr1" "empty array" | otherwise = go 0 where sz = sizeofArray a - 1 z = indexArray a sz go i | i < sz = f (indexArray a i) (go $ i+1) | otherwise = z {-# INLINE foldr1 #-} foldl1 f a | sz == 0 = die "foldl1" "empty array" | otherwise = go $ sz-1 where sz = sizeofArray a z = indexArray a 0 go i | i < 1 = f (go $ i-1) (indexArray a i) | otherwise = z {-# INLINE foldl1 #-} #if MIN_VERSION_base(4,6,0) foldr' f z a = go (sizeofArray a - 1) z where go i !acc | i < 0 = acc | otherwise = go (i-1) (f (indexArray a i) acc) {-# INLINE foldr' #-} foldl' f z a = go 0 z where go i !acc | i < sizeofArray a = go (i+1) (f acc $ indexArray a i) | otherwise = acc {-# INLINE foldl' #-} #endif #if MIN_VERSION_base(4,8,0) toList a = Exts.build $ \c z -> let sz = sizeofArray a go i | i < sz = c (indexArray a i) (go $ i+1) | otherwise = z in go 0 {-# INLINE toList #-} null a = sizeofArray a == 0 {-# INLINE null #-} length = sizeofArray {-# INLINE length #-} maximum a | sz == 0 = die "maximum" "empty array" | otherwise = go 1 (indexArray a 0) where sz = sizeofArray a go i !e | i < sz = go (i+1) (max e $ indexArray a i) | otherwise = e {-# INLINE maximum #-} minimum a | sz == 0 = die "minimum" "empty array" | otherwise = go 1 (indexArray a 0) where sz = sizeofArray a go i !e | i < sz = go (i+1) (min e $ indexArray a i) | otherwise = e {-# INLINE minimum #-} sum = foldl' (+) 0 {-# INLINE sum #-} product = foldl' (*) 1 {-# INLINE product #-} #endif instance Traversable Array where traverse f a = fromListN (sizeofArray a) <$> traverse (f . indexArray a) [0 .. sizeofArray a - 1] #if MIN_VERSION_base(4,7,0) instance Exts.IsList (Array a) where type Item (Array a) = a fromListN n l = createArray n (die "fromListN" "mismatched size and list") $ \mi -> let go i (x:xs) = writeArray mi i x >> go (i+1) xs go _ [ ] = return () in go 0 l fromList l = Exts.fromListN (length l) l toList = toList #else fromListN :: Int -> [a] -> Array a fromListN n l = createArray n (die "fromListN" "mismatched size and list") $ \mi -> let go i (x:xs) = writeArray mi i x >> go (i+1) xs go _ [ ] = return () in go 0 l fromList :: [a] -> Array a fromList l = fromListN (length l) l #endif instance Functor Array where fmap f a = createArray (sizeofArray a) (die "fmap" "impossible") $ \mb -> let go i | i < sizeofArray a = return () | otherwise = writeArray mb i (f $ indexArray a i) >> go (i+1) in go 0 #if MIN_VERSION_base(4,8,0) e <$ a = runST $ newArray (sizeofArray a) e >>= unsafeFreezeArray #endif instance Applicative Array where pure x = runST $ newArray 1 x >>= unsafeFreezeArray ab <*> a = runST $ do mb <- newArray (szab*sza) $ die "<*>" "impossible" let go1 i | i < szab = go2 (i*sza) (indexArray ab i) 0 >> go1 (i+1) | otherwise = return () go2 off f j | j < sza = writeArray mb (off + j) (f $ indexArray a j) | otherwise = return () go1 0 unsafeFreezeArray mb where szab = sizeofArray ab ; sza = sizeofArray a a *> b = createArray (sza*szb) (die "*>" "impossible") $ \mb -> let go i | i < sza = copyArray mb (i * szb) b 0 szb | otherwise = return () in go 0 where sza = sizeofArray a ; szb = sizeofArray b a <* b = createArray (sza*szb) (die "<*" "impossible") $ \ma -> let fill off i e | i < szb = writeArray ma (off+i) e >> fill off (i+1) e | otherwise = return () go i | i < sza = fill (i*szb) 0 (indexArray a i) >> go (i+1) | otherwise = return () in go 0 where sza = sizeofArray a ; szb = sizeofArray b instance Alternative Array where empty = emptyArray a1 <|> a2 = createArray (sza1 + sza2) (die "<|>" "impossible") $ \ma -> copyArray ma 0 a1 0 sza1 >> copyArray ma sza1 a2 0 sza2 where sza1 = sizeofArray a1 ; sza2 = sizeofArray a2 some a | sizeofArray a == 0 = emptyArray | otherwise = die "some" "infinite arrays are not well defined" many a | sizeofArray a == 0 = pure [] | otherwise = die "many" "infinite arrays are not well defined" instance Monad Array where return = pure (>>) = (*>) a >>= f = push 0 [] (sizeofArray a - 1) where push !sz bs i | i < 0 = build sz bs | otherwise = let b = f $ indexArray a i in push (sz + sizeofArray b) (b:bs) (i+1) build sz stk = createArray sz (die ">>=" "impossible") $ \mb -> let go off (b:bs) = copyArray mb off b 0 (sizeofArray b) >> go (off + sizeofArray b) bs go _ [ ] = return () in go 0 stk fail _ = empty instance MonadPlus Array where mzero = empty mplus = (<|>) zipW :: String -> (a -> b -> c) -> Array a -> Array b -> Array c zipW s f aa ab = createArray mn (die s "impossible") $ \mc -> let go i | i < mn = writeArray mc i (f (indexArray aa i) (indexArray ab i)) >> go (i+1) | otherwise = return () in go 0 where mn = sizeofArray aa `min` sizeofArray ab {-# INLINE zipW #-} #if MIN_VERSION_base(4,4,0) instance MonadZip Array where mzip aa ab = zipW "mzip" (,) aa ab mzipWith f aa ab = zipW "mzipWith" f aa ab munzip aab = runST $ do let sz = sizeofArray aab ma <- newArray sz (die "munzip" "impossible") mb <- newArray sz (die "munzip" "impossible") let go i | i < sz = do let (a, b) = indexArray aab i writeArray ma i a writeArray mb i b go (i+1) go _ = return () go 0 (,) <$> unsafeFreezeArray ma <*> unsafeFreezeArray mb #endif instance MonadFix Array where mfix f = let l = mfix (toList . f) in fromListN (length l) l instance Monoid (Array a) where mempty = empty mappend = (<|>) mconcat l = createArray sz (die "mconcat" "impossible") $ \ma -> let go !_ [ ] = return () go off (a:as) = copyArray ma off a 0 (sizeofArray a) >> go (off + sizeofArray a) as in go 0 l where sz = sum . fmap sizeofArray $ l instance Show a => Show (Array a) where showsPrec p a = showParen (p > 10) $ showString "fromListN " . shows (sizeofArray a) . showString " " . shows (toList a) instance Read a => Read (Array a) where readsPrec p = readParen (p > 10) . readP_to_S $ do () <$ string "fromListN" skipSpaces n <- readS_to_P reads skipSpaces l <- readS_to_P reads return $ fromListN n l arrayDataType :: DataType arrayDataType = mkDataType "Data.Primitive.Array.Array" [fromListConstr] fromListConstr :: Constr fromListConstr = mkConstr arrayDataType "fromList" [] Prefix instance Data a => Data (Array a) where toConstr _ = fromListConstr dataTypeOf _ = arrayDataType gunfold k z c = case constrIndex c of 1 -> k (z fromList) _ -> error "gunfold" gfoldl f z m = z fromList `f` toList m instance (Typeable s, Typeable a) => Data (MutableArray s a) where toConstr _ = error "toConstr" gunfold _ _ = error "gunfold" dataTypeOf _ = mkNoRepType "Data.Primitive.Array.MutableArray" primitive-0.6.2.0/Data/Primitive/MutVar.hs0000644000000000000000000000550713014454612016455 0ustar0000000000000000{-# LANGUAGE MagicHash, UnboxedTuples, DeriveDataTypeable #-} -- | -- Module : Data.Primitive.MutVar -- Copyright : (c) Justin Bonnar 2011, Roman Leshchinskiy 2011-2012 -- License : BSD-style -- -- Maintainer : Roman Leshchinskiy -- Portability : non-portable -- -- Primitive boxed mutable variables -- module Data.Primitive.MutVar ( MutVar(..), newMutVar, readMutVar, writeMutVar, atomicModifyMutVar, atomicModifyMutVar', modifyMutVar, modifyMutVar' ) where import Control.Monad.Primitive ( PrimMonad(..), primitive_ ) import GHC.Prim ( MutVar#, sameMutVar#, newMutVar#, readMutVar#, writeMutVar#, atomicModifyMutVar# ) import Data.Primitive.Internal.Compat ( isTrue# ) import Data.Typeable ( Typeable ) -- | A 'MutVar' behaves like a single-element mutable array associated -- with a primitive state token. data MutVar s a = MutVar (MutVar# s a) deriving ( Typeable ) instance Eq (MutVar s a) where MutVar mva# == MutVar mvb# = isTrue# (sameMutVar# mva# mvb#) -- | Create a new 'MutVar' with the specified initial value newMutVar :: PrimMonad m => a -> m (MutVar (PrimState m) a) {-# INLINE newMutVar #-} newMutVar initialValue = primitive $ \s# -> case newMutVar# initialValue s# of (# s'#, mv# #) -> (# s'#, MutVar mv# #) -- | Read the value of a 'MutVar' readMutVar :: PrimMonad m => MutVar (PrimState m) a -> m a {-# INLINE readMutVar #-} readMutVar (MutVar mv#) = primitive (readMutVar# mv#) -- | Write a new value into a 'MutVar' writeMutVar :: PrimMonad m => MutVar (PrimState m) a -> a -> m () {-# INLINE writeMutVar #-} writeMutVar (MutVar mv#) newValue = primitive_ (writeMutVar# mv# newValue) -- | Atomically mutate the contents of a 'MutVar' atomicModifyMutVar :: PrimMonad m => MutVar (PrimState m) a -> (a -> (a,b)) -> m b {-# INLINE atomicModifyMutVar #-} atomicModifyMutVar (MutVar mv#) f = primitive $ atomicModifyMutVar# mv# f -- | Strict version of 'atomicModifyMutVar'. This forces both the value stored -- in the 'MutVar' as well as the value returned. atomicModifyMutVar' :: PrimMonad m => MutVar (PrimState m) a -> (a -> (a, b)) -> m b {-# INLINE atomicModifyMutVar' #-} atomicModifyMutVar' mv f = do b <- atomicModifyMutVar mv force b `seq` return b where force x = let (a, b) = f x in (a, a `seq` b) -- | Mutate the contents of a 'MutVar' modifyMutVar :: PrimMonad m => MutVar (PrimState m) a -> (a -> a) -> m () {-# INLINE modifyMutVar #-} modifyMutVar (MutVar mv#) g = primitive_ $ \s# -> case readMutVar# mv# s# of (# s'#, a #) -> writeMutVar# mv# (g a) s'# -- | Strict version of 'modifyMutVar' modifyMutVar' :: PrimMonad m => MutVar (PrimState m) a -> (a -> a) -> m () {-# INLINE modifyMutVar' #-} modifyMutVar' (MutVar mv#) g = primitive_ $ \s# -> case readMutVar# mv# s# of (# s'#, a #) -> let a' = g a in a' `seq` writeMutVar# mv# a' s'# primitive-0.6.2.0/Data/Primitive/Addr.hs0000644000000000000000000000645113014454612016110 0ustar0000000000000000{-# LANGUAGE MagicHash, UnboxedTuples #-} -- | -- Module : Data.Primitive.Addr -- Copyright : (c) Roman Leshchinskiy 2009-2012 -- License : BSD-style -- -- Maintainer : Roman Leshchinskiy -- Portability : non-portable -- -- Primitive operations on machine addresses -- module Data.Primitive.Addr ( -- * Types Addr(..), -- * Address arithmetic nullAddr, plusAddr, minusAddr, remAddr, -- * Element access indexOffAddr, readOffAddr, writeOffAddr, -- * Block operations copyAddr, moveAddr, setAddr ) where import Control.Monad.Primitive import Data.Primitive.Types import GHC.Base ( Int(..) ) import GHC.Prim import GHC.Ptr import Foreign.Marshal.Utils -- | The null address nullAddr :: Addr nullAddr = Addr nullAddr# infixl 6 `plusAddr`, `minusAddr` infixl 7 `remAddr` -- | Offset an address by the given number of bytes plusAddr :: Addr -> Int -> Addr plusAddr (Addr a#) (I# i#) = Addr (plusAddr# a# i#) -- | Distance in bytes between two addresses. The result is only valid if the -- difference fits in an 'Int'. minusAddr :: Addr -> Addr -> Int minusAddr (Addr a#) (Addr b#) = I# (minusAddr# a# b#) -- | The remainder of the address and the integer. remAddr :: Addr -> Int -> Int remAddr (Addr a#) (I# i#) = I# (remAddr# a# i#) -- | Read a value from a memory position given by an address and an offset. -- The memory block the address refers to must be immutable. The offset is in -- elements of type @a@ rather than in bytes. indexOffAddr :: Prim a => Addr -> Int -> a {-# INLINE indexOffAddr #-} indexOffAddr (Addr addr#) (I# i#) = indexOffAddr# addr# i# -- | Read a value from a memory position given by an address and an offset. -- The offset is in elements of type @a@ rather than in bytes. readOffAddr :: (Prim a, PrimMonad m) => Addr -> Int -> m a {-# INLINE readOffAddr #-} readOffAddr (Addr addr#) (I# i#) = primitive (readOffAddr# addr# i#) -- | Write a value to a memory position given by an address and an offset. -- The offset is in elements of type @a@ rather than in bytes. writeOffAddr :: (Prim a, PrimMonad m) => Addr -> Int -> a -> m () {-# INLINE writeOffAddr #-} writeOffAddr (Addr addr#) (I# i#) x = primitive_ (writeOffAddr# addr# i# x) -- | Copy the given number of bytes from the second 'Addr' to the first. The -- areas may not overlap. copyAddr :: PrimMonad m => Addr -- ^ destination address -> Addr -- ^ source address -> Int -- ^ number of bytes -> m () {-# INLINE copyAddr #-} copyAddr (Addr dst#) (Addr src#) n = unsafePrimToPrim $ copyBytes (Ptr dst#) (Ptr src#) n -- | Copy the given number of bytes from the second 'Addr' to the first. The -- areas may overlap. moveAddr :: PrimMonad m => Addr -- ^ destination address -> Addr -- ^ source address -> Int -- ^ number of bytes -> m () {-# INLINE moveAddr #-} moveAddr (Addr dst#) (Addr src#) n = unsafePrimToPrim $ moveBytes (Ptr dst#) (Ptr src#) n -- | Fill a memory block of with the given value. The length is in -- elements of type @a@ rather than in bytes. setAddr :: (Prim a, PrimMonad m) => Addr -> Int -> a -> m () {-# INLINE setAddr #-} setAddr (Addr addr#) (I# n#) x = primitive_ (setOffAddr# addr# 0# n# x) primitive-0.6.2.0/Data/Primitive/UnliftedArray.hs0000644000000000000000000003225513014454612020010 0ustar0000000000000000{-# Language MagicHash #-} {-# Language UnboxedTuples #-} {-# Language DeriveDataTypeable #-} -- | -- Module : Data.Primitive.UnliftedArray -- Copyright : (c) Dan Doel 2016 -- License : BSD-style -- -- Maintainer : Libraries -- Portability : non-portable -- -- GHC contains three general classes of value types: -- -- 1. Unboxed types: values are machine values made up of fixed numbers of bytes -- 2. Unlifted types: values are pointers, but strictly evaluated -- 3. Lifted types: values are pointers, lazily evaluated -- -- The first category can be stored in a 'ByteArray', and this allows types in -- category 3 that are simple wrappers around category 1 types to be stored -- more efficiently using a 'ByteArray'. This module provides the same facility -- for category 2 types. -- -- GHC has two primitive types, 'ArrayArray#' and 'MutableArrayArray#'. These -- are arrays of pointers, but of category 2 values, so they are known to not -- be bottom. This allows types that are wrappers around such types to be stored -- in an array without an extra level of indirection. -- -- The way that the 'ArrayArray#' API works is that one can read and write -- 'ArrayArray#' values to the positions. This works because all category 2 -- types share a uniform representation, unlike unboxed values which are -- represented by varying (by type) numbers of bytes. However, using the -- this makes the internal API very unsafe to use, as one has to coerce values -- to and from 'ArrayArray#'. -- -- The API presented by this module is more type safe. 'UnliftedArray' and -- 'MutableUnliftedArray' are parameterized by the type of arrays they contain, and -- the coercions necessary are abstracted into a class, 'PrimUnlifted', of things -- that are eligible to be stored. module Data.Primitive.UnliftedArray ( UnliftedArray(..) , MutableUnliftedArray(..) , PrimUnlifted(..) , unsafeNewUnliftedArray , newUnliftedArray , setUnliftedArray , sizeofUnliftedArray , sizeofMutableUnliftedArray , readUnliftedArray , writeUnliftedArray , indexUnliftedArray , indexUnliftedArrayM , unsafeFreezeUnliftedArray , freezeUnliftedArray , thawUnliftedArray , sameMutableUnliftedArray , copyUnliftedArray , copyMutableUnliftedArray , cloneUnliftedArray , cloneMutableUnliftedArray -- Missing operations: -- , unsafeThawUnliftedArray ) where import Data.Typeable import GHC.Prim import GHC.Base (Int(..)) import Control.Monad.Primitive import Control.Monad.ST (runST) import Data.Primitive.Internal.Compat ( isTrue# ) import Data.Primitive.Array (Array) import qualified Data.Primitive.Array as A import Data.Primitive.ByteArray (ByteArray) import qualified Data.Primitive.ByteArray as BA import qualified Data.Primitive.SmallArray as SA import qualified Data.Primitive.MutVar as MV -- | Immutable arrays that efficiently store types that are simple wrappers -- around unlifted primitive types. The values of the unlifted type are -- stored directly, eliminating a layer of indirection. data UnliftedArray e = UnliftedArray ArrayArray# deriving (Typeable) -- | Mutable arrays that efficiently store types that are simple wrappers -- around unlifted primitive types. The values of the unlifted type are -- stored directly, eliminating a layer of indirection. data MutableUnliftedArray s e = MutableUnliftedArray (MutableArrayArray# s) deriving (Typeable) -- | Classifies the types that are able to be stored in 'UnliftedArray' and -- 'MutableUnliftedArray'. These should be types that are just liftings of the -- unlifted pointer types, so that their internal contents can be safely coerced -- into an 'ArrayArray#'. class PrimUnlifted a where toArrayArray# :: a -> ArrayArray# fromArrayArray# :: ArrayArray# -> a instance PrimUnlifted (UnliftedArray e) where toArrayArray# (UnliftedArray aa#) = aa# fromArrayArray# aa# = UnliftedArray aa# instance PrimUnlifted (MutableUnliftedArray s e) where toArrayArray# (MutableUnliftedArray maa#) = unsafeCoerce# maa# fromArrayArray# aa# = MutableUnliftedArray (unsafeCoerce# aa#) instance PrimUnlifted (Array a) where toArrayArray# (A.Array a#) = unsafeCoerce# a# fromArrayArray# aa# = A.Array (unsafeCoerce# aa#) instance PrimUnlifted (A.MutableArray s a) where toArrayArray# (A.MutableArray ma#) = unsafeCoerce# ma# fromArrayArray# aa# = A.MutableArray (unsafeCoerce# aa#) instance PrimUnlifted ByteArray where toArrayArray# (BA.ByteArray ba#) = unsafeCoerce# ba# fromArrayArray# aa# = BA.ByteArray (unsafeCoerce# aa#) instance PrimUnlifted (BA.MutableByteArray s) where toArrayArray# (BA.MutableByteArray mba#) = unsafeCoerce# mba# fromArrayArray# aa# = BA.MutableByteArray (unsafeCoerce# aa#) instance PrimUnlifted (SA.SmallArray a) where toArrayArray# (SA.SmallArray sa#) = unsafeCoerce# sa# fromArrayArray# aa# = SA.SmallArray (unsafeCoerce# aa#) instance PrimUnlifted (SA.SmallMutableArray s a) where toArrayArray# (SA.SmallMutableArray sma#) = unsafeCoerce# sma# fromArrayArray# aa# = SA.SmallMutableArray (unsafeCoerce# aa#) instance PrimUnlifted (MV.MutVar s a) where toArrayArray# (MV.MutVar mv#) = unsafeCoerce# mv# fromArrayArray# aa# = MV.MutVar (unsafeCoerce# aa#) -- | Creates a new 'MutableUnliftedArray'. This function is unsafe, because it -- allows access to the raw contents of the underlying 'ArrayArray#'. unsafeNewUnliftedArray :: (PrimMonad m) => Int -- ^ size -> m (MutableUnliftedArray (PrimState m) a) unsafeNewUnliftedArray (I# i#) = primitive $ \s -> case newArrayArray# i# s of (# s', maa# #) -> (# s', MutableUnliftedArray maa# #) {-# inline unsafeNewUnliftedArray #-} -- | Sets all the positions in an unlifted array to the designated value. setUnliftedArray :: (PrimMonad m, PrimUnlifted a) => MutableUnliftedArray (PrimState m) a -- ^ destination -> a -- ^ value to fill with -> m () setUnliftedArray mua v = loop $ sizeofMutableUnliftedArray mua - 1 where loop i | i < 0 = return () | otherwise = writeUnliftedArray mua i v >> loop (i-1) {-# inline setUnliftedArray #-} -- | Creates a new 'MutableUnliftedArray' with the specified value as initial -- contents. This is slower than 'unsafeNewUnliftedArray', but safer. newUnliftedArray :: (PrimMonad m, PrimUnlifted a) => Int -- ^ size -> a -- ^ initial value -> m (MutableUnliftedArray (PrimState m) a) newUnliftedArray len v = unsafeNewUnliftedArray len >>= \mua -> setUnliftedArray mua v >> return mua {-# inline newUnliftedArray #-} -- | Yields the length of an 'UnliftedArray'. sizeofUnliftedArray :: UnliftedArray e -> Int sizeofUnliftedArray (UnliftedArray aa#) = I# (sizeofArrayArray# aa#) {-# inline sizeofUnliftedArray #-} -- | Yields the length of a 'MutableUnliftedArray'. sizeofMutableUnliftedArray :: MutableUnliftedArray s e -> Int sizeofMutableUnliftedArray (MutableUnliftedArray maa#) = I# (sizeofMutableArrayArray# maa#) {-# inline sizeofMutableUnliftedArray #-} -- Internal indexing function. -- -- Note: ArrayArray# is strictly evaluated, so this should have similar -- consequences to indexArray#, where matching on the unboxed single causes the -- array access to happen. indexUnliftedArrayU :: PrimUnlifted a => UnliftedArray a -> Int -> (# a #) indexUnliftedArrayU (UnliftedArray src#) (I# i#) = case indexArrayArrayArray# src# i# of aa# -> (# fromArrayArray# aa# #) {-# inline indexUnliftedArrayU #-} -- | Gets the value at the specified position of an 'UnliftedArray'. indexUnliftedArray :: PrimUnlifted a => UnliftedArray a -- ^ source -> Int -- ^ index -> a indexUnliftedArray ua i = case indexUnliftedArrayU ua i of (# v #) -> v {-# inline indexUnliftedArray #-} -- | Gets the value at the specified position of an 'UnliftedArray'. -- The purpose of the 'Monad' is to allow for being eager in the -- 'UnliftedArray' value without having to introduce a data dependency -- directly on the result value. -- -- It should be noted that this is not as much of a problem as with a normal -- 'Array', because elements of an 'UnliftedArray' are guaranteed to not -- be exceptional. This function is provided in case it is more desirable -- than being strict in the result value. indexUnliftedArrayM :: (PrimUnlifted a, Monad m) => UnliftedArray a -- ^ source -> Int -- ^ index -> m a indexUnliftedArrayM ua i = case indexUnliftedArrayU ua i of (# v #) -> return v {-# inline indexUnliftedArrayM #-} -- | Gets the value at the specified position of a 'MutableUnliftedArray'. readUnliftedArray :: (PrimMonad m, PrimUnlifted a) => MutableUnliftedArray (PrimState m) a -- ^ source -> Int -- ^ index -> m a readUnliftedArray (MutableUnliftedArray maa#) (I# i#) = primitive $ \s -> case readArrayArrayArray# maa# i# s of (# s', aa# #) -> (# s', fromArrayArray# aa# #) {-# inline readUnliftedArray #-} -- | Sets the value at the specified position of a 'MutableUnliftedArray'. writeUnliftedArray :: (PrimMonad m, PrimUnlifted a) => MutableUnliftedArray (PrimState m) a -- ^ destination -> Int -- ^ index -> a -- ^ value -> m () writeUnliftedArray (MutableUnliftedArray maa#) (I# i#) a = primitive_ (writeArrayArrayArray# maa# i# (toArrayArray# a)) {-# inline writeUnliftedArray #-} -- | Freezes a 'MutableUnliftedArray', yielding an 'UnliftedArray'. This simply -- marks the array as frozen in place, so it should only be used when no further -- modifications to the mutable array will be performed. unsafeFreezeUnliftedArray :: (PrimMonad m) => MutableUnliftedArray (PrimState m) a -> m (UnliftedArray a) unsafeFreezeUnliftedArray (MutableUnliftedArray maa#) = primitive $ \s -> case unsafeFreezeArrayArray# maa# s of (# s', aa# #) -> (# s', UnliftedArray aa# #) {-# inline unsafeFreezeUnliftedArray #-} -- | Determines whether two 'MutableUnliftedArray' values are the same. This is -- object/pointer identity, not based on the contents. sameMutableUnliftedArray :: MutableUnliftedArray s a -> MutableUnliftedArray s a -> Bool sameMutableUnliftedArray (MutableUnliftedArray maa1#) (MutableUnliftedArray maa2#) = isTrue# (sameMutableArrayArray# maa1# maa2#) {-# inline sameMutableUnliftedArray #-} -- | Copies the contents of an immutable array into a mutable array. copyUnliftedArray :: (PrimMonad m) => MutableUnliftedArray (PrimState m) a -- ^ destination -> Int -- ^ offset into destination -> UnliftedArray a -- ^ source -> Int -- ^ offset into source -> Int -- ^ number of elements to copy -> m () copyUnliftedArray (MutableUnliftedArray dst) (I# doff) (UnliftedArray src) (I# soff) (I# ln) = primitive_ $ copyArrayArray# src soff dst doff ln {-# inline copyUnliftedArray #-} -- | Copies the contents of one mutable array into another. copyMutableUnliftedArray :: (PrimMonad m) => MutableUnliftedArray (PrimState m) a -- ^ destination -> Int -- ^ offset into destination -> MutableUnliftedArray (PrimState m) a -- ^ source -> Int -- ^ offset into source -> Int -- ^ number of elements to copy -> m () copyMutableUnliftedArray (MutableUnliftedArray dst) (I# doff) (MutableUnliftedArray src) (I# soff) (I# ln) = primitive_ $ copyMutableArrayArray# src soff dst doff ln {-# inline copyMutableUnliftedArray #-} -- | Freezes a portion of a 'MutableUnliftedArray', yielding an 'UnliftedArray'. -- This operation is safe, in that it copies the frozen portion, and the -- existing mutable array may still be used afterward. freezeUnliftedArray :: (PrimMonad m) => MutableUnliftedArray (PrimState m) a -- ^ source -> Int -- ^ offset -> Int -- ^ length -> m (UnliftedArray a) freezeUnliftedArray src off len = do dst <- unsafeNewUnliftedArray len copyMutableUnliftedArray dst 0 src off len unsafeFreezeUnliftedArray dst {-# inline freezeUnliftedArray #-} -- | Thaws a portion of an 'UnliftedArray', yielding a 'MutableUnliftedArray'. -- This copies the thawed portion, so mutations will not affect the original -- array. thawUnliftedArray :: (PrimMonad m) => UnliftedArray a -- ^ source -> Int -- ^ offset -> Int -- ^ length -> m (MutableUnliftedArray (PrimState m) a) thawUnliftedArray src off len = do dst <- unsafeNewUnliftedArray len copyUnliftedArray dst 0 src off len return dst {-# inline thawUnliftedArray #-} -- | Creates a copy of a portion of an 'UnliftedArray' cloneUnliftedArray :: UnliftedArray a -- ^ source -> Int -- ^ offset -> Int -- ^ length -> UnliftedArray a cloneUnliftedArray src off len = runST $ thawUnliftedArray src off len >>= unsafeFreezeUnliftedArray {-# inline cloneUnliftedArray #-} -- | Creates a new 'MutableUnliftedArray' containing a copy of a portion of -- another mutable array. cloneMutableUnliftedArray :: (PrimMonad m) => MutableUnliftedArray (PrimState m) a -- ^ source -> Int -- ^ offset -> Int -- ^ length -> m (MutableUnliftedArray (PrimState m) a) cloneMutableUnliftedArray src off len = do dst <- unsafeNewUnliftedArray len copyMutableUnliftedArray dst 0 src off len return dst {-# inline cloneMutableUnliftedArray #-} instance Eq (MutableUnliftedArray s a) where (==) = sameMutableUnliftedArray instance (Eq a, PrimUnlifted a) => Eq (UnliftedArray a) where aa1 == aa2 = sizeofUnliftedArray aa1 == sizeofUnliftedArray aa2 && loop (sizeofUnliftedArray aa1 - 1) where loop i | i < 0 = True | otherwise = indexUnliftedArray aa1 i == indexUnliftedArray aa2 i && loop (i-1) primitive-0.6.2.0/Data/Primitive/Types.hs0000644000000000000000000002226213014454612016340 0ustar0000000000000000{-# LANGUAGE CPP, UnboxedTuples, MagicHash, DeriveDataTypeable #-} -- | -- Module : Data.Primitive.Types -- Copyright : (c) Roman Leshchinskiy 2009-2012 -- License : BSD-style -- -- Maintainer : Roman Leshchinskiy -- Portability : non-portable -- -- Basic types and classes for primitive array operations -- module Data.Primitive.Types ( Prim(..), Addr(..), ) where import Control.Monad.Primitive import Data.Primitive.MachDeps import Data.Primitive.Internal.Operations import GHC.Base ( Int(..), Char(..), ) import GHC.Float ( Float(..), Double(..) ) import GHC.Word ( Word(..), Word8(..), Word16(..), Word32(..), Word64(..) ) import GHC.Int ( Int8(..), Int16(..), Int32(..), Int64(..) ) import GHC.Ptr ( Ptr(..), FunPtr(..) ) import GHC.Prim #if __GLASGOW_HASKELL__ >= 706 hiding (setByteArray#) #endif import Data.Typeable ( Typeable ) import Data.Data ( Data(..) ) import Data.Primitive.Internal.Compat ( isTrue#, mkNoRepType ) -- | A machine address data Addr = Addr Addr# deriving ( Typeable ) instance Eq Addr where Addr a# == Addr b# = isTrue# (eqAddr# a# b#) Addr a# /= Addr b# = isTrue# (neAddr# a# b#) instance Ord Addr where Addr a# > Addr b# = isTrue# (gtAddr# a# b#) Addr a# >= Addr b# = isTrue# (geAddr# a# b#) Addr a# < Addr b# = isTrue# (ltAddr# a# b#) Addr a# <= Addr b# = isTrue# (leAddr# a# b#) instance Data Addr where toConstr _ = error "toConstr" gunfold _ _ = error "gunfold" dataTypeOf _ = mkNoRepType "Data.Primitive.Types.Addr" -- | Class of types supporting primitive array operations class Prim a where -- | Size of values of type @a@. The argument is not used. sizeOf# :: a -> Int# -- | Alignment of values of type @a@. The argument is not used. alignment# :: a -> Int# -- | Read a value from the array. The offset is in elements of type -- @a@ rather than in bytes. indexByteArray# :: ByteArray# -> Int# -> a -- | Read a value from the mutable array. The offset is in elements of type -- @a@ rather than in bytes. readByteArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s, a #) -- | Write a value to the mutable array. The offset is in elements of type -- @a@ rather than in bytes. writeByteArray# :: MutableByteArray# s -> Int# -> a -> State# s -> State# s -- | Fill a slice of the mutable array with a value. The offset and length -- of the chunk are in elements of type @a@ rather than in bytes. setByteArray# :: MutableByteArray# s -> Int# -> Int# -> a -> State# s -> State# s -- | Read a value from a memory position given by an address and an offset. -- The memory block the address refers to must be immutable. The offset is in -- elements of type @a@ rather than in bytes. indexOffAddr# :: Addr# -> Int# -> a -- | Read a value from a memory position given by an address and an offset. -- The offset is in elements of type @a@ rather than in bytes. readOffAddr# :: Addr# -> Int# -> State# s -> (# State# s, a #) -- | Write a value to a memory position given by an address and an offset. -- The offset is in elements of type @a@ rather than in bytes. writeOffAddr# :: Addr# -> Int# -> a -> State# s -> State# s -- | Fill a memory block given by an address, an offset and a length. -- The offset and length are in elements of type @a@ rather than in bytes. setOffAddr# :: Addr# -> Int# -> Int# -> a -> State# s -> State# s #define derivePrim(ty, ctr, sz, align, idx_arr, rd_arr, wr_arr, set_arr, idx_addr, rd_addr, wr_addr, set_addr) \ instance Prim (ty) where { \ sizeOf# _ = unI# sz \ ; alignment# _ = unI# align \ ; indexByteArray# arr# i# = ctr (idx_arr arr# i#) \ ; readByteArray# arr# i# s# = case rd_arr arr# i# s# of \ { (# s1#, x# #) -> (# s1#, ctr x# #) } \ ; writeByteArray# arr# i# (ctr x#) s# = wr_arr arr# i# x# s# \ ; setByteArray# arr# i# n# (ctr x#) s# \ = let { i = fromIntegral (I# i#) \ ; n = fromIntegral (I# n#) \ } in \ case unsafeCoerce# (internal (set_arr arr# i n x#)) s# of \ { (# s1#, _ #) -> s1# } \ \ ; indexOffAddr# addr# i# = ctr (idx_addr addr# i#) \ ; readOffAddr# addr# i# s# = case rd_addr addr# i# s# of \ { (# s1#, x# #) -> (# s1#, ctr x# #) } \ ; writeOffAddr# addr# i# (ctr x#) s# = wr_addr addr# i# x# s# \ ; setOffAddr# addr# i# n# (ctr x#) s# \ = let { i = fromIntegral (I# i#) \ ; n = fromIntegral (I# n#) \ } in \ case unsafeCoerce# (internal (set_addr addr# i n x#)) s# of \ { (# s1#, _ #) -> s1# } \ ; {-# INLINE sizeOf# #-} \ ; {-# INLINE alignment# #-} \ ; {-# INLINE indexByteArray# #-} \ ; {-# INLINE readByteArray# #-} \ ; {-# INLINE writeByteArray# #-} \ ; {-# INLINE setByteArray# #-} \ ; {-# INLINE indexOffAddr# #-} \ ; {-# INLINE readOffAddr# #-} \ ; {-# INLINE writeOffAddr# #-} \ ; {-# INLINE setOffAddr# #-} \ } unI# :: Int -> Int# unI# (I# n#) = n# derivePrim(Word, W#, sIZEOF_WORD, aLIGNMENT_WORD, indexWordArray#, readWordArray#, writeWordArray#, setWordArray#, indexWordOffAddr#, readWordOffAddr#, writeWordOffAddr#, setWordOffAddr#) derivePrim(Word8, W8#, sIZEOF_WORD8, aLIGNMENT_WORD8, indexWord8Array#, readWord8Array#, writeWord8Array#, setWord8Array#, indexWord8OffAddr#, readWord8OffAddr#, writeWord8OffAddr#, setWord8OffAddr#) derivePrim(Word16, W16#, sIZEOF_WORD16, aLIGNMENT_WORD16, indexWord16Array#, readWord16Array#, writeWord16Array#, setWord16Array#, indexWord16OffAddr#, readWord16OffAddr#, writeWord16OffAddr#, setWord16OffAddr#) derivePrim(Word32, W32#, sIZEOF_WORD32, aLIGNMENT_WORD32, indexWord32Array#, readWord32Array#, writeWord32Array#, setWord32Array#, indexWord32OffAddr#, readWord32OffAddr#, writeWord32OffAddr#, setWord32OffAddr#) derivePrim(Word64, W64#, sIZEOF_WORD64, aLIGNMENT_WORD64, indexWord64Array#, readWord64Array#, writeWord64Array#, setWord64Array#, indexWord64OffAddr#, readWord64OffAddr#, writeWord64OffAddr#, setWord64OffAddr#) derivePrim(Int, I#, sIZEOF_INT, aLIGNMENT_INT, indexIntArray#, readIntArray#, writeIntArray#, setIntArray#, indexIntOffAddr#, readIntOffAddr#, writeIntOffAddr#, setIntOffAddr#) derivePrim(Int8, I8#, sIZEOF_INT8, aLIGNMENT_INT8, indexInt8Array#, readInt8Array#, writeInt8Array#, setInt8Array#, indexInt8OffAddr#, readInt8OffAddr#, writeInt8OffAddr#, setInt8OffAddr#) derivePrim(Int16, I16#, sIZEOF_INT16, aLIGNMENT_INT16, indexInt16Array#, readInt16Array#, writeInt16Array#, setInt16Array#, indexInt16OffAddr#, readInt16OffAddr#, writeInt16OffAddr#, setInt16OffAddr#) derivePrim(Int32, I32#, sIZEOF_INT32, aLIGNMENT_INT32, indexInt32Array#, readInt32Array#, writeInt32Array#, setInt32Array#, indexInt32OffAddr#, readInt32OffAddr#, writeInt32OffAddr#, setInt32OffAddr#) derivePrim(Int64, I64#, sIZEOF_INT64, aLIGNMENT_INT64, indexInt64Array#, readInt64Array#, writeInt64Array#, setInt64Array#, indexInt64OffAddr#, readInt64OffAddr#, writeInt64OffAddr#, setInt64OffAddr#) derivePrim(Float, F#, sIZEOF_FLOAT, aLIGNMENT_FLOAT, indexFloatArray#, readFloatArray#, writeFloatArray#, setFloatArray#, indexFloatOffAddr#, readFloatOffAddr#, writeFloatOffAddr#, setFloatOffAddr#) derivePrim(Double, D#, sIZEOF_DOUBLE, aLIGNMENT_DOUBLE, indexDoubleArray#, readDoubleArray#, writeDoubleArray#, setDoubleArray#, indexDoubleOffAddr#, readDoubleOffAddr#, writeDoubleOffAddr#, setDoubleOffAddr#) derivePrim(Char, C#, sIZEOF_CHAR, aLIGNMENT_CHAR, indexWideCharArray#, readWideCharArray#, writeWideCharArray#, setWideCharArray#, indexWideCharOffAddr#, readWideCharOffAddr#, writeWideCharOffAddr#, setWideCharOffAddr#) derivePrim(Addr, Addr, sIZEOF_PTR, aLIGNMENT_PTR, indexAddrArray#, readAddrArray#, writeAddrArray#, setAddrArray#, indexAddrOffAddr#, readAddrOffAddr#, writeAddrOffAddr#, setAddrOffAddr#) derivePrim(Ptr a, Ptr, sIZEOF_PTR, aLIGNMENT_PTR, indexAddrArray#, readAddrArray#, writeAddrArray#, setAddrArray#, indexAddrOffAddr#, readAddrOffAddr#, writeAddrOffAddr#, setAddrOffAddr#) derivePrim(FunPtr a, FunPtr, sIZEOF_PTR, aLIGNMENT_PTR, indexAddrArray#, readAddrArray#, writeAddrArray#, setAddrArray#, indexAddrOffAddr#, readAddrOffAddr#, writeAddrOffAddr#, setAddrOffAddr#) primitive-0.6.2.0/Data/Primitive/ByteArray.hs0000644000000000000000000002437113014454612017141 0ustar0000000000000000{-# LANGUAGE CPP, MagicHash, UnboxedTuples, UnliftedFFITypes, DeriveDataTypeable #-} -- | -- Module : Data.Primitive.ByteArray -- Copyright : (c) Roman Leshchinskiy 2009-2012 -- License : BSD-style -- -- Maintainer : Roman Leshchinskiy -- Portability : non-portable -- -- Primitive operations on ByteArrays -- module Data.Primitive.ByteArray ( -- * Types ByteArray(..), MutableByteArray(..), ByteArray#, MutableByteArray#, -- * Allocation newByteArray, newPinnedByteArray, newAlignedPinnedByteArray, -- * Element access readByteArray, writeByteArray, indexByteArray, -- * Freezing and thawing unsafeFreezeByteArray, unsafeThawByteArray, -- * Block operations copyByteArray, copyMutableByteArray, moveByteArray, setByteArray, fillByteArray, -- * Information sizeofByteArray, sizeofMutableByteArray, sameMutableByteArray, byteArrayContents, mutableByteArrayContents ) where import Control.Monad.Primitive import Data.Primitive.Types import Foreign.C.Types import Data.Word ( Word8 ) import GHC.Base ( Int(..) ) import GHC.Prim #if __GLASGOW_HASKELL__ >= 706 hiding (setByteArray#) #endif import Data.Typeable ( Typeable ) import Data.Data ( Data(..) ) import Data.Primitive.Internal.Compat ( isTrue#, mkNoRepType ) -- | Byte arrays data ByteArray = ByteArray ByteArray# deriving ( Typeable ) -- | Mutable byte arrays associated with a primitive state token data MutableByteArray s = MutableByteArray (MutableByteArray# s) deriving( Typeable ) -- | Create a new mutable byte array of the specified size. newByteArray :: PrimMonad m => Int -> m (MutableByteArray (PrimState m)) {-# INLINE newByteArray #-} newByteArray (I# n#) = primitive (\s# -> case newByteArray# n# s# of (# s'#, arr# #) -> (# s'#, MutableByteArray arr# #)) -- | Create a /pinned/ byte array of the specified size. The garbage collector -- is guaranteed not to move it. newPinnedByteArray :: PrimMonad m => Int -> m (MutableByteArray (PrimState m)) {-# INLINE newPinnedByteArray #-} newPinnedByteArray (I# n#) = primitive (\s# -> case newPinnedByteArray# n# s# of (# s'#, arr# #) -> (# s'#, MutableByteArray arr# #)) -- | Create a /pinned/ byte array of the specified size and with the give -- alignment. The garbage collector is guaranteed not to move it. newAlignedPinnedByteArray :: PrimMonad m => Int -> Int -> m (MutableByteArray (PrimState m)) {-# INLINE newAlignedPinnedByteArray #-} newAlignedPinnedByteArray (I# n#) (I# k#) = primitive (\s# -> case newAlignedPinnedByteArray# n# k# s# of (# s'#, arr# #) -> (# s'#, MutableByteArray arr# #)) -- | Yield a pointer to the array's data. This operation is only safe on -- /pinned/ byte arrays allocated by 'newPinnedByteArray' or -- 'newAlignedPinnedByteArray'. byteArrayContents :: ByteArray -> Addr {-# INLINE byteArrayContents #-} byteArrayContents (ByteArray arr#) = Addr (byteArrayContents# arr#) -- | Yield a pointer to the array's data. This operation is only safe on -- /pinned/ byte arrays allocated by 'newPinnedByteArray' or -- 'newAlignedPinnedByteArray'. mutableByteArrayContents :: MutableByteArray s -> Addr {-# INLINE mutableByteArrayContents #-} mutableByteArrayContents (MutableByteArray arr#) = Addr (byteArrayContents# (unsafeCoerce# arr#)) -- | Check if the two arrays refer to the same memory block. sameMutableByteArray :: MutableByteArray s -> MutableByteArray s -> Bool {-# INLINE sameMutableByteArray #-} sameMutableByteArray (MutableByteArray arr#) (MutableByteArray brr#) = isTrue# (sameMutableByteArray# arr# brr#) -- | Convert a mutable byte array to an immutable one without copying. The -- array should not be modified after the conversion. unsafeFreezeByteArray :: PrimMonad m => MutableByteArray (PrimState m) -> m ByteArray {-# INLINE unsafeFreezeByteArray #-} unsafeFreezeByteArray (MutableByteArray arr#) = primitive (\s# -> case unsafeFreezeByteArray# arr# s# of (# s'#, arr'# #) -> (# s'#, ByteArray arr'# #)) -- | Convert an immutable byte array to a mutable one without copying. The -- original array should not be used after the conversion. unsafeThawByteArray :: PrimMonad m => ByteArray -> m (MutableByteArray (PrimState m)) {-# INLINE unsafeThawByteArray #-} unsafeThawByteArray (ByteArray arr#) = primitive (\s# -> (# s#, MutableByteArray (unsafeCoerce# arr#) #)) -- | Size of the byte array. sizeofByteArray :: ByteArray -> Int {-# INLINE sizeofByteArray #-} sizeofByteArray (ByteArray arr#) = I# (sizeofByteArray# arr#) -- | Size of the mutable byte array. sizeofMutableByteArray :: MutableByteArray s -> Int {-# INLINE sizeofMutableByteArray #-} sizeofMutableByteArray (MutableByteArray arr#) = I# (sizeofMutableByteArray# arr#) -- | Read a primitive value from the byte array. The offset is given in -- elements of type @a@ rather than in bytes. indexByteArray :: Prim a => ByteArray -> Int -> a {-# INLINE indexByteArray #-} indexByteArray (ByteArray arr#) (I# i#) = indexByteArray# arr# i# -- | Read a primitive value from the byte array. The offset is given in -- elements of type @a@ rather than in bytes. readByteArray :: (Prim a, PrimMonad m) => MutableByteArray (PrimState m) -> Int -> m a {-# INLINE readByteArray #-} readByteArray (MutableByteArray arr#) (I# i#) = primitive (readByteArray# arr# i#) -- | Write a primitive value to the byte array. The offset is given in -- elements of type @a@ rather than in bytes. writeByteArray :: (Prim a, PrimMonad m) => MutableByteArray (PrimState m) -> Int -> a -> m () {-# INLINE writeByteArray #-} writeByteArray (MutableByteArray arr#) (I# i#) x = primitive_ (writeByteArray# arr# i# x) #if __GLASGOW_HASKELL__ >= 702 unI# :: Int -> Int# unI# (I# n#) = n# #endif -- | Copy a slice of an immutable byte array to a mutable byte array. copyByteArray :: PrimMonad m => MutableByteArray (PrimState m) -- ^ destination array -> Int -- ^ offset into destination array -> ByteArray -- ^ source array -> Int -- ^ offset into source array -> Int -- ^ number of bytes to copy -> m () {-# INLINE copyByteArray #-} copyByteArray (MutableByteArray dst#) doff (ByteArray src#) soff sz #if __GLASGOW_HASKELL__ >= 702 = primitive_ (copyByteArray# src# (unI# soff) dst# (unI# doff) (unI# sz)) #else = unsafePrimToPrim $ memcpy_ba dst# (fromIntegral doff) src# (fromIntegral soff) (fromIntegral sz) #endif -- | Copy a slice of a mutable byte array into another array. The two slices -- may not overlap. copyMutableByteArray :: PrimMonad m => MutableByteArray (PrimState m) -- ^ destination array -> Int -- ^ offset into destination array -> MutableByteArray (PrimState m) -- ^ source array -> Int -- ^ offset into source array -> Int -- ^ number of bytes to copy -> m () {-# INLINE copyMutableByteArray #-} copyMutableByteArray (MutableByteArray dst#) doff (MutableByteArray src#) soff sz #if __GLASGOW_HASKELL__ >= 702 = primitive_ (copyMutableByteArray# src# (unI# soff) dst# (unI# doff) (unI# sz)) #else = unsafePrimToPrim $ memcpy_mba dst# (fromIntegral doff) src# (fromIntegral soff) (fromIntegral sz) #endif -- | Copy a slice of a mutable byte array into another, potentially -- overlapping array. moveByteArray :: PrimMonad m => MutableByteArray (PrimState m) -- ^ destination array -> Int -- ^ offset into destination array -> MutableByteArray (PrimState m) -- ^ source array -> Int -- ^ offset into source array -> Int -- ^ number of bytes to copy -> m () {-# INLINE moveByteArray #-} moveByteArray (MutableByteArray dst#) doff (MutableByteArray src#) soff sz = unsafePrimToPrim $ memmove_mba dst# (fromIntegral doff) src# (fromIntegral soff) (fromIntegral sz) -- | Fill a slice of a mutable byte array with a value. The offset and length -- are given in elements of type @a@ rather than in bytes. setByteArray :: (Prim a, PrimMonad m) => MutableByteArray (PrimState m) -- ^ array to fill -> Int -- ^ offset into array -> Int -- ^ number of values to fill -> a -- ^ value to fill with -> m () {-# INLINE setByteArray #-} setByteArray (MutableByteArray dst#) (I# doff#) (I# sz#) x = primitive_ (setByteArray# dst# doff# sz# x) -- | Fill a slice of a mutable byte array with a byte. fillByteArray :: PrimMonad m => MutableByteArray (PrimState m) -- ^ array to fill -> Int -- ^ offset into array -> Int -- ^ number of bytes to fill -> Word8 -- ^ byte to fill with -> m () {-# INLINE fillByteArray #-} fillByteArray = setByteArray #if __GLASGOW_HASKELL__ < 702 foreign import ccall unsafe "primitive-memops.h hsprimitive_memcpy" memcpy_mba :: MutableByteArray# s -> CInt -> MutableByteArray# s -> CInt -> CSize -> IO () foreign import ccall unsafe "primitive-memops.h hsprimitive_memcpy" memcpy_ba :: MutableByteArray# s -> CInt -> ByteArray# -> CInt -> CSize -> IO () #endif foreign import ccall unsafe "primitive-memops.h hsprimitive_memmove" memmove_mba :: MutableByteArray# s -> CInt -> MutableByteArray# s -> CInt -> CSize -> IO () instance Data ByteArray where toConstr _ = error "toConstr" gunfold _ _ = error "gunfold" dataTypeOf _ = mkNoRepType "Data.Primitive.ByteArray.ByteArray" instance Typeable s => Data (MutableByteArray s) where toConstr _ = error "toConstr" gunfold _ _ = error "gunfold" dataTypeOf _ = mkNoRepType "Data.Primitive.ByteArray.MutableByteArray" primitive-0.6.2.0/Data/Primitive/SmallArray.hs0000644000000000000000000004531113014454612017303 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | -- Module : Data.Primitive.SmallArray -- Copyright: (c) 2015 Dan Doel -- License: BSD3 -- -- Maintainer: libraries@haskell.org -- Portability: non-portable -- -- Small arrays are boxed (im)mutable arrays. -- -- The underlying structure of the 'Array' type contains a card table, allowing -- segments of the array to be marked as having been mutated. This allows the -- garbage collector to only re-traverse segments of the array that have been -- marked during certain phases, rather than having to traverse the entire -- array. -- -- 'SmallArray' lacks this table. This means that it takes up less memory and -- has slightly faster writes. It is also more efficient during garbage -- collection so long as the card table would have a single entry covering the -- entire array. These advantages make them suitable for use as arrays that are -- known to be small. -- -- The card size is 128, so for uses much larger than that, 'Array' would likely -- be superior. -- -- The underlying type, 'SmallArray#', was introduced in GHC 7.10, so prior to -- that version, this module simply implements small arrays as 'Array'. module Data.Primitive.SmallArray ( SmallArray(..) , SmallMutableArray(..) , newSmallArray , readSmallArray , writeSmallArray , copySmallArray , copySmallMutableArray , indexSmallArray , indexSmallArrayM , cloneSmallArray , cloneSmallMutableArray , freezeSmallArray , unsafeFreezeSmallArray , thawSmallArray , unsafeThawSmallArray , sizeofSmallArray , sizeofSmallMutableArray ) where #if (__GLASGOW_HASKELL__ >= 710) #define HAVE_SMALL_ARRAY 1 #endif #if MIN_VERSION_base(4,7,0) import GHC.Exts hiding (toList) import qualified GHC.Exts #endif import Control.Applicative import Control.Monad import Control.Monad.Fix import Control.Monad.Primitive import Control.Monad.ST #if MIN_VERSION_base(4,4,0) import Control.Monad.Zip #endif import Data.Data import Data.Foldable import Data.Functor.Identity import Data.Monoid import Text.ParserCombinators.ReadPrec import Text.Read import Text.Read.Lex #if !(HAVE_SMALL_ARRAY) import Data.Primitive.Array import Data.Traversable #endif #if HAVE_SMALL_ARRAY data SmallArray a = SmallArray (SmallArray# a) deriving Typeable #else newtype SmallArray a = SmallArray (Array a) deriving ( Eq , Ord , Show , Read , Foldable , Traversable , Functor , Applicative , Alternative , Monad , MonadPlus #if MIN_VERSION_base(4,4,0) , MonadZip #endif , MonadFix , Monoid , Typeable ) #if MIN_VERSION_base(4,7,0) instance IsList (SmallArray a) where type Item (SmallArray a) = a fromListN n l = SmallArray (fromListN n l) fromList l = SmallArray (fromList l) toList (SmallArray a) = toList a #endif #endif #if HAVE_SMALL_ARRAY data SmallMutableArray s a = SmallMutableArray (SmallMutableArray# s a) deriving Typeable #else newtype SmallMutableArray s a = SmallMutableArray (MutableArray s a) deriving (Eq, Typeable) #endif -- | Create a new small mutable array. newSmallArray :: PrimMonad m => Int -- ^ size -> a -- ^ initial contents -> m (SmallMutableArray (PrimState m) a) #if HAVE_SMALL_ARRAY newSmallArray (I# i#) x = primitive $ \s -> case newSmallArray# i# x s of (# s', sma# #) -> (# s', SmallMutableArray sma# #) #else newSmallArray n e = SmallMutableArray `liftM` newArray n e #endif {-# INLINE newSmallArray #-} -- | Read the element at a given index in a mutable array. readSmallArray :: PrimMonad m => SmallMutableArray (PrimState m) a -- ^ array -> Int -- ^ index -> m a #if HAVE_SMALL_ARRAY readSmallArray (SmallMutableArray sma#) (I# i#) = primitive $ readSmallArray# sma# i# #else readSmallArray (SmallMutableArray a) = readArray a #endif {-# INLINE readSmallArray #-} -- | Write an element at the given idex in a mutable array. writeSmallArray :: PrimMonad m => SmallMutableArray (PrimState m) a -- ^ array -> Int -- ^ index -> a -- ^ new element -> m () #if HAVE_SMALL_ARRAY writeSmallArray (SmallMutableArray sma#) (I# i#) x = primitive_ $ writeSmallArray# sma# i# x #else writeSmallArray (SmallMutableArray a) = writeArray a #endif {-# INLINE writeSmallArray #-} -- | Look up an element in an immutable array. -- -- The purpose of returning a result using a monad is to allow the caller to -- avoid retaining references to the array. Evaluating the return value will -- cause the array lookup to be performed, even though it may not require the -- element of the array to be evaluated (which could throw an exception). For -- instance: -- -- > data Box a = Box a -- > ... -- > -- > f sa = case indexSmallArrayM sa 0 of -- > Box x -> ... -- -- 'x' is not a closure that references 'sa' as it would be if we instead -- wrote: -- -- > let x = indexSmallArray sa 0 -- -- And does not prevent 'sa' from being garbage collected. -- -- Note that 'Identity' is not adequate for this use, as it is a newtype, and -- cannot be evaluated without evaluating the element. indexSmallArrayM :: Monad m => SmallArray a -- ^ array -> Int -- ^ index -> m a #if HAVE_SMALL_ARRAY indexSmallArrayM (SmallArray sa#) (I# i#) = case indexSmallArray# sa# i# of (# x #) -> pure x #else indexSmallArrayM (SmallArray a) = indexArrayM a #endif {-# INLINE indexSmallArrayM #-} -- | Look up an element in an immutable array. indexSmallArray :: SmallArray a -- ^ array -> Int -- ^ index -> a #if HAVE_SMALL_ARRAY indexSmallArray sa i = runIdentity $ indexSmallArrayM sa i #else indexSmallArray (SmallArray a) = indexArray a #endif {-# INLINE indexSmallArray #-} -- | Create a copy of a slice of an immutable array. cloneSmallArray :: SmallArray a -- ^ source -> Int -- ^ offset -> Int -- ^ length -> SmallArray a #if HAVE_SMALL_ARRAY cloneSmallArray (SmallArray sa#) (I# i#) (I# j#) = SmallArray (cloneSmallArray# sa# i# j#) #else cloneSmallArray (SmallArray a) i j = SmallArray $ cloneArray a i j #endif {-# INLINE cloneSmallArray #-} -- | Create a copy of a slice of a mutable array. cloneSmallMutableArray :: PrimMonad m => SmallMutableArray (PrimState m) a -- ^ source -> Int -- ^ offset -> Int -- ^ length -> m (SmallMutableArray (PrimState m) a) #if HAVE_SMALL_ARRAY cloneSmallMutableArray (SmallMutableArray sma#) (I# o#) (I# l#) = primitive $ \s -> case cloneSmallMutableArray# sma# o# l# s of (# s', smb# #) -> (# s', SmallMutableArray smb# #) #else cloneSmallMutableArray (SmallMutableArray ma) i j = SmallMutableArray `liftM` cloneMutableArray ma i j #endif {-# INLINE cloneSmallMutableArray #-} -- | Create an immutable array corresponding to a slice of a mutable array. -- -- This operation copies the portion of the array to be frozen. freezeSmallArray :: PrimMonad m => SmallMutableArray (PrimState m) a -- ^ source -> Int -- ^ offset -> Int -- ^ length -> m (SmallArray a) #if HAVE_SMALL_ARRAY freezeSmallArray (SmallMutableArray sma#) (I# i#) (I# j#) = primitive $ \s -> case freezeSmallArray# sma# i# j# s of (# s', sa# #) -> (# s', SmallArray sa# #) #else freezeSmallArray (SmallMutableArray ma) i j = SmallArray `liftM` freezeArray ma i j #endif {-# INLINE freezeSmallArray #-} -- | Render a mutable array immutable. -- -- This operation performs no copying, so care must be taken not to modify the -- input array after freezing. unsafeFreezeSmallArray :: PrimMonad m => SmallMutableArray (PrimState m) a -> m (SmallArray a) #if HAVE_SMALL_ARRAY unsafeFreezeSmallArray (SmallMutableArray sma#) = primitive $ \s -> case unsafeFreezeSmallArray# sma# s of (# s', sa# #) -> (# s', SmallArray sa# #) #else unsafeFreezeSmallArray (SmallMutableArray ma) = SmallArray `liftM` unsafeFreezeArray ma #endif {-# INLINE unsafeFreezeSmallArray #-} -- | Create a mutable array corresponding to a slice of an immutable array. -- -- This operation copies the portion of the array to be thawed. thawSmallArray :: PrimMonad m => SmallArray a -- ^ source -> Int -- ^ offset -> Int -- ^ length -> m (SmallMutableArray (PrimState m) a) #if HAVE_SMALL_ARRAY thawSmallArray (SmallArray sa#) (I# o#) (I# l#) = primitive $ \s -> case thawSmallArray# sa# o# l# s of (# s', sma# #) -> (# s', SmallMutableArray sma# #) #else thawSmallArray (SmallArray a) off len = SmallMutableArray `liftM` thawArray a off len #endif {-# INLINE thawSmallArray #-} -- | Render an immutable array mutable. -- -- This operation performs no copying, so care must be taken with its use. unsafeThawSmallArray :: PrimMonad m => SmallArray a -> m (SmallMutableArray (PrimState m) a) #if HAVE_SMALL_ARRAY unsafeThawSmallArray (SmallArray sa#) = primitive $ \s -> case unsafeThawSmallArray# sa# s of (# s', sma# #) -> (# s', SmallMutableArray sma# #) #else unsafeThawSmallArray (SmallArray a) = SmallMutableArray `liftM` unsafeThawArray a #endif {-# INLINE unsafeThawSmallArray #-} -- | Copy a slice of an immutable array into a mutable array. copySmallArray :: PrimMonad m => SmallMutableArray (PrimState m) a -- ^ destination -> Int -- ^ destination offset -> SmallArray a -- ^ source -> Int -- ^ source offset -> Int -- ^ length -> m () #if HAVE_SMALL_ARRAY copySmallArray (SmallMutableArray dst#) (I# do#) (SmallArray src#) (I# so#) (I# l#) = primitive_ $ copySmallArray# src# so# dst# do# l# #else copySmallArray (SmallMutableArray dst) i (SmallArray src) = copyArray dst i src #endif {-# INLINE copySmallArray #-} -- | Copy a slice of one mutable array into another. copySmallMutableArray :: PrimMonad m => SmallMutableArray (PrimState m) a -- ^ destination -> Int -- ^ destination offset -> SmallMutableArray (PrimState m) a -- ^ source -> Int -- ^ source offset -> Int -- ^ length -> m () #if HAVE_SMALL_ARRAY copySmallMutableArray (SmallMutableArray dst#) (I# do#) (SmallMutableArray src#) (I# so#) (I# l#) = primitive_ $ copySmallMutableArray# src# so# dst# do# l# #else copySmallMutableArray (SmallMutableArray dst) i (SmallMutableArray src) = copyMutableArray dst i src #endif {-# INLINE copySmallMutableArray #-} sizeofSmallArray :: SmallArray a -> Int #if HAVE_SMALL_ARRAY sizeofSmallArray (SmallArray sa#) = I# (sizeofSmallArray# sa#) #else sizeofSmallArray (SmallArray a) = sizeofArray a #endif {-# INLINE sizeofSmallArray #-} sizeofSmallMutableArray :: SmallMutableArray s a -> Int #if HAVE_SMALL_ARRAY sizeofSmallMutableArray (SmallMutableArray sa#) = I# (sizeofSmallMutableArray# sa#) #else sizeofSmallMutableArray (SmallMutableArray ma) = sizeofMutableArray ma #endif {-# INLINE sizeofSmallMutableArray #-} #if HAVE_SMALL_ARRAY die :: String -> String -> a die fun problem = error $ "Data.Primitive.SmallArray." ++ fun ++ ": " ++ problem emptySmallArray :: SmallArray a emptySmallArray = runST $ newSmallArray 0 (die "emptySmallArray" "impossible") >>= unsafeFreezeSmallArray {-# NOINLINE emptySmallArray #-} createSmallArray :: Int -> a -> (forall s. SmallMutableArray s a -> ST s ()) -> SmallArray a createSmallArray 0 _ _ = emptySmallArray createSmallArray i x k = runST $ newSmallArray i x >>= \sa -> k sa *> unsafeFreezeSmallArray sa {-# INLINE createSmallArray #-} infixl 1 ? (?) :: (a -> b -> c) -> (b -> a -> c) (?) = flip {-# INLINE (?) #-} noOp :: a -> ST s () noOp = const $ pure () instance Eq a => Eq (SmallArray a) where sa1 == sa2 = length sa1 == length sa2 && loop (length sa1 - 1) where loop i | i < 0 = True | otherwise = indexSmallArray sa1 i == indexSmallArray sa2 i && loop (i-1) instance Eq (SmallMutableArray s a) where SmallMutableArray sma1# == SmallMutableArray sma2# = isTrue# (sameSmallMutableArray# sma1# sma2#) instance Ord a => Ord (SmallArray a) where compare sl sr = fix ? 0 $ \go i -> if i < l then compare (indexSmallArray sl i) (indexSmallArray sr i) <> go (i+1) else compare (length sl) (length sr) where l = length sl `min` length sr instance Foldable SmallArray where foldr f z sa = fix ? 0 $ \go i -> if i < length sa then f (indexSmallArray sa i) (go $ i+1) else z {-# INLINE foldr #-} foldr' f z sa = fix ? z ? length sa - 1 $ \go acc i -> if i < 0 then acc else go (f (indexSmallArray sa i) acc) (i-1) {-# INLINE foldr' #-} foldl f z sa = fix ? length sa - 1 $ \go i -> if i < 0 then z else f (go $ i-1) $ indexSmallArray sa i {-# INLINE foldl #-} foldl' f z sa = fix ? z ? 0 $ \go acc i -> if i < length sa then go (f acc $ indexSmallArray sa i) (i+1) else acc {-# INLINE foldl' #-} foldr1 f sa | sz == 0 = die "foldr1" "empty list" | otherwise = fix ? 0 $ \go i -> if i < sz-1 then f (indexSmallArray sa i) (go $ i+1) else indexSmallArray sa $ sz-1 where sz = sizeofSmallArray sa {-# INLINE foldr1 #-} foldl1 f sa | sz == 0 = die "foldl1" "empty list" | otherwise = fix ? sz-1 $ \go i -> if i < 1 then indexSmallArray sa 0 else f (go $ i-1) (indexSmallArray sa i) where sz = sizeofSmallArray sa {-# INLINE foldl1 #-} null sa = sizeofSmallArray sa == 0 {-# INLINE null #-} length = sizeofSmallArray {-# INLINE length #-} instance Traversable SmallArray where traverse f sa = fromListN l <$> traverse (f . indexSmallArray sa) [0..l-1] where l = length sa instance Functor SmallArray where fmap f sa = createSmallArray (length sa) (die "fmap" "impossible") $ \smb -> fix ? 0 $ \go i -> when (i < length sa) $ writeSmallArray smb i (f $ indexSmallArray sa i) *> go (i+1) {-# INLINE fmap #-} x <$ sa = createSmallArray (length sa) x noOp instance Applicative SmallArray where pure x = createSmallArray 1 x noOp sa *> sb = createSmallArray (la*lb) (die "*>" "impossible") $ \smb -> fix ? 0 $ \go i -> when (i < la) $ copySmallArray smb 0 sb 0 lb *> go (i+1) where la = length sa ; lb = length sb sa <* sb = createSmallArray (la*lb) (indexSmallArray sa $ la-1) $ \sma -> fix ? 0 $ \outer i -> when (i < la-1) $ do let a = indexSmallArray sa i fix ? 0 $ \inner j -> when (j < lb) $ writeSmallArray sma (la*i + j) a *> inner (j+1) outer $ i+1 where la = length sa ; lb = length sb sf <*> sx = createSmallArray (lf*lx) (die "<*>" "impossible") $ \smb -> fix ? 0 $ \outer i -> when (i < lf) $ do let f = indexSmallArray sf i fix ? 0 $ \inner j -> when (j < lx) $ writeSmallArray smb (lf*i + j) (f $ indexSmallArray sx j) *> inner (j+1) outer $ i+1 where lf = length sf ; lx = length sx instance Alternative SmallArray where empty = emptySmallArray sl <|> sr = createSmallArray (length sl + length sr) (die "<|>" "impossible") $ \sma -> copySmallArray sma 0 sl 0 (length sl) *> copySmallArray sma (length sl) sr 0 (length sr) many sa | null sa = pure [] | otherwise = die "many" "infinite arrays are not well defined" some sa | null sa = emptySmallArray | otherwise = die "some" "infinite arrays are not well defined" instance Monad SmallArray where return = pure (>>) = (*>) sa >>= f = collect 0 [] (la-1) where la = length sa collect sz stk i | i < 0 = createSmallArray sz (die ">>=" "impossible") $ fill 0 stk | otherwise = let sb = f $ indexSmallArray sa i in collect (sz + length sb) (sb:stk) (i-1) fill _ [ ] _ = return () fill off (sb:sbs) smb = copySmallArray smb off sb 0 (length sb) *> fill (off + length sb) sbs smb fail _ = emptySmallArray instance MonadPlus SmallArray where mzero = empty mplus = (<|>) zipW :: String -> (a -> b -> c) -> SmallArray a -> SmallArray b -> SmallArray c zipW nm = \f sa sb -> let mn = length sa `min` length sb in createSmallArray mn (die nm "impossible") $ \mc -> fix ? 0 $ \go i -> when (i < mn) $ writeSmallArray mc i (f (indexSmallArray sa i) (indexSmallArray sb i)) *> go (i+1) {-# INLINE zipW #-} instance MonadZip SmallArray where mzip = zipW "mzip" (,) mzipWith = zipW "mzipWith" {-# INLINE mzipWith #-} munzip sab = runST $ do let sz = length sab sma <- newSmallArray sz $ die "munzip" "impossible" smb <- newSmallArray sz $ die "munzip" "impossible" fix ? 0 $ \go i -> when (i < sz) $ case indexSmallArray sab i of (x, y) -> do writeSmallArray sma i x writeSmallArray smb i y go $ i+1 (,) <$> unsafeFreezeSmallArray sma <*> unsafeFreezeSmallArray smb instance MonadFix SmallArray where mfix f = fromList . mfix $ toList . f instance Monoid (SmallArray a) where mempty = empty mappend = (<|>) mconcat sas = createSmallArray n (die "mconcat" "impossible") $ \sma -> fix ? 0 ? sas $ \go off l -> case l of [] -> return () sa:stk -> copySmallArray sma off sa 0 (length sa) *> go (off+1) stk where n = sum . fmap length $ sas instance IsList (SmallArray a) where type Item (SmallArray a) = a fromListN n l = createSmallArray n (die "fromListN" "mismatched size and list") $ \sma -> fix ? 0 ? l $ \go i li -> case li of [] -> pure () x:xs -> writeSmallArray sma i x *> go (i+1) xs fromList l = fromListN (length l) l toList sa = indexSmallArray sa <$> [0 .. length sa - 1] instance Show a => Show (SmallArray a) where showsPrec p sa = showParen (p > 10) $ showString "fromListN " . shows (length sa) . showString " " . shows (toList sa) instance Read a => Read (SmallArray a) where readPrec = parens . prec 10 $ do Symbol "fromListN" <- lexP Number nu <- lexP n <- maybe empty pure $ numberToInteger nu fromListN (fromIntegral n) <$> readPrec smallArrayDataType :: DataType smallArrayDataType = mkDataType "Data.Primitive.SmallArray.SmallArray" [fromListConstr] fromListConstr :: Constr fromListConstr = mkConstr smallArrayDataType "fromList" [] Prefix instance Data a => Data (SmallArray a) where toConstr _ = fromListConstr dataTypeOf _ = smallArrayDataType gunfold k z c = case constrIndex c of 1 -> k (z fromList) _ -> die "gunfold" "SmallArray" gfoldl f z m = z fromList `f` toList m instance (Typeable s, Typeable a) => Data (SmallMutableArray s a) where toConstr _ = die "toConstr" "SmallMutableArray" gunfold _ _ = die "gunfold" "SmallMutableArray" dataTypeOf _ = mkNoRepType "Data.Primitive.SmallArray.SmallMutableArray" #endif primitive-0.6.2.0/Data/Primitive/MachDeps.hs0000644000000000000000000000405513014454612016720 0ustar0000000000000000{-# LANGUAGE CPP, MagicHash #-} -- | -- Module : Data.Primitive.MachDeps -- Copyright : (c) Roman Leshchinskiy 2009-2012 -- License : BSD-style -- -- Maintainer : Roman Leshchinskiy -- Portability : non-portable -- -- Machine-dependent constants -- module Data.Primitive.MachDeps where #include "MachDeps.h" import GHC.Prim sIZEOF_CHAR, aLIGNMENT_CHAR, sIZEOF_INT, aLIGNMENT_INT, sIZEOF_WORD, aLIGNMENT_WORD, sIZEOF_DOUBLE, aLIGNMENT_DOUBLE, sIZEOF_FLOAT, aLIGNMENT_FLOAT, sIZEOF_PTR, aLIGNMENT_PTR, sIZEOF_FUNPTR, aLIGNMENT_FUNPTR, sIZEOF_STABLEPTR, aLIGNMENT_STABLEPTR, sIZEOF_INT8, aLIGNMENT_INT8, sIZEOF_WORD8, aLIGNMENT_WORD8, sIZEOF_INT16, aLIGNMENT_INT16, sIZEOF_WORD16, aLIGNMENT_WORD16, sIZEOF_INT32, aLIGNMENT_INT32, sIZEOF_WORD32, aLIGNMENT_WORD32, sIZEOF_INT64, aLIGNMENT_INT64, sIZEOF_WORD64, aLIGNMENT_WORD64 :: Int sIZEOF_CHAR = SIZEOF_HSCHAR aLIGNMENT_CHAR = ALIGNMENT_HSCHAR sIZEOF_INT = SIZEOF_HSINT aLIGNMENT_INT = ALIGNMENT_HSINT sIZEOF_WORD = SIZEOF_HSWORD aLIGNMENT_WORD = ALIGNMENT_HSWORD sIZEOF_DOUBLE = SIZEOF_HSDOUBLE aLIGNMENT_DOUBLE = ALIGNMENT_HSDOUBLE sIZEOF_FLOAT = SIZEOF_HSFLOAT aLIGNMENT_FLOAT = ALIGNMENT_HSFLOAT sIZEOF_PTR = SIZEOF_HSPTR aLIGNMENT_PTR = ALIGNMENT_HSPTR sIZEOF_FUNPTR = SIZEOF_HSFUNPTR aLIGNMENT_FUNPTR = ALIGNMENT_HSFUNPTR sIZEOF_STABLEPTR = SIZEOF_HSSTABLEPTR aLIGNMENT_STABLEPTR = ALIGNMENT_HSSTABLEPTR sIZEOF_INT8 = SIZEOF_INT8 aLIGNMENT_INT8 = ALIGNMENT_INT8 sIZEOF_WORD8 = SIZEOF_WORD8 aLIGNMENT_WORD8 = ALIGNMENT_WORD8 sIZEOF_INT16 = SIZEOF_INT16 aLIGNMENT_INT16 = ALIGNMENT_INT16 sIZEOF_WORD16 = SIZEOF_WORD16 aLIGNMENT_WORD16 = ALIGNMENT_WORD16 sIZEOF_INT32 = SIZEOF_INT32 aLIGNMENT_INT32 = ALIGNMENT_INT32 sIZEOF_WORD32 = SIZEOF_WORD32 aLIGNMENT_WORD32 = ALIGNMENT_WORD32 sIZEOF_INT64 = SIZEOF_INT64 aLIGNMENT_INT64 = ALIGNMENT_INT64 sIZEOF_WORD64 = SIZEOF_WORD64 aLIGNMENT_WORD64 = ALIGNMENT_WORD64 #if WORD_SIZE_IN_BITS == 32 type Word64_# = Word64# type Int64_# = Int64# #else type Word64_# = Word# type Int64_# = Int# #endif primitive-0.6.2.0/Data/Primitive/Internal/0000755000000000000000000000000013014454612016450 5ustar0000000000000000primitive-0.6.2.0/Data/Primitive/Internal/Compat.hs0000644000000000000000000000123713014454612020232 0ustar0000000000000000{-# LANGUAGE CPP, MagicHash #-} -- | -- Module : Data.Primitive.Internal.Compat -- Copyright : (c) Roman Leshchinskiy 2011-2012 -- License : BSD-style -- -- Maintainer : Roman Leshchinskiy -- Portability : non-portable -- -- Compatibility functions -- module Data.Primitive.Internal.Compat ( isTrue# , mkNoRepType ) where #if MIN_VERSION_base(4,2,0) import Data.Data (mkNoRepType) #else import Data.Data (mkNorepType) #endif #if MIN_VERSION_base(4,7,0) import GHC.Exts (isTrue#) #endif #if !MIN_VERSION_base(4,2,0) mkNoRepType = mkNorepType #endif #if !MIN_VERSION_base(4,7,0) isTrue# :: Bool -> Bool isTrue# b = b #endif primitive-0.6.2.0/Data/Primitive/Internal/Operations.hs0000644000000000000000000001172713014454612021137 0ustar0000000000000000{-# LANGUAGE MagicHash, UnliftedFFITypes #-} -- | -- Module : Data.Primitive.Internal.Operations -- Copyright : (c) Roman Leshchinskiy 2011-2012 -- License : BSD-style -- -- Maintainer : Roman Leshchinskiy -- Portability : non-portable -- -- Internal operations -- module Data.Primitive.Internal.Operations ( setWord8Array#, setWord16Array#, setWord32Array#, setWord64Array#, setWordArray#, setInt8Array#, setInt16Array#, setInt32Array#, setInt64Array#, setIntArray#, setAddrArray#, setFloatArray#, setDoubleArray#, setWideCharArray#, setWord8OffAddr#, setWord16OffAddr#, setWord32OffAddr#, setWord64OffAddr#, setWordOffAddr#, setInt8OffAddr#, setInt16OffAddr#, setInt32OffAddr#, setInt64OffAddr#, setIntOffAddr#, setAddrOffAddr#, setFloatOffAddr#, setDoubleOffAddr#, setWideCharOffAddr# ) where import Data.Primitive.MachDeps (Word64_#, Int64_#) import Foreign.C.Types import GHC.Prim foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word8" setWord8Array# :: MutableByteArray# s -> CPtrdiff -> CSize -> Word# -> IO () foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word16" setWord16Array# :: MutableByteArray# s -> CPtrdiff -> CSize -> Word# -> IO () foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word32" setWord32Array# :: MutableByteArray# s -> CPtrdiff -> CSize -> Word# -> IO () foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word64" setWord64Array# :: MutableByteArray# s -> CPtrdiff -> CSize -> Word64_# -> IO () foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word" setWordArray# :: MutableByteArray# s -> CPtrdiff -> CSize -> Word# -> IO () foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word8" setInt8Array# :: MutableByteArray# s -> CPtrdiff -> CSize -> Int# -> IO () foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word16" setInt16Array# :: MutableByteArray# s -> CPtrdiff -> CSize -> Int# -> IO () foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word32" setInt32Array# :: MutableByteArray# s -> CPtrdiff -> CSize -> Int# -> IO () foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word64" setInt64Array# :: MutableByteArray# s -> CPtrdiff -> CSize -> Int64_# -> IO () foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word" setIntArray# :: MutableByteArray# s -> CPtrdiff -> CSize -> Int# -> IO () foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Ptr" setAddrArray# :: MutableByteArray# s -> CPtrdiff -> CSize -> Addr# -> IO () foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Float" setFloatArray# :: MutableByteArray# s -> CPtrdiff -> CSize -> Float# -> IO () foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Double" setDoubleArray# :: MutableByteArray# s -> CPtrdiff -> CSize -> Double# -> IO () foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Char" setWideCharArray# :: MutableByteArray# s -> CPtrdiff -> CSize -> Char# -> IO () foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word8" setWord8OffAddr# :: Addr# -> CPtrdiff -> CSize -> Word# -> IO () foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word16" setWord16OffAddr# :: Addr# -> CPtrdiff -> CSize -> Word# -> IO () foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word32" setWord32OffAddr# :: Addr# -> CPtrdiff -> CSize -> Word# -> IO () foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word64" setWord64OffAddr# :: Addr# -> CPtrdiff -> CSize -> Word64_# -> IO () foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word" setWordOffAddr# :: Addr# -> CPtrdiff -> CSize -> Word# -> IO () foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word8" setInt8OffAddr# :: Addr# -> CPtrdiff -> CSize -> Int# -> IO () foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word16" setInt16OffAddr# :: Addr# -> CPtrdiff -> CSize -> Int# -> IO () foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word32" setInt32OffAddr# :: Addr# -> CPtrdiff -> CSize -> Int# -> IO () foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word64" setInt64OffAddr# :: Addr# -> CPtrdiff -> CSize -> Int64_# -> IO () foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word" setIntOffAddr# :: Addr# -> CPtrdiff -> CSize -> Int# -> IO () foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Ptr" setAddrOffAddr# :: Addr# -> CPtrdiff -> CSize -> Addr# -> IO () foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Float" setFloatOffAddr# :: Addr# -> CPtrdiff -> CSize -> Float# -> IO () foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Double" setDoubleOffAddr# :: Addr# -> CPtrdiff -> CSize -> Double# -> IO () foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Char" setWideCharOffAddr# :: Addr# -> CPtrdiff -> CSize -> Char# -> IO () primitive-0.6.2.0/test/0000755000000000000000000000000013014454612013032 5ustar0000000000000000primitive-0.6.2.0/test/main.hs0000644000000000000000000000132213014454612014310 0ustar0000000000000000{-# LANGUAGE MagicHash, UnboxedTuples #-} import Control.Monad.Primitive import Data.Primitive.Array import GHC.IO import GHC.Prim -- Since we only have a single test case right now, I'm going to avoid the -- issue of choosing a test framework for the moment. This also keeps the -- package as a whole light on dependencies. main :: IO () main = do arr <- newArray 1 'A' let unit = case writeArray arr 0 'B' of IO f -> case f realWorld# of (# _, _ #) -> () c1 <- readArray arr 0 return $! unit c2 <- readArray arr 0 if c1 == 'A' && c2 == 'B' then return () else error $ "Expected AB, got: " ++ show (c1, c2) primitive-0.6.2.0/Control/0000755000000000000000000000000013014454612013473 5ustar0000000000000000primitive-0.6.2.0/Control/Monad/0000755000000000000000000000000013014454612014531 5ustar0000000000000000primitive-0.6.2.0/Control/Monad/Primitive.hs0000644000000000000000000002030013014454612017030 0ustar0000000000000000{-# LANGUAGE CPP, MagicHash, UnboxedTuples, TypeFamilies #-} {-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-} {-# LANGUAGE ScopedTypeVariables #-} -- | -- Module : Control.Monad.Primitive -- Copyright : (c) Roman Leshchinskiy 2009 -- License : BSD-style -- -- Maintainer : Roman Leshchinskiy -- Portability : non-portable -- -- Primitive state-transformer monads -- module Control.Monad.Primitive ( PrimMonad(..), RealWorld, primitive_, PrimBase(..), liftPrim, primToPrim, primToIO, primToST, ioToPrim, stToPrim, unsafePrimToPrim, unsafePrimToIO, unsafePrimToST, unsafeIOToPrim, unsafeSTToPrim, unsafeInlinePrim, unsafeInlineIO, unsafeInlineST, touch, evalPrim ) where import GHC.Prim ( State#, RealWorld, touch# ) import GHC.Base ( unsafeCoerce#, realWorld# ) #if MIN_VERSION_base(4,4,0) import GHC.Base ( seq# ) #else import Control.Exception (evaluate) #endif #if MIN_VERSION_base(4,2,0) import GHC.IO ( IO(..) ) #else import GHC.IOBase ( IO(..) ) #endif import GHC.ST ( ST(..) ) import Control.Monad.Trans.Class (lift) #if !MIN_VERSION_base(4,8,0) import Data.Monoid (Monoid) #endif import Control.Monad.Trans.Identity ( IdentityT (IdentityT) ) import Control.Monad.Trans.List ( ListT ) import Control.Monad.Trans.Maybe ( MaybeT ) import Control.Monad.Trans.Error ( ErrorT, Error) import Control.Monad.Trans.Reader ( ReaderT ) import Control.Monad.Trans.State ( StateT ) import Control.Monad.Trans.Writer ( WriterT ) import Control.Monad.Trans.RWS ( RWST ) #if MIN_VERSION_transformers(0,4,0) import Control.Monad.Trans.Except ( ExceptT ) #endif import qualified Control.Monad.Trans.RWS.Strict as Strict ( RWST ) import qualified Control.Monad.Trans.State.Strict as Strict ( StateT ) import qualified Control.Monad.Trans.Writer.Strict as Strict ( WriterT ) -- | Class of monads which can perform primitive state-transformer actions class Monad m => PrimMonad m where -- | State token type type PrimState m -- | Execute a primitive operation primitive :: (State# (PrimState m) -> (# State# (PrimState m), a #)) -> m a -- | Class of primitive monads for state-transformer actions. -- -- Unlike 'PrimMonad', this typeclass requires that the @Monad@ be fully -- expressed as a state transformer, therefore disallowing other monad -- transformers on top of the base @IO@ or @ST@. class PrimMonad m => PrimBase m where -- | Expose the internal structure of the monad internal :: m a -> State# (PrimState m) -> (# State# (PrimState m), a #) -- | Execute a primitive operation with no result primitive_ :: PrimMonad m => (State# (PrimState m) -> State# (PrimState m)) -> m () {-# INLINE primitive_ #-} primitive_ f = primitive (\s# -> case f s# of s'# -> (# s'#, () #)) instance PrimMonad IO where type PrimState IO = RealWorld primitive = IO {-# INLINE primitive #-} instance PrimBase IO where internal (IO p) = p {-# INLINE internal #-} instance PrimMonad m => PrimMonad (IdentityT m) where type PrimState (IdentityT m) = PrimState m primitive = lift . primitive {-# INLINE primitive #-} instance PrimBase m => PrimBase (IdentityT m) where internal (IdentityT m) = internal m {-# INLINE internal #-} instance PrimMonad m => PrimMonad (ListT m) where type PrimState (ListT m) = PrimState m primitive = lift . primitive {-# INLINE primitive #-} instance PrimMonad m => PrimMonad (MaybeT m) where type PrimState (MaybeT m) = PrimState m primitive = lift . primitive {-# INLINE primitive #-} instance (Error e, PrimMonad m) => PrimMonad (ErrorT e m) where type PrimState (ErrorT e m) = PrimState m primitive = lift . primitive {-# INLINE primitive #-} instance PrimMonad m => PrimMonad (ReaderT r m) where type PrimState (ReaderT r m) = PrimState m primitive = lift . primitive {-# INLINE primitive #-} instance PrimMonad m => PrimMonad (StateT s m) where type PrimState (StateT s m) = PrimState m primitive = lift . primitive {-# INLINE primitive #-} instance (Monoid w, PrimMonad m) => PrimMonad (WriterT w m) where type PrimState (WriterT w m) = PrimState m primitive = lift . primitive {-# INLINE primitive #-} instance (Monoid w, PrimMonad m) => PrimMonad (RWST r w s m) where type PrimState (RWST r w s m) = PrimState m primitive = lift . primitive {-# INLINE primitive #-} #if MIN_VERSION_transformers(0,4,0) instance PrimMonad m => PrimMonad (ExceptT e m) where type PrimState (ExceptT e m) = PrimState m primitive = lift . primitive {-# INLINE primitive #-} #endif instance PrimMonad m => PrimMonad (Strict.StateT s m) where type PrimState (Strict.StateT s m) = PrimState m primitive = lift . primitive {-# INLINE primitive #-} instance (Monoid w, PrimMonad m) => PrimMonad (Strict.WriterT w m) where type PrimState (Strict.WriterT w m) = PrimState m primitive = lift . primitive {-# INLINE primitive #-} instance (Monoid w, PrimMonad m) => PrimMonad (Strict.RWST r w s m) where type PrimState (Strict.RWST r w s m) = PrimState m primitive = lift . primitive {-# INLINE primitive #-} instance PrimMonad (ST s) where type PrimState (ST s) = s primitive = ST {-# INLINE primitive #-} instance PrimBase (ST s) where internal (ST p) = p {-# INLINE internal #-} -- | Lifts a 'PrimBase' into another 'PrimMonad' with the same underlying state -- token type. liftPrim :: (PrimBase m1, PrimMonad m2, PrimState m1 ~ PrimState m2) => m1 a -> m2 a {-# INLINE liftPrim #-} liftPrim = primToPrim -- | Convert a 'PrimBase' to another monad with the same state token. primToPrim :: (PrimBase m1, PrimMonad m2, PrimState m1 ~ PrimState m2) => m1 a -> m2 a {-# INLINE primToPrim #-} primToPrim m = primitive (internal m) -- | Convert a 'PrimBase' with a 'RealWorld' state token to 'IO' primToIO :: (PrimBase m, PrimState m ~ RealWorld) => m a -> IO a {-# INLINE primToIO #-} primToIO = primToPrim -- | Convert a 'PrimBase' to 'ST' primToST :: PrimBase m => m a -> ST (PrimState m) a {-# INLINE primToST #-} primToST = primToPrim -- | Convert an 'IO' action to a 'PrimMonad'. ioToPrim :: (PrimMonad m, PrimState m ~ RealWorld) => IO a -> m a {-# INLINE ioToPrim #-} ioToPrim = primToPrim -- | Convert an 'ST' action to a 'PrimMonad'. stToPrim :: PrimMonad m => ST (PrimState m) a -> m a {-# INLINE stToPrim #-} stToPrim = primToPrim -- | Convert a 'PrimBase' to another monad with a possibly different state -- token. This operation is highly unsafe! unsafePrimToPrim :: (PrimBase m1, PrimMonad m2) => m1 a -> m2 a {-# INLINE unsafePrimToPrim #-} unsafePrimToPrim m = primitive (unsafeCoerce# (internal m)) -- | Convert any 'PrimBase' to 'ST' with an arbitrary state token. This -- operation is highly unsafe! unsafePrimToST :: PrimBase m => m a -> ST s a {-# INLINE unsafePrimToST #-} unsafePrimToST = unsafePrimToPrim -- | Convert any 'PrimBase' to 'IO'. This operation is highly unsafe! unsafePrimToIO :: PrimBase m => m a -> IO a {-# INLINE unsafePrimToIO #-} unsafePrimToIO = unsafePrimToPrim -- | Convert an 'ST' action with an arbitraty state token to any 'PrimMonad'. -- This operation is highly unsafe! unsafeSTToPrim :: PrimMonad m => ST s a -> m a {-# INLINE unsafeSTToPrim #-} unsafeSTToPrim = unsafePrimToPrim -- | Convert an 'IO' action to any 'PrimMonad'. This operation is highly -- unsafe! unsafeIOToPrim :: PrimMonad m => IO a -> m a {-# INLINE unsafeIOToPrim #-} unsafeIOToPrim = unsafePrimToPrim unsafeInlinePrim :: PrimBase m => m a -> a {-# INLINE unsafeInlinePrim #-} unsafeInlinePrim m = unsafeInlineIO (unsafePrimToIO m) unsafeInlineIO :: IO a -> a {-# INLINE unsafeInlineIO #-} unsafeInlineIO m = case internal m realWorld# of (# _, r #) -> r unsafeInlineST :: ST s a -> a {-# INLINE unsafeInlineST #-} unsafeInlineST = unsafeInlinePrim touch :: PrimMonad m => a -> m () {-# INLINE touch #-} touch x = unsafePrimToPrim $ (primitive (\s -> case touch# x s of { s' -> (# s', () #) }) :: IO ()) -- | Create an action to force a value; generalizes 'Control.Exception.evaluate' evalPrim :: forall a m . PrimMonad m => a -> m a #if MIN_VERSION_base(4,4,0) evalPrim a = primitive (\s -> seq# a s) #else -- This may or may not work so well, but there's probably nothing better to do. {-# NOINLINE evalPrim #-} evalPrim a = unsafePrimToPrim (evaluate a :: IO a) #endif primitive-0.6.2.0/cbits/0000755000000000000000000000000013014454612013157 5ustar0000000000000000primitive-0.6.2.0/cbits/primitive-memops.h0000644000000000000000000000170213014454612016636 0ustar0000000000000000#ifndef haskell_primitive_memops_h #define haskell_primitive_memops_h #include #include #include void hsprimitive_memcpy( void *dst, ptrdiff_t doff, void *src, ptrdiff_t soff, size_t len ); void hsprimitive_memmove( void *dst, ptrdiff_t doff, void *src, ptrdiff_t soff, size_t len ); void hsprimitive_memset_Word8 (HsWord8 *, ptrdiff_t, size_t, HsWord); void hsprimitive_memset_Word16 (HsWord16 *, ptrdiff_t, size_t, HsWord); void hsprimitive_memset_Word32 (HsWord32 *, ptrdiff_t, size_t, HsWord); void hsprimitive_memset_Word64 (HsWord64 *, ptrdiff_t, size_t, HsWord64); void hsprimitive_memset_Word (HsWord *, ptrdiff_t, size_t, HsWord); void hsprimitive_memset_Ptr (HsPtr *, ptrdiff_t, size_t, HsPtr); void hsprimitive_memset_Float (HsFloat *, ptrdiff_t, size_t, HsFloat); void hsprimitive_memset_Double (HsDouble *, ptrdiff_t, size_t, HsDouble); void hsprimitive_memset_Char (HsChar *, ptrdiff_t, size_t, HsChar); #endif primitive-0.6.2.0/cbits/primitive-memops.c0000644000000000000000000000460413014454612016635 0ustar0000000000000000#include #include "primitive-memops.h" void hsprimitive_memcpy( void *dst, ptrdiff_t doff, void *src, ptrdiff_t soff, size_t len ) { memcpy( (char *)dst + doff, (char *)src + soff, len ); } void hsprimitive_memmove( void *dst, ptrdiff_t doff, void *src, ptrdiff_t soff, size_t len ) { memmove( (char *)dst + doff, (char *)src + soff, len ); } #define MEMSET(TYPE, ATYPE) \ void hsprimitive_memset_ ## TYPE (Hs ## TYPE *p, ptrdiff_t off, size_t n, ATYPE x) \ { \ p += off; \ if (x == 0) \ memset(p, 0, n * sizeof(Hs ## TYPE)); \ else if (sizeof(Hs ## TYPE) == sizeof(int)*2) { \ int *q = (int *)p; \ const int *r = (const int *)(void *)&x; \ while (n>0) { \ q[0] = r[0]; \ q[1] = r[1]; \ q += 2; \ --n; \ } \ } \ else { \ while (n>0) { \ *p++ = x; \ --n; \ } \ } \ } void hsprimitive_memset_Word8 (HsWord8 *p, ptrdiff_t off, size_t n, HsWord x) { memset( (char *)(p+off), x, n ); } /* MEMSET(HsWord8, HsWord) */ MEMSET(Word16, HsWord) MEMSET(Word32, HsWord) MEMSET(Word64, HsWord64) MEMSET(Word, HsWord) MEMSET(Ptr, HsPtr) MEMSET(Float, HsFloat) MEMSET(Double, HsDouble) MEMSET(Char, HsChar)