primitive 0.6.1.2 → 0.6.2.0
raw patch · 8 files changed
+1460/−47 lines, 8 filesdep ~basedep ~ghc-prim
Dependency ranges changed: base, ghc-prim
Files
- Control/Monad/Primitive.hs +45/−5
- Data/Primitive/Array.hs +385/−28
- Data/Primitive/MutVar.hs +1/−6
- Data/Primitive/SmallArray.hs +628/−0
- Data/Primitive/Types.hs +11/−1
- Data/Primitive/UnliftedArray.hs +365/−0
- changelog.md +19/−0
- primitive.cabal +6/−7
Control/Monad/Primitive.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE CPP, MagicHash, UnboxedTuples, TypeFamilies #-} {-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-}+{-# LANGUAGE ScopedTypeVariables #-} -- | -- Module : Control.Monad.Primitive@@ -15,14 +16,19 @@ module Control.Monad.Primitive ( PrimMonad(..), RealWorld, primitive_, PrimBase(..),- liftPrim, primToPrim, primToIO, primToST,- unsafePrimToPrim, unsafePrimToIO, unsafePrimToST,- unsafeInlinePrim, unsafeInlineIO, unsafeInlineST,- touch+ 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@@ -35,7 +41,7 @@ import Data.Monoid (Monoid) #endif -import Control.Monad.Trans.Identity ( IdentityT)+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)@@ -89,6 +95,9 @@ 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@@ -169,6 +178,16 @@ {-# 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@@ -186,6 +205,18 @@ {-# 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)@@ -203,3 +234,12 @@ 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
Data/Primitive/Array.hs view
@@ -1,4 +1,6 @@ {-# LANGUAGE CPP, MagicHash, UnboxedTuples, DeriveDataTypeable, BangPatterns #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-} -- | -- Module : Data.Primitive.Array@@ -8,60 +10,106 @@ -- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> -- Portability : non-portable ----- Primitive boxed arrays+-- 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+ 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(..) )+import Data.Data+ (Data(..), DataType, mkDataType, Constr, mkConstr, Fixity(..), constrIndex) import Data.Primitive.Internal.Compat ( isTrue#, mkNoRepType ) -#if !(__GLASGOW_HASKELL__ >= 702)-import Control.Monad.ST(runST)+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# a) deriving ( Typeable )+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 (MutableArray# s a)- deriving ( Typeable )+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# #) -> (# s'#, MutableArray arr# #))+ (# 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 (MutableArray arr#) (I# i#) = primitive (readArray# arr# i#)+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 (MutableArray arr#) (I# i#) x = primitive_ (writeArray# arr# i# x)+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 (Array arr#) (I# i#) = case indexArray# arr# i# of (# x #) -> x+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@@ -88,30 +136,84 @@ -- indexArrayM :: Monad m => Array a -> Int -> m a {-# INLINE indexArrayM #-}-indexArrayM (Array arr#) (I# i#)- = case indexArray# arr# i# of (# x #) -> return x+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 (MutableArray arr#)- = primitive (\s# -> case unsafeFreezeArray# arr# s# of- (# s'#, arr'# #) -> (# s'#, Array arr'# #))+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 (Array arr#)- = primitive (\s# -> case unsafeThawArray# arr# s# of- (# s'#, arr'# #) -> (# s'#, MutableArray arr'# #))+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 (MutableArray arr#) (MutableArray brr#)- = isTrue# (sameMutableArray# arr# brr#)+sameMutableArray arr brr+ = isTrue# (sameMutableArray# (marray# arr) (marray# brr)) -- | Copy a slice of an immutable array to a mutable array. copyArray :: PrimMonad m@@ -174,7 +276,7 @@ = case cloneArray# arr# off# len# of arr'# -> Array arr'# #else cloneArray arr off len = runST $ do- marr2 <- newArray len (error "Undefined element")+ marr2 <- newArray len $ die "cloneArray" "impossible" copyArray marr2 0 arr off len unsafeFreezeArray marr2 #endif@@ -194,7 +296,7 @@ (# s'#, arr'# #) -> (# s'#, MutableArray arr'# #)) #else cloneMutableArray marr off len = do- marr2 <- newArray len (error "Undefined element")+ marr2 <- newArray len $ die "cloneMutableArray" "impossible" let go !i !j c | c >= len = return marr2 | otherwise = do@@ -204,10 +306,265 @@ go off 0 0 #endif -instance Typeable a => Data (Array a) where- toConstr _ = error "toConstr"- gunfold _ _ = error "gunfold"- dataTypeOf _ = mkNoRepType "Data.Primitive.Array.Array"+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"
Data/Primitive/MutVar.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE MagicHash, UnboxedTuples, DeriveDataTypeable, CPP #-}+{-# LANGUAGE MagicHash, UnboxedTuples, DeriveDataTypeable #-} -- | -- Module : Data.Primitive.MutVar@@ -25,13 +25,8 @@ ) where import Control.Monad.Primitive ( PrimMonad(..), primitive_ )-#if MIN_VERSION_base(4,11,0)-import GHC.Exts ( MutVar#, sameMutVar#, newMutVar#,- readMutVar#, writeMutVar#, atomicModifyMutVar# )-#else import GHC.Prim ( MutVar#, sameMutVar#, newMutVar#, readMutVar#, writeMutVar#, atomicModifyMutVar# )-#endif import Data.Primitive.Internal.Compat ( isTrue# ) import Data.Typeable ( Typeable )
+ Data/Primitive/SmallArray.hs view
@@ -0,0 +1,628 @@+{-# 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
Data/Primitive/Types.hs view
@@ -34,6 +34,10 @@ Int8(..), Int16(..), Int32(..), Int64(..) ) +import GHC.Ptr (+ Ptr(..), FunPtr(..)+ )+ import GHC.Prim #if __GLASGOW_HASKELL__ >= 706 hiding (setByteArray#)@@ -105,7 +109,7 @@ 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 { \+instance Prim (ty) where { \ sizeOf# _ = unI# sz \ ; alignment# _ = unI# align \ ; indexByteArray# arr# i# = ctr (idx_arr arr# i#) \@@ -184,5 +188,11 @@ 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#)
+ Data/Primitive/UnliftedArray.hs view
@@ -0,0 +1,365 @@+{-# Language MagicHash #-}+{-# Language UnboxedTuples #-}+{-# Language DeriveDataTypeable #-}++-- |+-- Module : Data.Primitive.UnliftedArray+-- Copyright : (c) Dan Doel 2016+-- License : BSD-style+--+-- Maintainer : Libraries <libraries@haskell.org>+-- 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)
changelog.md view
@@ -1,3 +1,22 @@+## 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
primitive.cabal view
@@ -1,5 +1,5 @@ Name: primitive-Version: 0.6.1.2+Version: 0.6.2.0 License: BSD3 License-File: LICENSE @@ -21,10 +21,7 @@ GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3,- GHC == 8.0.2,- GHC == 8.2.2,- GHC == 8.4.4,- GHC == 8.6.2+ GHC == 8.0.1 Library Default-Language: Haskell2010@@ -39,6 +36,8 @@ Data.Primitive.Types Data.Primitive.Array Data.Primitive.ByteArray+ Data.Primitive.SmallArray+ Data.Primitive.UnliftedArray Data.Primitive.Addr Data.Primitive.MutVar @@ -46,8 +45,8 @@ Data.Primitive.Internal.Compat Data.Primitive.Internal.Operations - Build-Depends: base >= 4.3 && < 4.13- , ghc-prim >= 0.2 && < 0.7+ Build-Depends: base >= 4.5 && < 4.10+ , ghc-prim >= 0.2 && < 0.6 , transformers >= 0.2 && < 0.6 Ghc-Options: -O2 -Wall