diff --git a/Data/StorableVector.hs b/Data/StorableVector.hs --- a/Data/StorableVector.hs +++ b/Data/StorableVector.hs @@ -7,7 +7,7 @@ -- (c) Don Stewart 2005-2006 -- (c) Bjorn Bringert 2006 -- (c) Spencer Janssen 2006 --- (c) Henning Thielemann 2008-2009 +-- (c) Henning Thielemann 2008-2010 -- -- -- License : BSD-style @@ -184,7 +184,8 @@ ,scanl,scanl1,scanr,scanr1 ,readFile,writeFile,appendFile,replicate ,getContents,getLine,putStr,putStrLn - ,zip,zipWith,zipWith3,unzip,notElem) + ,zip,zipWith,zipWith3,unzip,notElem + ,pred,succ) import Data.StorableVector.Base @@ -210,7 +211,7 @@ hGetBuf, hPutBuf, Handle, IOMode(..), ) -import System.IO.Unsafe (unsafePerformIO, ) +import System.IO.Unsafe (unsafePerformIO, {- unsafeInterleaveIO, -} ) -- import GHC.IOBase -- ----------------------------------------------------------------------------- @@ -484,6 +485,12 @@ -- | 'foldr', applied to a binary operator, a starting value -- (typically the right-identity of the operator), and a 'Vector', -- reduces the 'Vector' using the binary operator, from right to left. +-- However, it is not the same as 'foldl' applied to the reversed vector. +-- Actually 'foldr' starts processing with the first element, +-- and thus can be used for efficiently building a singly linked list +-- by @foldr (:) [] vec@. +-- Unfortunately 'foldr' is quite slow for low-level loops, +-- since GHC (up to 6.12.1) cannot detect the loop. foldr :: (Storable a) => (a -> b -> b) -> b -> Vector a -> b foldr = foldrByLoop {-# INLINE foldr #-} @@ -492,6 +499,9 @@ *Data.StorableVector> List.length $ foldrBySwitch (:) [] $ replicate 1000000 'a' 1000000 (11.29 secs, 1183476300 bytes) +*Data.StorableVector> List.length $ foldrByIO (:) [] $ replicate 1000000 'a' +1000000 +(7.86 secs, 1033901140 bytes) *Data.StorableVector> List.length $ foldrByIndex (:) [] $ replicate 1000000 'a' 1000000 (7.86 secs, 914340420 bytes) @@ -506,6 +516,9 @@ and increment that instead, because we need to keep the reference to ForeignPtr, otherwise memory might be freed. +We can also not perform loop entirely in strict IO, +since this eat up the stack quickly +and 'foldr' might be used to build a list lazily. -} foldrByLoop :: (Storable a) => (a -> b -> b) -> b -> Vector a -> b foldrByLoop f z (SV fp s l) = @@ -518,6 +531,17 @@ {-# INLINE foldrByLoop #-} {- +foldrByIO :: (Storable a) => (a -> b -> b) -> b -> Vector a -> b +foldrByIO f z v@(SV fp _ _) = + unsafeWithStartPtr v $ + let go = Strict.arguments2 $ \p l -> + unsafeInterleaveIO $ + if l>0 + then liftM2 f (peek p) (go (incPtr p) (pred l)) + else touchForeignPtr fp >> return z + in go +{-# INLINE foldrByIO #-} + foldrByIndex :: (Storable a) => (a -> b -> b) -> b -> Vector a -> b foldrByIndex k z xs = let recourse n = @@ -755,11 +779,58 @@ -- | /O(n)/ 'replicate' @n x@ is a 'Vector' of length @n@ with @x@ -- the value of every element. -- +{- nice implementation replicate :: (Storable a) => Int -> a -> Vector a replicate n c = fst $ unfoldrN n (const $ Just (c, ())) () +-} + +-- fast implementation +replicate :: (Storable a) => Int -> a -> Vector a +replicate n c = + if n <= 0 + then empty + else unsafeCreate n $ + let go = Strict.arguments2 $ \i p -> + if i == 0 + then return () + else poke p c >> go (pred i) (incPtr p) + in go n {-# INLINE replicate #-} +{- +For 'replicate 10000000 (42::Int)' generates: +Main_zdwa_info: + movl (%ebp),%eax + testl %eax,%eax + jne .LcfIQ + movl $ghczmprim_GHCziUnit_Z0T_closure+1,%esi + addl $8,%ebp + jmp *(%ebp) +.LcfIQ: + movl 4(%ebp),%ecx + movl $42,(%ecx) + decl %eax + addl $4,4(%ebp) + movl %eax,(%ebp) + jmp Main_zdwa_info + +that is, the inner loop consists of 9 instructions, +where I would write something like: + # counter in %ecx + testl %ecx + jz skip_loop + movl $42,%ebx +start_loop: + movl %ebx,(%edx) + addl $4,%edx + loop start_loop +skip_loop: + +and need only 3 instructions in the loop. +-} + + -- | /O(n)/ 'iterateN' @n f x@ is a 'Vector' of length @n@ -- where the elements of @x@ are generated by repeated application of @f@. -- @@ -797,23 +868,23 @@ -- > fst (unfoldrN n f s) == take n (unfoldr f s) -- unfoldrN :: (Storable b) => Int -> (a -> Maybe (b, a)) -> a -> (Vector b, Maybe a) -unfoldrN i f x0 = - if i <= 0 +unfoldrN n f x0 = + if n <= 0 then (empty, Just x0) - else unsafePerformIO $ createAndTrim' i $ \p -> go p 0 x0 + else unsafePerformIO $ createAndTrim' n $ \p -> go p n x0 {- go must not be strict in the accumulator since otherwise packN would be too strict. -} where - go = Strict.arguments2 $ \p n -> \x -> - if n == i - then return (0, n, Just x) + go = Strict.arguments2 $ \p i -> \x -> + if i == 0 + then return (0, n-i, Just x) else case f x of - Nothing -> return (0, n, Nothing) + Nothing -> return (0, n-i, Nothing) Just (w,x') -> do poke p w - go (incPtr p) (n+1) x' + go (incPtr p) (i-1) x' {-# INLINE unfoldrN #-} {- @@ -1372,6 +1443,17 @@ -- --------------------------------------------------------------------- -- Internal utilities + + +-- These definitions of succ and pred do not check for overflow +-- and are faster than their counterparts from Enum class. +succ :: Int -> Int +succ n = n+1 +{-# INLINE succ #-} + +pred :: Int -> Int +pred n = n-1 +{-# INLINE pred #-} unsafeWithStartPtr :: Storable a => Vector a -> (Ptr a -> Int -> IO b) -> b unsafeWithStartPtr v f = diff --git a/Data/StorableVector/Lazy.hs b/Data/StorableVector/Lazy.hs --- a/Data/StorableVector/Lazy.hs +++ b/Data/StorableVector/Lazy.hs @@ -36,7 +36,9 @@ import qualified System.IO.Error as Exc import System.IO.Unsafe (unsafeInterleaveIO) +import Test.QuickCheck (Arbitrary(..)) + import Prelude hiding (length, (++), concat, iterate, foldl, map, repeat, replicate, null, zip, zipWith, zipWith3, drop, take, splitAt, takeWhile, dropWhile, reverse) @@ -73,10 +75,16 @@ (showString "VectorLazy.fromChunks " . showsPrec 10 (chunks xs)) +instance (Storable a, Arbitrary a) => Arbitrary (Vector a) where + arbitrary = liftM2 pack arbitrary arbitrary + -- for a list of chunk sizes see "Data.StorableVector.LazySize". newtype ChunkSize = ChunkSize Int deriving (Eq, Ord, Show) + +instance Arbitrary ChunkSize where + arbitrary = fmap (ChunkSize . max 1) arbitrary instance Num ChunkSize where (ChunkSize x) + (ChunkSize y) = diff --git a/Data/StorableVector/Lazy/Pattern.hs b/Data/StorableVector/Lazy/Pattern.hs --- a/Data/StorableVector/Lazy/Pattern.hs +++ b/Data/StorableVector/Lazy/Pattern.hs @@ -63,6 +63,8 @@ take, drop, splitAt, + takeVectorPattern, + splitAtVectorPattern, dropMarginRem, dropMargin, dropWhile, @@ -103,7 +105,7 @@ import qualified Data.List as List import qualified Data.List.HT as ListHT -import Data.Tuple.HT (mapPair, mapFst, forcePair, ) +import Data.Tuple.HT (mapPair, mapFst, forcePair, swap, ) import Control.Monad (liftM2, liftM3, liftM4, guard, ) @@ -237,10 +239,21 @@ -- * sub-vectors +{- | +Generates laziness breaks +wherever either the lazy length number or the vector has a chunk boundary. +-} {-# INLINE take #-} take :: (Storable a) => LazySize -> Vector a -> Vector a -take _ (SV []) = empty -take n (SV (x:xs)) = +take n = fst . splitAt n + +{- | +Preserves the chunk pattern of the lazy vector. +-} +{-# INLINE takeVectorPattern #-} +takeVectorPattern :: (Storable a) => LazySize -> Vector a -> Vector a +takeVectorPattern _ (SV []) = empty +takeVectorPattern n (SV (x:xs)) = if List.null (LS.toChunks n) then empty else @@ -257,8 +270,20 @@ List.foldl (flip (LSV.drop . intFromChunkSize)) xs (LS.toChunks size) {-# INLINE splitAt #-} -splitAt :: (Storable a) => LazySize -> Vector a -> (Vector a, Vector a) -splitAt n0 = +splitAt :: + (Storable a) => LazySize -> Vector a -> (Vector a, Vector a) +splitAt size xs = + mapFst LSV.concat $ swap $ + List.mapAccumL + (\xs0 n -> + swap $ LSV.splitAt (intFromChunkSize n) xs0) + xs (LS.toChunks size) + +{-# INLINE splitAtVectorPattern #-} +splitAtVectorPattern :: + (Storable a) => LazySize -> Vector a -> (Vector a, Vector a) +splitAtVectorPattern n0 = + forcePair . if List.null (LS.toChunks n0) then (,) empty else @@ -269,7 +294,8 @@ (x:xs) -> let remain = decrementLimit x n in if LS.isNull remain - then mapPair ((:[]), (:xs)) $ V.splitAt (intFromLazySize n) x + then mapPair ((:[]), (:xs)) $ + V.splitAt (intFromLazySize n) x else mapFst (x:) $ recourse remain xs in mapPair (SV, SV) . recourse n0 . LSV.chunks diff --git a/Data/StorableVector/ST/Strict.hs b/Data/StorableVector/ST/Strict.hs --- a/Data/StorableVector/ST/Strict.hs +++ b/Data/StorableVector/ST/Strict.hs @@ -16,6 +16,9 @@ read, write, modify, + maybeRead, + maybeWrite, + maybeModify, unsafeRead, unsafeWrite, unsafeModify, @@ -43,6 +46,10 @@ import Foreign.Marshal.Array (advancePtr, copyArray, ) -- import System.IO.Unsafe (unsafePerformIO) +import qualified Data.Traversable as Traversable +import Data.Maybe.HT (toMaybe, ) +import Data.Maybe (isJust, ) + -- import Prelude (Int, ($), (+), return, const, ) import Prelude hiding (read, length, ) @@ -103,6 +110,58 @@ then act else error ("StorableVector.ST." ++ name ++ ": index out of range") + +{- | +Returns @Just e@, when the element @e@ could be read +and 'Nothing' if the index was out of range. +This way you can avoid duplicate index checks +that may be needed when using 'read'. + +> Control.Monad.ST.runST (do arr <- new_ 10; Monad.zipWithM_ (write arr) [9,8..0] ['a'..]; read arr 3) + +In future 'maybeRead' will replace 'read'. +-} +{-# INLINE maybeRead #-} +maybeRead :: (Storable e) => + Vector s e -> Int -> ST s (Maybe e) +maybeRead v n = + maybeAccess v n $ unsafeRead v n + +{- | +Returns 'True' if the element could be written +and 'False' if the index was out of range. + +> runSTVector (do arr <- new_ 10; foldr (\c go i -> maybeWrite arr i c >>= \cont -> if cont then go (succ i) else return arr) (error "unreachable") ['a'..] 0) + +In future 'maybeWrite' will replace 'write'. +-} +{-# INLINE maybeWrite #-} +maybeWrite :: (Storable e) => + Vector s e -> Int -> e -> ST s Bool +maybeWrite v n x = + fmap isJust $ maybeAccess v n $ unsafeWrite v n x + +{- | +Similar to 'maybeWrite'. + +In future 'maybeModify' will replace 'modify'. +-} +{-# INLINE maybeModify #-} +maybeModify :: (Storable e) => + Vector s e -> Int -> (e -> e) -> ST s Bool +maybeModify v n f = + fmap isJust $ maybeAccess v n $ unsafeModify v n f + +{-# INLINE maybeAccess #-} +maybeAccess :: (Storable e) => + Vector s e -> Int -> ST s a -> ST s (Maybe a) +maybeAccess (SV _v l) n act = + Traversable.sequence $ toMaybe (0<=n && n diff --git a/speedtest/SpeedTestChorus.hs b/speedtest/SpeedTestChorus.hs --- a/speedtest/SpeedTestChorus.hs +++ b/speedtest/SpeedTestChorus.hs @@ -1,6 +1,8 @@ -{-# OPTIONS_GHC -funbox-strict-fields -ddump-simpl -O #-} +{-# OPTIONS_GHC -funbox-strict-fields -ddump-simpl -ddump-asm -O #-} {-# LANGUAGE ExistentialQuantification #-} {- -dverbose-core2core -ddump-simpl-stats -} +-- I use the dump options only in the main module and not in Cabal +-- in order to get only code for the main module and not all modules {- This module demonstrates the following: mainMonolithic1Generator performs the same computation as mainMonolithic1Compose @@ -18,7 +20,7 @@ > ghc -package storablevector-0.2.5 -O speedtest/SpeedTestChorus.hs -Exporting only main causes warnings about unused functions, +Exporting only 'main' causes warnings about unused functions, but it also reduces the core output to a third. -} module Main (main) where @@ -28,7 +30,7 @@ import qualified Data.StorableVector.ST.Lazy as SVSTL import qualified Data.StorableVector as SV import qualified Data.StorableVector.Lazy as SVL -import qualified Data.StorableVector.Private as SVP +-- import qualified Data.StorableVector.Private as SVP import qualified Control.Monad.ST.Strict as StrictST import Control.Monad.ST.Lazy (ST, runST, strictToLazyST, ) @@ -45,6 +47,7 @@ {- +GHC-6.10.4: I started with Storable instance for pairs from storable-tuple, that was implemented using the storable-record framework at this time. I got run-time around 5 seconds. @@ -124,6 +127,30 @@ SVL.unfoldr SVL.defaultChunkSize (generator0Freq freq) phase +{- +Here we let storablevector functions check +whether we reached the end of the vector. +However, 'SVSTS.maybeWrite' also checks +whether the index is non-negative, +which is unnecessary in our case. +-} +{-# INLINE runLoopSTStrictSafe #-} +runLoopSTStrictSafe :: + (Storable a) => + Int -> (s -> Maybe (a, s)) -> s -> SV.Vector a +runLoopSTStrictSafe n f s = + SVSTS.runSTVector + (do v <- SVSTS.new_ n + let go i s0 = + case f s0 of + Nothing -> return v + Just (a,s1) -> + SVSTS.maybeWrite v i a >>= \cont -> + if cont + then go (succ i) s1 + else return v + go 0 s) + {-# INLINE runLoopSTStrict #-} runLoopSTStrict :: (Storable a) => @@ -132,14 +159,10 @@ SVSTS.runSTVector (do v <- SVSTS.new_ n let go i s0 = - if i return v - Just (a,s1) -> --- SVSTS.write v i a >> go (succ i) s1 - SVSTS.unsafeWrite v i a >> go (succ i) s1 - else return v + case guard (i> f s0 of + Nothing -> return v + Just (a,s1) -> + SVSTS.unsafeWrite v i a >> go (succ i) s1 go 0 s) {-# INLINE runLoopSTLazy #-} @@ -150,22 +173,19 @@ SVSTL.runSTVector (do v <- SVSTL.new_ n let go s0 i = - if i return v - Just (a,s1) -> - {- - Strict pattern matching on () is necessary - in order to avoid a memory leak. - Working in ST.Lazy is still - three times slower than ST.Strict - -} - strictToLazyST (SVSTS.unsafeWrite v i a >> return (succ i)) - >>= go s1 --- SVSTL.unsafeWrite v i a >>= \() -> go s1 (succ i) --- SVSTL.unsafeWrite v i a >> go s1 (succ i) - else return v + case guard (i> f s0 of + Nothing -> return v + Just (a,s1) -> + strictToLazyST (SVSTS.unsafeWrite v i a >> return (succ i)) + >>= go s1 + {- + Strict pattern matching on () is necessary + in order to avoid a memory leak. + Working in ST.Lazy is still + three times slower than ST.Strict + -} +-- SVSTL.unsafeWrite v i a >>= \() -> go s1 (succ i) +-- SVSTL.unsafeWrite v i a >> go s1 (succ i) go s 0) @@ -179,7 +199,7 @@ case f s0 of Nothing -> return i Just (a,s1) -> - SVSTS.unsafeWrite v i a >> go (succ i) s1 + SVSTS.unsafeModify v i (a+) >> go (succ i) s1 else return i in go 0 s @@ -191,11 +211,42 @@ case guard (i < SVSTS.length v) >> f s0 of Nothing -> return i Just (a,s1) -> - SVSTS.unsafeWrite v i a >> go (succ i) s1 + SVSTS.unsafeModify v i (a+) >> go (succ i) s1 in go 0 s +{- +It seems that mixSTVectorFoldr is essentially slower than mixSTVectorIndex. +The former one should be faster, +since 'foldr' uses direct pointer into the source vector. +-} +{-# INLINE mixSTVectorIndex #-} +mixSTVectorIndex :: (Storable a, Num a) => + SVSTS.Vector s a -> SV.Vector a -> StrictST.ST s Int +mixSTVectorIndex dst src = + let end = min (SVSTS.length dst) (SV.length src) + go i = + if i >= end + then return i + else + SVSTS.unsafeModify dst i (SV.index src i +) >> + go (succ i) + in go 0 +{-# INLINE mixSTVectorFoldr #-} +mixSTVectorFoldr :: (Storable a, Num a) => + SVSTS.Vector s a -> SV.Vector a -> StrictST.ST s Int +mixSTVectorFoldr dst src = + SV.foldr + (\x go i -> + if i >= SVSTS.length dst + then return i + else + SVSTS.unsafeModify dst i (x +) >> + go (succ i)) + return src 0 + + {-# INLINE runBuilder #-} runBuilder :: (Storable a) => @@ -320,14 +371,53 @@ size :: Int size = 10000000 + +mainSumFoldl :: IO () +mainSumFoldl = + print $ SV.foldl (\s x -> s+x+13) 23 (SV.replicate size (42::Int)) +{- +stack overflow +-} + +mainSumFoldl' :: IO () +mainSumFoldl' = + print $ SV.foldl' (\s x -> s+x+13) 23 (SV.replicate size (42::Int)) +{- +GHC-6.12.1: + +real 0m0.171s +user 0m0.112s +sys 0m0.056s +-} + +mainSumFoldr :: IO () +mainSumFoldr = + print $ SV.foldr (\x go s -> go $! s+x+13) id (SV.replicate size (42::Int)) $! 23 +{- +GHC-6.12.1: + +real 0m0.503s +user 0m0.464s +sys 0m0.036s +-} + mainMonolithic0 :: IO () mainMonolithic0 = SV.writeFile "speed.f32" (fst $ SV.unfoldrN size generator0 0) {- +GHC-6.10.4: + real 0m0.423s user 0m0.256s sys 0m0.152s + + +GHC-6.12.1: + +real 0m0.392s +user 0m0.252s +sys 0m0.140s -} mainMonolithic0Generator :: IO () @@ -335,15 +425,31 @@ SV.writeFile "speed.f32" (runGeneratorMonolithic size (generator0Gen (0.01::Float) 0)) +{- +GHC-6.12.1: +real 0m0.413s +user 0m0.240s +sys 0m0.172s +-} + mainMonolithic0STStrict :: IO () mainMonolithic0STStrict = SV.writeFile "speed.f32" (runLoopSTStrict size (generator0Freq (0.01::Float)) 0) {- +GHC-6.10.4: + real 0m0.430s user 0m0.288s sys 0m0.132s + + +GHC-6.12.1: + +real 0m0.447s +user 0m0.276s +sys 0m0.168s -} mainMonolithic0STLazy :: IO () @@ -351,9 +457,17 @@ SV.writeFile "speed.f32" (runLoopSTLazy size (generator0Freq (0.01::Float)) 0) {- +GHC-6.10.4: + real 0m0.886s user 0m0.752s sys 0m0.128s + +GHC-6.12.1: + +real 0m0.763s +user 0m0.620s +sys 0m0.144s -} mainMonolithic0STMix :: IO () @@ -364,16 +478,32 @@ l <- mixSTGuard v (generator0Freq (0.01::Float)) 0 fmap (SV.take l) (SVSTS.unsafeFreeze v)) {- +GHC-6.10.4: + real 0m0.505s user 0m0.344s sys 0m0.156s + + +GHC-6.12.1: + +real 0m0.475s +user 0m0.344s +sys 0m0.128s -} mainMonolithic1 :: IO () mainMonolithic1 = SV.writeFile "speed.f32" (fst $ SV.unfoldrN size generator1 (fst initPhase2)) +{- +GHC-6.12.1: +real 0m0.973s +user 0m0.824s +sys 0m0.140s +-} + mainMonolithic1Composed :: IO () mainMonolithic1Composed = SV.writeFile "speed.f32" @@ -385,9 +515,18 @@ (let (p0,p1,p2) = fst initPhase2 in ((p0,p1),p2))) {- +GHC-6.10.4: + real 0m0.974s user 0m0.812s sys 0m0.160s + + +GHC-6.12.1: + +real 0m0.940s +user 0m0.800s +sys 0m0.132s -} mainMonolithic1Generator :: IO () @@ -400,9 +539,18 @@ generator0Gen f1 p1 `mixGen` generator0Gen f2 p2)) {- +GHC-6.10.4: + real 0m2.244s user 0m2.084s sys 0m0.152s + + +GHC-6.12.1: + +real 0m2.256s +user 0m2.084s +sys 0m0.172s -} mainMonolithic1GeneratorFold :: IO () @@ -415,9 +563,18 @@ map (uncurry generator0Gen) $ [(f0,p0), (f1,p1), (f2,p2)])) {- +GHC-6.10.4: + real 0m3.006s user 0m2.816s sys 0m0.180s + + +GHC-6.12.1: + +real 0m3.050s +user 0m2.884s +sys 0m0.160s -} mainMonolithic1STMix :: IO () @@ -432,9 +589,18 @@ l2 <- mixSTGuard v (generator0Freq f2) p2 fmap (SV.take (l0 `min` l1 `min` l2)) (SVSTS.unsafeFreeze v)) {- +GHC-6.10.4: + real 0m1.895s user 0m1.684s sys 0m0.180s + + +GHC-6.12.1: + +real 0m1.932s +user 0m1.764s +sys 0m0.168s -} mainMonolithic1STMixZip :: IO () @@ -448,16 +614,95 @@ [f0,f1,f2] [p0,p1,p2] fmap (SV.take (minimum ls)) (SVSTS.unsafeFreeze v)) {- +GHC-6.10.4: + real 0m1.391s user 0m1.232s sys 0m0.160s + + +GHC-6.12.1: + +real 0m1.560s +user 0m1.404s +sys 0m0.136s -} + +mainMonolithic1STMixVector :: IO () +mainMonolithic1STMixVector = + SV.writeFile "speed.f32" $ + StrictST.runST + (do v <- SVSTS.new size 0 + let (f0,f1,f2) = dl + (p0,p1,p2) = fst initPhase2 + osci f p = fst $ SV.unfoldrN size (generator0Freq f) p + l0 <- mixSTVectorIndex v (osci f0 p0) + l1 <- mixSTVectorIndex v (osci f1 p1) + l2 <- mixSTVectorIndex v (osci f2 p2) + fmap (SV.take (l0 `min` l1 `min` l2)) (SVSTS.unsafeFreeze v)) +{- +GHC-6.12.1: + +real 0m1.751s +user 0m1.544s +sys 0m0.208s +-} + +mainMonolithic1STMixVectorZipFoldr :: IO () +mainMonolithic1STMixVectorZipFoldr = + SV.writeFile "speed.f32" $ + StrictST.runST + (do v <- SVSTS.new size 0 + let (f0,f1,f2) = dl + (p0,p1,p2) = fst initPhase2 + vs = zipWith + (\f p -> fst $ SV.unfoldrN size (generator0Freq f) p) + [f0,f1,f2] [p0,p1,p2] + ls <- mapM (mixSTVectorFoldr v) vs + fmap (SV.take (minimum ls)) (SVSTS.unsafeFreeze v)) +{- +GHC-6.12.1: + +real 0m3.046s +user 0m2.828s +sys 0m0.216s +-} + +mainMonolithic1STMixVectorZipIndex :: IO () +mainMonolithic1STMixVectorZipIndex = + SV.writeFile "speed.f32" $ + StrictST.runST + (do v <- SVSTS.new size 0 + let (f0,f1,f2) = dl + (p0,p1,p2) = fst initPhase2 + vs = zipWith + (\f p -> fst $ SV.unfoldrN size (generator0Freq f) p) + [f0,f1,f2] [p0,p1,p2] + ls <- mapM (mixSTVectorIndex v) vs + fmap (SV.take (minimum ls)) (SVSTS.unsafeFreeze v)) +{- +GHC-6.12.1: + +real 0m1.782s +user 0m1.532s +sys 0m0.220s +-} + + mainMonolithic2 :: IO () mainMonolithic2 = SV.writeFile "speed.f32" (fst $ SV.unfoldrN size generator2 initPhase2) +{- +GHC-6.12.1: +real 0m1.852s +user 0m1.588s +sys 0m0.252s +-} + +{- mainMonolithicStrict2 :: IO () mainMonolithicStrict2 = SV.writeFile "speed.f32" @@ -471,6 +716,7 @@ (\(pl,pr) -> Just (Stereo.cons (sawChorus pl) (sawChorus pr))) initPhase2) +-} mainChunky0 :: IO () @@ -479,9 +725,18 @@ (SVL.take size $ SVL.unfoldr SVL.defaultChunkSize generator0 0) {- +GHC-6.10.4: + real 0m0.428s user 0m0.292s sys 0m0.132s + + +GHC-6.12.1: + +real 0m0.424s +user 0m0.252s +sys 0m0.168s -} mainChunky0Builder :: IO () @@ -490,9 +745,18 @@ (SVL.take size $ runBuilder SVL.defaultChunkSize generator0 0) {- +GHC-6.10.4: + real 0m1.107s user 0m0.968s sys 0m0.140s + + +GHC-6.12.1: + +real 0m1.079s +user 0m0.936s +sys 0m0.136s -} mainChunky1 :: IO () @@ -501,9 +765,18 @@ (SVL.take size $ SVL.unfoldr SVL.defaultChunkSize generator1 (fst initPhase2)) {- +GHC-6.10.4: + real 0m0.938s user 0m0.812s sys 0m0.116s + + +GHC-6.12.1: + +real 0m0.945s +user 0m0.788s +sys 0m0.152s -} mainChunky1MixFlat :: IO () @@ -516,9 +789,18 @@ tone0 f1 p1 `mixVec` tone0 f2 p2) {- +GHC-6.10.4: + real 0m3.932s user 0m2.112s sys 0m0.156s + + +GHC-6.12.1: + +real 0m2.264s +user 0m2.144s +sys 0m0.116s -} mainChunky1MixFold :: IO () @@ -531,9 +813,18 @@ map (uncurry tone0) $ [(f0,p0), (f1,p1), (f2,p2)]) {- +GHC-6.10.4: + real 0m1.611s user 0m1.476s sys 0m0.108s + + +GHC-6.12.1: + +real 0m1.555s +user 0m1.416s +sys 0m0.136s -} mainChunky2 :: IO () @@ -542,12 +833,20 @@ (SVL.take size $ SVL.unfoldr SVL.defaultChunkSize generator2 initPhase2) {- +GHC-6.10.4: + real 0m2.220s user 0m1.400s sys 0m0.192s + + +GHC-6.12.1: + +real 0m1.877s +user 0m1.652s +sys 0m0.216s -} main :: IO () main = - mainMonolithic1STMixZip --- mainMonolithic1GeneratorFold + mainSumFoldl' diff --git a/storablevector.cabal b/storablevector.cabal --- a/storablevector.cabal +++ b/storablevector.cabal @@ -1,5 +1,5 @@ Name: storablevector -Version: 0.2.5 +Version: 0.2.6 Category: Data Synopsis: Fast, packed, strict storable arrays with a list interface like ByteString Description: @@ -51,13 +51,14 @@ Source-Repository this type: darcs location: http://code.haskell.org/storablevector/ - tag: 0.2.5 + tag: 0.2.6 Library Build-Depends: non-negative >= 0.0.4 && <0.1, utility-ht >= 0.0.5 && <0.1, - transformers >=0.0 && <0.2 + transformers >=0.2 && <0.3, + QuickCheck >= 1 && < 3 If impl(jhc) Hs-Source-Dirs: foreign-ptr/jhc @@ -114,7 +115,7 @@ If flag(buildTests) Build-Depends: bytestring >= 0.9 && < 0.10, - QuickCheck >= 1 && < 2 + QuickCheck >= 1 && < 3 If flag(splitBase) Build-Depends: random >= 1.0 && < 1.1 If flag(functorInstance) diff --git a/tests/QuickCheckUtils.hs b/tests/QuickCheckUtils.hs --- a/tests/QuickCheckUtils.hs +++ b/tests/QuickCheckUtils.hs @@ -85,12 +85,12 @@ ------------------------------------------------------------------------ instance Arbitrary Char where - arbitrary = choose ('a', 'i') - coarbitrary c = variant (ord c `rem` 4) + arbitrary = choose ('a', 'i') + coarbitrary c = variant (ord c `rem` 4) instance Arbitrary Word8 where - arbitrary = choose (97, 105) - coarbitrary c = variant (fromIntegral ((fromIntegral c) `rem` 4)) + arbitrary = choose (97, 105) + coarbitrary c = variant (fromIntegral ((fromIntegral c) `rem` 4)) instance Arbitrary Int64 where arbitrary = sized $ \n -> choose (-fromIntegral n,fromIntegral n) @@ -120,8 +120,8 @@ (x,g) -> (fromIntegral x, g) instance Arbitrary V where - arbitrary = V.pack `fmap` arbitrary - coarbitrary s = coarbitrary (V.unpack s) + arbitrary = V.pack `fmap` arbitrary + coarbitrary s = coarbitrary (V.unpack s) instance Arbitrary P.ByteString where arbitrary = P.pack `fmap` arbitrary