persistent-vector 0.1.0.1 → 0.1.0.3
raw patch · 5 files changed
+125/−81 lines, 5 filesdep ~criterion
Dependency ranges changed: criterion
Files
- bench/pvBench.hs +1/−2
- persistent-vector.cabal +3/−3
- src/Data/Vector/Persistent.hs +69/−39
- src/Data/Vector/Persistent/Array.hs +38/−34
- tests/pvTests.hs +14/−3
bench/pvBench.hs view
@@ -1,6 +1,5 @@ module Main ( main ) where -import Criterion.Config import Criterion.Main import Control.DeepSeq@@ -88,7 +87,7 @@ testVecBuild len = L.foldl' V.snoc V.empty [0..len] main :: IO ()-main = defaultMainWith defaultConfig setup [+main = setup >> defaultMain [ bgroup "traverse1000" [ bench "ListR1000" $ whnf testListRTraversal l1000 , bench "IMR1000" $ whnf testIMRTraversal im1000 , bench "SeqR1000" $ whnf testSeqRTraversal s1000
persistent-vector.cabal view
@@ -1,10 +1,10 @@ name: persistent-vector-version: 0.1.0.1+version: 0.1.0.3 synopsis: A persistent sequence based on array mapped tries license: BSD3 license-file: LICENSE author: Tristan Ravitch-maintainer: travitch@cs.wisc.edu+maintainer: tristan@nochair.net category: Data build-type: Simple cabal-version: >=1.10@@ -67,7 +67,7 @@ build-depends: persistent-vector, base == 4.*, containers,- criterion,+ criterion >= 1 && < 1.2, deepseq source-repository head
src/Data/Vector/Persistent.hs view
@@ -35,23 +35,22 @@ reverse, -- * Searches filter,- partition+ partition,+ takeWhile,+ dropWhile ) where import Prelude hiding ( null, length, tail, take, drop, map, foldr, reverse,- splitAt, filter+ splitAt, filter, takeWhile, dropWhile ) -import Control.Applicative hiding ( empty )+import qualified Control.Applicative as Ap import Control.DeepSeq import Data.Bits-import Data.Foldable ( Foldable ) import qualified Data.Foldable as F import qualified Data.List as L-import Data.Monoid ( Monoid ) import qualified Data.Monoid as M-import Data.Traversable ( Traversable ) import qualified Data.Traversable as T import Data.Vector.Persistent.Array ( Array )@@ -67,11 +66,11 @@ , vecOffset :: {-# UNPACK #-} !Int , vecCapacity :: {-# UNPACK #-} !Int , vecTail :: ![a]- , intVecPtrs :: !(Array (Vector a))+ , intVecPtrs :: {-# UNPACK #-} !(Array (Vector a)) }- | InternalNode { intVecPtrs :: !(Array (Vector a))+ | InternalNode { intVecPtrs :: {-# UNPACK #-} !(Array (Vector a)) }- | DataNode { dataVec :: !(Array a)+ | DataNode { dataVec :: {-# UNPACK #-} !(Array a) } deriving (Show) @@ -81,17 +80,17 @@ instance (Ord a) => Ord (Vector a) where compare = pvCompare -instance Foldable Vector where+instance F.Foldable Vector where foldr = foldr instance Functor Vector where fmap = map -instance Monoid (Vector a) where+instance M.Monoid (Vector a) where mempty = empty mappend = append -instance Traversable Vector where+instance T.Traversable Vector where traverse = pvTraverse instance (NFData a) => NFData (Vector a) where@@ -168,6 +167,9 @@ v' = A.map (fmap f) v in RootNode sz sh off cap t' v' +-- | A more strict 3 tuple for the folds+data FoldInfo a = FI a !Int !Int+ {-# INLINABLE foldr #-} -- | O(n) Right fold over the vector foldr :: (a -> b -> b) -> b -> Vector a -> b@@ -175,25 +177,25 @@ foldr f s0 v | isNotSliced v = sgo v s0 | otherwise =- case go v (s0, max 0 (vecCapacity v - vecSize v), length v) of (r, _, _) -> r+ case go v (FI s0 (max 0 (vecCapacity v - vecSize v)) (length v)) of (FI r _ _) -> r where go EmptyVector seed = seed- go (DataNode a) (seed, nskip, len)- | len <= 0 = (seed, 0, 0)- | nskip == 0 = (A.boundedFoldr f (32 - len) 32 seed a, 0, len - A.length a)- | nskip >= 32 = (seed, nskip - 32, len)+ go (DataNode a) s@(FI seed nskip len)+ | len <= 0 = s+ | nskip == 0 = FI (A.boundedFoldr f (32 - len) 32 seed a) 0 (len - A.length a)+ | nskip >= 32 = FI seed (nskip - 32) len | otherwise = let end = min (max 0 (32 - nskip)) 32 start = 32 - (len + nskip) taken = end - max 0 start- in (A.boundedFoldr f start end seed a, 0, len - taken)+ in FI (A.boundedFoldr f start end seed a) 0 (len - taken) go (InternalNode as) seed = A.foldr go seed as -- Note: if there is a tail at all, the elements are live (slice -- drops unused tail elements)- go (RootNode _ _ _ _ t as) (s, nskip, l) =+ go (RootNode _ _ _ _ t as) (FI s nskip l) = let tseed = L.foldl' (flip f) s t- seed = (tseed, nskip, l - L.length t)+ seed = FI tseed nskip (l - L.length t) in A.foldr go seed as -- A simpler variant for unsliced vectors (the common case) that is@@ -212,23 +214,23 @@ foldl' f s0 v | isNotSliced v = sgo s0 v | otherwise =- case go (s0, vecOffset v, length v) v of (r, _, _) -> r+ case go (FI s0 (vecOffset v) (length v)) v of (FI r _ _) -> r where go seed EmptyVector = seed- go (seed, nskip, len) (DataNode a)- | len <= 0 = (seed, 0, 0)- | nskip == 0 = (A.boundedFoldl' f 0 (min len 32) seed a, 0, len - A.length a)- | nskip >= 32 = (seed, nskip - 32, len)+ go s@(FI seed nskip len) (DataNode a)+ | len <= 0 = s+ | nskip == 0 = FI (A.boundedFoldl' f 0 (min len 32) seed a) 0 (len - A.length a)+ | nskip >= 32 = FI seed (nskip - 32) len | otherwise = let end = min 32 (len + nskip) start = nskip taken = end - max 0 start- in (A.boundedFoldl' f start end seed a, 0, len - taken)+ in FI (A.boundedFoldl' f start end seed a) 0 (len - taken) go seed (InternalNode as) = A.foldl' go seed as- go (s, nskip, l) (RootNode _ _ _ _ t as) =- let (rseed, _, _) = A.foldl' go (s, nskip, l - L.length t) as- in (L.foldr (flip f) rseed t, 0, 0)+ go (FI s nskip l) (RootNode _ _ _ _ t as) =+ let FI rseed _ _ = A.foldl' go (FI s nskip (l - L.length t)) as+ in FI (L.foldr (flip f) rseed t) 0 0 sgo seed EmptyVector = seed sgo seed (DataNode a) = A.foldl' f seed a@@ -239,20 +241,20 @@ in F.foldr (flip f) rseed t {-# INLINABLE pvTraverse #-}-pvTraverse :: (Applicative f) => (a -> f b) -> Vector a -> f (Vector b)+pvTraverse :: (Ap.Applicative f) => (a -> f b) -> Vector a -> f (Vector b) pvTraverse f = go where go EmptyVector = pure EmptyVector- go (DataNode a) = DataNode <$> A.traverse f a- go (InternalNode as) = InternalNode <$> A.traverse go as+ go (DataNode a) = DataNode <$> A.traverseArray f a+ go (InternalNode as) = InternalNode <$> A.traverseArray go as go (RootNode sz sh off cap t as) =- RootNode sz sh off cap <$> T.traverse f t <*> A.traverse go as+ RootNode sz sh off cap <$> T.traverse f t <*> A.traverseArray go as {-# INLINABLE append #-} append :: Vector a -> Vector a -> Vector a append EmptyVector v = v append v EmptyVector = v-append v1 v2 = F.foldl' snoc v1 (F.toList v2)+append v1 v2 = foldl' snoc v1 v2 {-# INLINABLE pvRnf #-} pvRnf :: (NFData a) => Vector a -> ()@@ -286,10 +288,11 @@ -- usually just return nonsense values. unsafeIndex :: Vector a -> Int -> a unsafeIndex vec userIndex--- | tailOffset vec < vecOffset vec = L.reverse (vecTail vec) !! (userIndex .&. 0x1f) | ix >= tailOffset vec && vecCapacity vec < vecSize vec = L.reverse (vecTail vec) !! (ix .&. 0x1f)- | otherwise = go (vecShift vec) vec+ | otherwise =+ let sh = vecShift vec+ in go (sh - 5) (A.index (intVecPtrs vec) (ix `shiftR` sh)) where -- The user is indexing from zero but there could be some masked -- portion of the vector due to the offset - we have to correct to@@ -527,14 +530,41 @@ -- | O(n) Return the elements that do and do not obey the predicate partition :: (a -> Bool) -> Vector a -> (Vector a, Vector a)-partition p = foldl' go (empty, empty)+partition p = spToPair . foldl' go (SP empty empty) where- go (atrue, afalse) e =- if p e then (snoc atrue e, afalse) else (atrue, snoc afalse e)+ go (SP atrue afalse) e =+ if p e then SP (snoc atrue e) afalse else SP atrue (snoc afalse e) -- | O(n) Construct a vector from a list. fromList :: [a] -> Vector a fromList = F.foldl' snoc empty++data StrictPair a b = SP !a !b++spSnd :: StrictPair a b -> b+spSnd (SP _ v) = v++spToPair :: StrictPair a b -> (a, b)+spToPair (SP a b) = (a, b)++-- | O(n) Apply a predicate @p@ to the vector, returning the longest+-- prefix of elements that satisfy @p@.+takeWhile :: (a -> Bool) -> Vector a -> Vector a+takeWhile p = spSnd . foldl' f (SP True empty)+ where+ f (SP True v) e =+ if p e then SP True (snoc v e)+ else SP False v+ f a _ = a++-- | O(n) Returns the longest suffix after @takeWhile p v@.+dropWhile :: (a -> Bool) -> Vector a -> Vector a+dropWhile p = spSnd . foldl' f (SP True empty)+ where+ f a@(SP True v) e =+ if p e then a+ else SP False (snoc v e)+ f (SP False v) e = SP False (snoc v e) -- Helpers
src/Data/Vector/Persistent/Array.hs view
@@ -1,8 +1,12 @@ {-# LANGUAGE BangPatterns, CPP, MagicHash, Rank2Types, UnboxedTuples #-} {-# OPTIONS_GHC -fno-full-laziness -funbox-strict-fields #-}---- | Zero based arrays.+-- |+-- Module: Data.Vector.Persistent.Array+-- Copyright: Johan Tibell <johan.tibell@gmail.com>+-- License: BSD3 --+-- Zero based arrays.+-- -- Note that no bounds checking are performed. module Data.Vector.Persistent.Array ( Array@@ -48,17 +52,17 @@ , thaw , map , map'- , traverse+ , traverseArray , filter , fromList , toList ) where import qualified Data.Traversable as Traversable-import Control.Applicative (Applicative)+import qualified Control.Applicative as A import Control.DeepSeq import Control.Monad.ST hiding (runST)-import GHC.Exts+import qualified GHC.Exts as Ext import GHC.ST (ST(..)) import Prelude hiding (filter, foldr, length, map, read) import qualified Prelude as P@@ -84,7 +88,7 @@ #endif data Array a = Array {- unArray :: !(Array# a)+ unArray :: !(Ext.Array# a) #if __GLASGOW_HASKELL__ < 702 , length :: !Int #endif@@ -119,12 +123,12 @@ #if __GLASGOW_HASKELL__ >= 702 length :: Array a -> Int-length ary = I# (sizeofArray# (unArray ary))+length ary = Ext.I# (Ext.sizeofArray# (unArray ary)) {-# INLINE length #-} #endif -- | Smart constructor-array :: Array# a -> Int -> Array a+array :: Ext.Array# a -> Int -> Array a #if __GLASGOW_HASKELL__ >= 702 array ary _n = Array ary #else@@ -133,7 +137,7 @@ {-# INLINE array #-} data MArray s a = MArray {- unMArray :: !(MutableArray# s a)+ unMArray :: !(Ext.MutableArray# s a) #if __GLASGOW_HASKELL__ < 702 , lengthM :: !Int #endif@@ -141,12 +145,12 @@ #if __GLASGOW_HASKELL__ >= 702 lengthM :: MArray s a -> Int-lengthM mary = I# (sizeofMutableArray# (unMArray mary))+lengthM mary = Ext.I# (Ext.sizeofMutableArray# (unMArray mary)) {-# INLINE lengthM #-} #endif -- | Smart constructor-marray :: MutableArray# s a -> Int -> MArray s a+marray :: Ext.MutableArray# s a -> Int -> MArray s a #if __GLASGOW_HASKELL__ >= 702 marray mary _n = MArray mary #else@@ -172,10 +176,10 @@ -- state thread, with each element containing the specified initial -- value. new :: Int -> a -> ST s (MArray s a)-new n@(I# n#) b =+new n@(Ext.I# n#) b = CHECK_GT("new",n,(0 :: Int)) ST $ \s ->- case newArray# n# b s of+ case Ext.newArray# n# b s of (# s', ary #) -> (# s', marray ary n #) {-# INLINE new #-} @@ -198,45 +202,45 @@ {-# INLINE pair #-} read :: MArray s a -> Int -> ST s a-read ary _i@(I# i#) = ST $ \ s ->+read ary _i@(Ext.I# i#) = ST $ \ s -> CHECK_BOUNDS("read", lengthM ary, _i)- readArray# (unMArray ary) i# s+ Ext.readArray# (unMArray ary) i# s {-# INLINE read #-} write :: MArray s a -> Int -> a -> ST s ()-write ary _i@(I# i#) b = ST $ \ s ->+write ary _i@(Ext.I# i#) b = ST $ \ s -> CHECK_BOUNDS("write", lengthM ary, _i)- case writeArray# (unMArray ary) i# b s of+ case Ext.writeArray# (unMArray ary) i# b s of s' -> (# s' , () #) {-# INLINE write #-} index :: Array a -> Int -> a-index ary _i@(I# i#) =+index ary _i@(Ext.I# i#) = CHECK_BOUNDS("index", length ary, _i)- case indexArray# (unArray ary) i# of (# b #) -> b+ case Ext.indexArray# (unArray ary) i# of (# b #) -> b {-# INLINE index #-} index_ :: Array a -> Int -> ST s a-index_ ary _i@(I# i#) =+index_ ary _i@(Ext.I# i#) = CHECK_BOUNDS("index_", length ary, _i)- case indexArray# (unArray ary) i# of (# b #) -> return b+ case Ext.indexArray# (unArray ary) i# of (# b #) -> return b {-# INLINE index_ #-} indexM_ :: MArray s a -> Int -> ST s a-indexM_ ary _i@(I# i#) =+indexM_ ary _i@(Ext.I# i#) = CHECK_BOUNDS("index_", lengthM ary, _i)- ST $ \ s# -> readArray# (unMArray ary) i# s#+ ST $ \ s# -> Ext.readArray# (unMArray ary) i# s# {-# INLINE indexM_ #-} unsafeFreeze :: MArray s a -> ST s (Array a) unsafeFreeze mary- = ST $ \s -> case unsafeFreezeArray# (unMArray mary) s of+ = ST $ \s -> case Ext.unsafeFreezeArray# (unMArray mary) s of (# s', ary #) -> (# s', array ary (lengthM mary) #) {-# INLINE unsafeFreeze #-} unsafeThaw :: Array a -> ST s (MArray s a) unsafeThaw ary- = ST $ \s -> case unsafeThawArray# (unArray ary) s of+ = ST $ \s -> case Ext.unsafeThawArray# (unArray ary) s of (# s', mary #) -> (# s', marray mary (length ary) #) {-# INLINE unsafeThaw #-} @@ -253,11 +257,11 @@ -- | Unsafely copy the elements of an array. Array bounds are not checked. copy :: Array e -> Int -> MArray s e -> Int -> Int -> ST s () #if __GLASGOW_HASKELL__ >= 702-copy !src !_sidx@(I# sidx#) !dst !_didx@(I# didx#) _n@(I# n#) =+copy !src !_sidx@(Ext.I# sidx#) !dst !_didx@(Ext.I# didx#) _n@(Ext.I# n#) = CHECK_LE("copy", _sidx + _n, length src) CHECK_LE("copy", _didx + _n, lengthM dst) ST $ \ s# ->- case copyArray# (unArray src) sidx# (unMArray dst) didx# n# s# of+ case Ext.copyArray# (unArray src) sidx# (unMArray dst) didx# n# s# of s2 -> (# s2, () #) #else copy !src !sidx !dst !didx n =@@ -275,11 +279,11 @@ -- | Unsafely copy the elements of an array. Array bounds are not checked. copyM :: MArray s e -> Int -> MArray s e -> Int -> Int -> ST s () #if __GLASGOW_HASKELL__ >= 702-copyM !src !_sidx@(I# sidx#) !dst !_didx@(I# didx#) _n@(I# n#) =+copyM !src !_sidx@(Ext.I# sidx#) !dst !_didx@(Ext.I# didx#) _n@(Ext.I# n#) = CHECK_BOUNDS("copyM: src", lengthM src, _sidx + _n - 1) CHECK_BOUNDS("copyM: dst", lengthM dst, _didx + _n - 1) ST $ \ s# ->- case copyMutableArray# (unMArray src) sidx# (unMArray dst) didx# n# s# of+ case Ext.copyMutableArray# (unMArray src) sidx# (unMArray dst) didx# n# s# of s2 -> (# s2, () #) #else copyM !src !sidx !dst !didx n =@@ -386,9 +390,9 @@ thaw :: Array e -> Int -> Int -> ST s (MArray s e) #if __GLASGOW_HASKELL__ >= 702-thaw !ary !_o@(I# o#) !n@(I# n#) =+thaw !ary !_o@(Ext.I# o#) !n@(Ext.I# n#) = CHECK_LE("thaw", _o + n, length ary)- ST $ \ s -> case thawArray# (unArray ary) o# n# s of+ ST $ \ s -> case Ext.thawArray# (unArray ary) o# n# s of (# s2, mary# #) -> (# s2, marray mary# n #) #else thaw !ary !o !n =@@ -457,10 +461,10 @@ toList :: Array a -> [a] toList = foldr (:) [] -traverse :: Applicative f => (a -> f b) -> Array a -> f (Array b)-traverse f = \ ary -> fromList (length ary) `fmap`+traverseArray :: A.Applicative f => (a -> f b) -> Array a -> f (Array b)+traverseArray f = \ ary -> fromList (length ary) `fmap` Traversable.traverse f (toList ary)-{-# INLINE traverse #-}+{-# INLINE traverseArray #-} filter :: (a -> Bool) -> Array a -> Array a filter p = \ ary ->
tests/pvTests.hs view
@@ -7,9 +7,6 @@ import qualified Data.Foldable as F import Data.Monoid import qualified Data.List as L-import qualified Data.Traversable as T--import Data.Vector.Persistent ( Vector ) import qualified Data.Vector.Persistent as V newtype InputList = InputList [Int]@@ -66,6 +63,8 @@ , testProperty "shrink" prop_shrinkPreserves , testProperty "shrinkEq" prop_shrinkEquality , testProperty "appendAfterSlice" prop_appendAfterSlice+ , testProperty "takeWhile" prop_takeWhile+ , testProperty "dropWhile" prop_dropWhile ] main :: IO ()@@ -155,3 +154,15 @@ where v0 = V.slice s n (V.fromList il) v1 = V.snoc v0 elt++prop_takeWhile :: IndexableList -> Bool+prop_takeWhile (IndexableList il ix) =+ L.takeWhile (<ix) il == F.toList v+ where+ v = V.takeWhile (<ix) $ V.fromList il++prop_dropWhile :: IndexableList -> Bool+prop_dropWhile (IndexableList il ix) =+ L.dropWhile (<ix) il == F.toList v+ where+ v = V.dropWhile (<ix) $ V.fromList il