packages feed

storablevector 0.2.3.1 → 0.2.4

raw patch · 7 files changed

+338/−99 lines, 7 filesdep ~basenew-component:exe:speedpointer

Dependency ranges changed: base

Files

Data/StorableVector.hs view
@@ -63,6 +63,8 @@         length,         viewL,         viewR,+        switchL,+        switchR,          -- * Transformating 'Vector's         map,@@ -208,8 +210,8 @@  -- ----------------------------------------------------------------------------- -instance (Storable a, Eq a) => Eq (Vector a)-    where (==)    = eq+instance (Storable a, Eq a) => Eq (Vector a) where+    (==) = equal  instance (Storable a) => Monoid (Vector a) where     mempty  = empty@@ -217,12 +219,29 @@     mconcat = concat  -- | /O(n)/ Equality on the 'Vector' type.-eq :: (Storable a, Eq a) => Vector a -> Vector a -> Bool-eq a@(SV p s l) b@(SV p' s' l')-    | l /= l'            = False    -- short cut on length-    | p == p' && s == s' = True     -- short cut for the same string-    | otherwise          = unpack a == unpack b-{-# INLINE eq #-}+equal :: (Storable a, Eq a) => Vector a -> Vector a -> Bool+equal a b =+   unsafePerformIO $+   withStartPtr a $ \paf la ->+   withStartPtr b $ \pbf lb ->+    if la /= lb+      then+        return False+      else+        if paf == pbf+          then return True+          else+            let go = Strict.arguments3 $ \p q l ->+                   if l==0+                     then return True+                     else+                       do x <- peek p+                          y <- peek q+                          if x==y+                            then go (incPtr p) (incPtr q) (l-1)+                            else return False+            in  go paf pbf la+{-# INLINE equal #-}  -- ----------------------------------------------------------------------------- -- Introducing and eliminating 'Vector's@@ -245,7 +264,7 @@       go = Strict.arguments2 $ \p ->         ListHT.switchL            (return ())-           (\x xs -> poke p x >> go (p `advancePtr` 1) xs)+           (\x xs -> poke p x >> go (incPtr p) xs)  -- | /O(n)/ Convert first @n@ elements of a '[a]' into a 'Vector a'. --@@ -267,7 +286,7 @@       go = Strict.arguments2 $ \p ->         ListHT.switchL            (return ())-           (\x xs -> poke p (k x) >> go (p `advancePtr` 1) xs)+           (\x xs -> poke p (k x) >> go (incPtr p) xs)                           -- less space than pokeElemOff {-# INLINE packWith #-} @@ -288,8 +307,8 @@ -- | /O(n)/ Convert a 'Vector' into a list using a conversion function unpackWith :: (Storable a) => (a -> b) -> Vector a -> [b] unpackWith _ (SV _  _ 0) = []-unpackWith k (SV ps s l) = inlinePerformIO $ withForeignPtr ps $ \p ->-        go (p `advancePtr` s) (l - 1) []+unpackWith k v@(SV ps s l) = inlinePerformIO $ withStartPtr v $ \p ->+        go p (l - 1) []     where         STRICT3(go)         go p 0 acc = peek p          >>= \e -> return (k e : acc)@@ -333,48 +352,48 @@ -- | /O(n)/ 'cons' is analogous to (:) for lists, but of different -- complexity, as it requires a memcpy. cons :: (Storable a) => a -> Vector a -> Vector a-cons c (SV x s l) = unsafeCreate (l+1) $ \p -> withForeignPtr x $ \f -> do-        poke p c-        copyArray (p `advancePtr` 1) (f `advancePtr` s) (fromIntegral l)+cons c v =+   unsafeWithStartPtr v $ \f l ->+   create (l + 1) $ \p -> do+      poke p c+      copyArray (incPtr p) f (fromIntegral l) {-# INLINE cons #-}  -- | /O(n)/ Append an element to the end of a 'Vector' snoc :: (Storable a) => Vector a -> a -> Vector a-snoc (SV x s l) c = unsafeCreate (l+1) $ \p -> withForeignPtr x $ \f -> do-        copyArray p (f `advancePtr` s) l-        pokeElemOff p l c+snoc v c =+   unsafeWithStartPtr v $ \f l ->+   create (l + 1) $ \p -> do+      copyArray p f l+      pokeElemOff p l c {-# INLINE snoc #-}  -- | /O(1)/ Extract the first element of a 'Vector', which must be non-empty. -- An exception will be thrown in the case of an empty 'Vector'. head :: (Storable a) => Vector a -> a-head (SV x s l)-    | l <= 0    = errorEmptyList "head"-    | otherwise = inlinePerformIO $ withForeignPtr x $ \p -> peekElemOff p s+head =+   withNonEmptyVector "head" $ \ p s _l -> foreignPeek p s {-# INLINE head #-}  -- | /O(1)/ Extract the elements after the head of a 'Vector', which must be non-empty. -- An exception will be thrown in the case of an empty 'Vector'. tail :: (Storable a) => Vector a -> Vector a-tail (SV p s l)-    | l <= 0    = errorEmptyList "tail"-    | otherwise = SV p (s+1) (l-1)+tail =+   withNonEmptyVector "tail" $ \ p s l -> SV p (s+1) (l-1) {-# INLINE tail #-}  -- | /O(1)/ Extract the last element of a 'Vector', which must be finite and non-empty. -- An exception will be thrown in the case of an empty 'Vector'. last :: (Storable a) => Vector a -> a-last ps@(SV x s l)-    | null ps   = errorEmptyList "last"-    | otherwise = inlinePerformIO $ withForeignPtr x $ \p -> peekElemOff p (s+l-1)+last =+   withNonEmptyVector "last" $ \ p s l -> foreignPeek p (s+l-1) {-# INLINE last #-}  -- | /O(1)/ Return all the elements of a 'Vector' except the last one. -- An exception will be thrown in the case of an empty 'Vector'. init :: Vector a -> Vector a-init ps@(SV p s l)-    | null ps   = errorEmptyList "init"-    | otherwise = SV p s (l-1)+init =+   withNonEmptyVector "init" $ \ p s l -> SV p s (l-1) {-# INLINE init #-}  -- | /O(n)/ Append two Vectors@@ -391,32 +410,34 @@ -- | /O(n)/ 'map' @f xs@ is the 'Vector' obtained by applying @f@ to each -- element of @xs@. map :: (Storable a, Storable b) => (a -> b) -> Vector a -> Vector b-map f (SV fp s len) = inlinePerformIO $ withForeignPtr fp $ \a ->-   create len $+map f v =+   unsafeWithStartPtr v $ \a len ->+   create len $ \p ->       let go = Strict.arguments3 $              \ n p1 p2 ->                when (n>0) $                  do poke p2 . f =<< peek p1-                    go (n-1) (p1 `advancePtr` 1) (p2 `advancePtr` 1)-      in  go len (a `advancePtr` s)+                    go (n-1) (incPtr p1) (incPtr p2)+      in  go len a p {-# INLINE map #-}  {- mapByIndex :: (Storable a, Storable b) => (a -> b) -> Vector a -> Vector b-mapByIndex f (SV fp s len) = inlinePerformIO $ withForeignPtr fp $ \a ->+mapByIndex f v = inlinePerformIO $ withStartPtr v $ \a len ->     create len $ \p2 ->-       let p1 = a `advancePtr` s-           go = Strict.arguments1 $ \ n ->+       let go = Strict.arguments1 $ \ n ->               when (n<len) $-                do pokeElemOff p2 n . f =<< peekElemOff p1 n+                do pokeElemOff p2 n . f =<< peekElemOff a n                    go (n+1)        in  go 0 -}  -- | /O(n)/ 'reverse' @xs@ efficiently returns the elements of @xs@ in reverse order. reverse :: (Storable a) => Vector a -> Vector a-reverse (SV x s l) = unsafeCreate l $ \p -> withForeignPtr x $ \f ->-   sequence_ [peekElemOff (f `advancePtr` s) i >>= pokeElemOff p (l - i - 1)+reverse v =+   unsafeWithStartPtr v $ \f l ->+   create l $ \p ->+   sequence_ [peekElemOff f i >>= pokeElemOff p (l - i - 1)                  | i <- [0 .. l - 1]]  -- | /O(n)/ The 'intersperse' function takes a element and a@@ -445,15 +466,14 @@  -- | 'foldl\'' is like 'foldl', but strict in the accumulator. foldl' :: (Storable a) => (b -> a -> b) -> b -> Vector a -> b-foldl' f v (SV x s l) =-   unsafePerformIO $ withForeignPtr x $ \ptr ->-      let sptr = ptr `advancePtr` s-          q    = sptr `advancePtr` l+foldl' f b v =+   unsafePerformIO $ withStartPtr v $ \ptr l ->+      let q  = ptr `advancePtr` l           go = Strict.arguments2 $ \p z ->              if p == q                then return z-               else go (p `advancePtr` 1) . f z =<< peek p-      in  go sptr v+               else go (incPtr p) . f z =<< peek p+      in  go ptr b {-# INLINE foldl' #-}  -- | 'foldr', applied to a binary operator, a starting value@@ -522,7 +542,7 @@ foldl1 :: (Storable a) => (a -> a -> a) -> Vector a -> a foldl1 f =    switchL-      (errorEmptyList "foldl1")+      (errorEmpty "foldl1")       (foldl f) {-# INLINE foldl1 #-} @@ -531,7 +551,7 @@ foldl1' :: (Storable a) => (a -> a -> a) -> Vector a -> a foldl1' f =    switchL-      (errorEmptyList "foldl1'")+      (errorEmpty "foldl1'")       (foldl' f) {-# INLINE foldl1' #-} @@ -541,7 +561,7 @@ foldr1 :: (Storable a) => (a -> a -> a) -> Vector a -> a foldr1 f =    switchR-      (errorEmptyList "foldr1")+      (errorEmpty "foldr1")       (flip (foldr f)) {-# INLINE foldr1 #-} @@ -558,9 +578,9 @@           Strict.arguments2 $ \ptr ->              ListHT.switchL                 (return ())-                (\(SV fp s l) ps -> do-                   withForeignPtr fp $ \p -> copyArray ptr (p `advancePtr` s) l-                   go (ptr `advancePtr` l) ps)+                (\v ps -> do+                   withStartPtr v $ copyArray ptr+                   go (ptr `advancePtr` length v) ps)  -- | Map a function over a 'Vector' and concatenate the results concatMap :: (Storable a, Storable b) => (a -> Vector b) -> Vector a -> Vector b@@ -773,7 +793,7 @@                  case f x of                    Nothing     -> return (0, n, Nothing)                    Just (w,x') -> do poke p w-                                     go (p `advancePtr` 1) (n+1) x'+                                     go (incPtr p) (n+1) x' {-# INLINE unfoldrN #-}  unfoldlN :: (Storable b) => Int -> (a -> Maybe (b, a)) -> a -> (Vector b, Maybe a)@@ -1102,7 +1122,7 @@ -- iff the first is a prefix of the second. isPrefixOf :: (Storable a, Eq a) => Vector a -> Vector a -> Bool isPrefixOf x@(SV _ _ l1) y@(SV _ _ l2) =-    l1 <= l2 && x `eq` unsafeTake l1 y+    l1 <= l2 && x == unsafeTake l1 y  -- | /O(n)/ The 'isSuffixOf' function takes two 'Vector's and returns 'True' -- iff the first is a suffix of the second.@@ -1113,7 +1133,7 @@ -- isSuffixOf :: (Storable a, Eq a) => Vector a -> Vector a -> Bool isSuffixOf x@(SV _ _ l1) y@(SV _ _ l2) =-    l1 <= l2 && x `eq` unsafeDrop (l2 - l1) y+    l1 <= l2 && x == unsafeDrop (l2 - l1) y  -- --------------------------------------------------------------------- -- Zipping@@ -1177,8 +1197,10 @@ --   if a large string has been read in, and only a small part of it --   is needed in the rest of the program. copy :: (Storable a) => Vector a -> Vector a-copy (SV x s l) = unsafeCreate l $ \p -> withForeignPtr x $ \f ->-    copyArray p (f `advancePtr` s) (fromIntegral l)+copy v =+   unsafeWithStartPtr v $ \f l ->+   create l $ \p ->+   copyArray p f (fromIntegral l)   @@ -1189,12 +1211,10 @@ hPut :: (Storable a) => Handle -> Vector a -> IO () hPut h v =    when (not (null v)) $-      let (fptr, s, l) = toForeignPtr v-      in  withForeignPtr fptr $ \ ptr ->-             let ptrS = advancePtr ptr s-                 ptrE = advancePtr ptrS l-                 -- use advancePtr and minusPtr in order to respect alignment-             in  hPutBuf h ptrS (minusPtr ptrE ptrS)+      withStartPtr v $ \ ptrS l ->+         let ptrE = advancePtr ptrS l+             -- use advancePtr and minusPtr in order to respect alignment+         in  hPutBuf h ptrS (minusPtr ptrE ptrS)  -- | Read a 'Vector' directly from the specified 'Handle'.  This -- is far more efficient than reading the characters into a list@@ -1236,16 +1256,33 @@ -- --------------------------------------------------------------------- -- Internal utilities +unsafeWithStartPtr :: Storable a => Vector a -> (Ptr a -> Int -> IO b) -> b+unsafeWithStartPtr v f =+   unsafePerformIO (withStartPtr v f)+{-# INLINE unsafeWithStartPtr #-}+ foreignPeek :: Storable a => ForeignPtr a -> Int -> a foreignPeek fp k =    inlinePerformIO $ withForeignPtr fp $ flip peekElemOff k {-# INLINE foreignPeek #-} +incPtr :: (Storable a) => Ptr a -> Ptr a+incPtr v = advancePtr v 1+{-# INLINE incPtr #-}++withNonEmptyVector ::+   String -> (ForeignPtr a -> Int -> Int -> b) -> Vector a -> b+withNonEmptyVector fun f (SV x s l) =+   if l <= 0+     then errorEmpty fun+     else f x s l+{-# INLINE withNonEmptyVector #-}+ -- Common up near identical calls to `error' to reduce the number -- constant strings created when compiled:-errorEmptyList :: String -> a-errorEmptyList fun = moduleError fun "empty Vector"-{-# NOINLINE errorEmptyList #-}+errorEmpty :: String -> a+errorEmpty fun = moduleError fun "empty Vector"+{-# NOINLINE errorEmpty #-}  moduleError :: String -> String -> a moduleError fun msg = error ("Data.StorableVector." ++ fun ++ ':':' ':msg)
Data/StorableVector/Base.hs view
@@ -37,6 +37,7 @@          fromForeignPtr,         -- :: ForeignPtr a -> Int -> Vector a         toForeignPtr,           -- :: Vector a -> (ForeignPtr a, Int, Int)+        withStartPtr,           -- :: Vector a -> (Ptr a -> Int -> IO b) -> IO b          inlinePerformIO @@ -100,8 +101,8 @@ -- check for the empty case, so there is an obligation on the programmer -- to provide a proof that the Vector is non-empty. unsafeLast :: (Storable a) => Vector a -> a-unsafeLast (SV x _s l) = assert (l > 0) $-    inlinePerformIO $ withForeignPtr x $ \p -> peekElemOff p (l-1)+unsafeLast (SV x s l) = assert (l > 0) $+    inlinePerformIO $ withForeignPtr x $ \p -> peekElemOff p (s+l-1) {-# INLINE unsafeLast #-}  -- | A variety of 'init' for non-empty Vectors. 'unsafeInit' omits the@@ -142,6 +143,13 @@ -- | /O(1)/ Deconstruct a ForeignPtr from a Vector toForeignPtr :: Vector a -> (ForeignPtr a, Int, Int) toForeignPtr (SV ps s l) = (ps, s, l)++-- | Run an action that is initialized+-- with a pointer to the first element to be used.+withStartPtr :: Storable a => Vector a -> (Ptr a -> Int -> IO b) -> IO b+withStartPtr (SV x s l) f =+   withForeignPtr x $ \p -> f (p `advancePtr` s) l+{-# INLINE withStartPtr #-}  -- | A way of creating Vectors outside the IO monad. The @Int@ -- argument gives the final size of the Vector. Unlike
Data/StorableVector/Lazy.hs view
@@ -13,13 +13,14 @@ import qualified Data.List as List import qualified Data.StorableVector as V import qualified Data.StorableVector.Base as VB+import qualified Data.StorableVector.Lazy.PointerPrivate as Ptr  import qualified Numeric.NonNegative.Class as NonNeg  import qualified Data.List.HT as ListHT import Data.Tuple.HT (mapPair, mapFst, mapSnd, ) import Data.Maybe.HT (toMaybe, )-import Data.Maybe (Maybe(Just), maybe, fromMaybe)+import Data.Maybe (Maybe(Just), maybe, fromMaybe, )  import Foreign.Storable (Storable) @@ -65,7 +66,10 @@     mappend = append     mconcat = concat +instance (Storable a, Eq a) => Eq (Vector a) where+   (==) = equal + -- for a list of chunk sizes see "Data.StorableVector.LazySize". newtype ChunkSize = ChunkSize Int    deriving (Eq, Ord, Show)@@ -73,10 +77,10 @@ instance Num ChunkSize where    (ChunkSize x) + (ChunkSize y)  =        ChunkSize (x+y)-   (-)  =  error "ChunkSize.-: intentionally unimplemented"-   (*)  =  error "ChunkSize.*: intentionally unimplemented"-   abs  =  error "ChunkSize.abs: intentionally unimplemented"-   signum  =  error "ChunkSize.signum: intentionally unimplemented"+   (-)  =  moduleError "ChunkSize.-" "intentionally unimplemented"+   (*)  =  moduleError "ChunkSize.*" "intentionally unimplemented"+   abs  =  moduleError "ChunkSize.abs" "intentionally unimplemented"+   signum  =  moduleError "ChunkSize.signum" "intentionally unimplemented"    fromInteger = ChunkSize . fromInteger  instance NonNeg.C ChunkSize where@@ -88,7 +92,7 @@    ChunkSize $       if x>0         then x-        else error ("no positive chunk size: " List.++ show x)+        else moduleError "chunkSize" ("no positive number: " List.++ show x)  defaultChunkSize :: ChunkSize defaultChunkSize =@@ -179,7 +183,40 @@ length :: Vector a -> Int length = sum . List.map V.length . chunks +equal :: (Storable a, Eq a) => Vector a -> Vector a -> Bool+equal (SV xs0) (SV ys0) =+   let recourse (x:xs) (y:ys) =+          let l = min (V.length x) (V.length y)+              (xPrefix, xSuffix) = V.splitAt l x+              (yPrefix, ySuffix) = V.splitAt l y+              build z zs =+                 if V.null z then zs else z:zs+          in  xPrefix == yPrefix &&+              recourse (build xSuffix xs) (build ySuffix ys)+       recourse [] [] = True+       -- this requires that chunks will always be non-empty+       recourse _ _ = False+   in  recourse xs0 ys0 +index :: (Storable a) => Vector a -> Int -> a+index (SV xs) n =+   if n < 0+     then+        moduleError "index"+           ("negative index: " List.++ show n)+     else+        List.foldr+           (\x k m0 ->+              let m1 = m0 - V.length x+              in  if m1 < 0+                    then VB.unsafeIndex x m0+                    else k m1)+           (\m -> moduleError "index"+                     ("index too large: " List.++ show n+                      List.++ ", length = " List.++ show (n-m)))+           xs n++ {-# NOINLINE [0] cons #-} cons :: Storable a => a -> Vector a -> Vector a cons x = SV . (V.singleton x :) . chunks@@ -275,6 +312,11 @@  -- * inspecting a vector +{-# INLINE pointer #-}+pointer :: Storable a => Vector a -> Ptr.Pointer a+pointer x =+   Ptr.Pointer (chunks x) 0+ {-# INLINE viewL #-} viewL :: Storable a => Vector a -> Maybe (a, Vector a) viewL (SV xs0) =@@ -286,7 +328,7 @@ viewR :: Storable a => Vector a -> Maybe (Vector a, a) viewR (SV xs0) =    do ~(xs,x) <- ListHT.viewR xs0-      let (ys,y) = fromMaybe (error "StorableVector.Lazy.viewR: last chunk empty") (V.viewR x)+      let (ys,y) = fromMaybe (moduleError "viewR" "last chunk empty") (V.viewR x)       return (append (SV xs) (fromChunk ys), y)  {-# INLINE switchL #-}@@ -492,7 +534,8 @@    -> Vector b    -> Vector c zipWith f =-   crochetL (\y -> liftM (mapFst (flip f y)) . viewL)+   crochetL (\y -> liftM (mapFst (flip f y)) . Ptr.viewL)+    . pointer  {-# INLINE zipWith3 #-} zipWith3 ::@@ -503,9 +546,9 @@    crochetL (\z (xt,yt) ->       liftM2          (\(x,xs) (y,ys) -> (f x y z, (xs,ys)))-         (viewL xt)-         (viewL yt))-      (s0,s1)+         (Ptr.viewL xt)+         (Ptr.viewL yt))+      (pointer s0, pointer s1)  {-# INLINE zipWith4 #-} zipWith4 ::@@ -516,25 +559,26 @@    crochetL (\w (xt,yt,zt) ->       liftM3          (\(x,xs) (y,ys) (z,zs) -> (f x y z w, (xs,ys,zs)))-         (viewL xt)-         (viewL yt)-         (viewL zt))-      (s0,s1,s2)+         (Ptr.viewL xt)+         (Ptr.viewL yt)+         (Ptr.viewL zt))+      (pointer s0, pointer s1, pointer s2)  -{-# INLINE [0] zipWithSize #-}+{-# INLINE zipWithSize #-} zipWithSize :: (Storable a, Storable b, Storable c) =>       ChunkSize    -> (a -> b -> c)    -> Vector a    -> Vector b    -> Vector c-zipWithSize size f =-   curry (unfoldr size (\(xt,yt) ->+zipWithSize size f s0 s1 =+   unfoldr size (\(xt,yt) ->       liftM2          (\(x,xs) (y,ys) -> (f x y, (xs,ys)))-         (viewL xt)-         (viewL yt)))+         (Ptr.viewL xt)+         (Ptr.viewL yt))+      (pointer s0, pointer s1)  {-# INLINE zipWithSize3 #-} zipWithSize3 ::@@ -546,10 +590,10 @@       liftM3          (\(x,xs) (y,ys) (z,zs) ->              (f x y z, (xs,ys,zs)))-         (viewL xt)-         (viewL yt)-         (viewL zt))-      (s0,s1,s2)+         (Ptr.viewL xt)+         (Ptr.viewL yt)+         (Ptr.viewL zt))+      (pointer s0, pointer s1, pointer s2)  {-# INLINE zipWithSize4 #-} zipWithSize4 ::@@ -561,11 +605,11 @@       liftM4          (\(x,xs) (y,ys) (z,zs) (w,ws) ->              (f x y z w, (xs,ys,zs,ws)))-         (viewL xt)-         (viewL yt)-         (viewL zt)-         (viewL wt))-      (s0,s1,s2,s3)+         (Ptr.viewL xt)+         (Ptr.viewL yt)+         (Ptr.viewL zt)+         (Ptr.viewL wt))+      (pointer s0, pointer s1, pointer s2, pointer s3)   {- |@@ -1130,3 +1174,9 @@ appendFile :: Storable a => FilePath -> Vector a -> IO () appendFile path =    bracket (openBinaryFile path AppendMode) hClose . flip hPut+++{-# NOINLINE moduleError #-}+moduleError :: String -> String -> a+moduleError fun msg =+   error ("Data.StorableVector.Lazy." List.++ fun List.++ ':':' ':msg)
+ Data/StorableVector/Lazy/Pointer.hs view
@@ -0,0 +1,20 @@+{- |+In principle you can traverse through a lazy storable vector+using repeated calls to @viewL@.+However this needs a bit of pointer arrangement and allocation.+This data structure makes the inner loop faster,+that consists of traversing through a chunk.+-}+module Data.StorableVector.Lazy.Pointer (+   Pointer, cons, viewL, switchL,+   ) where++import Data.StorableVector.Lazy.PointerPrivate (Pointer(..), viewL, switchL, )+import qualified Data.StorableVector.Lazy as VL++import Foreign.Storable (Storable)+++{-# INLINE cons #-}+cons :: Storable a => VL.Vector a -> Pointer a+cons = VL.pointer
+ Data/StorableVector/Lazy/PointerPrivate.hs view
@@ -0,0 +1,31 @@+module Data.StorableVector.Lazy.PointerPrivate where++import qualified Data.StorableVector as V+import qualified Data.StorableVector.Base as VB++import Foreign.Storable (Storable)+++data Pointer a =+   Pointer {chunks :: ![VB.Vector a], index :: !Int}+++{-# INLINE viewL #-}+viewL :: Storable a => Pointer a -> Maybe (a, Pointer a)+viewL = switchL Nothing (curry Just)++{-# INLINE switchL #-}+switchL :: Storable a =>+   b -> (a -> Pointer a -> b) -> Pointer a -> b+switchL n j =+   let recourse p =+          let s = chunks p+          in  case s of+                 [] -> n+                 (c:cs) ->+                    let i = index p+                        d = i - V.length c+                    in  if d < 0+                          then j (VB.unsafeIndex c i) (Pointer s (i+1))+                          else recourse (Pointer cs d)+   in  recourse
+ speedtest/Pointer.hs view
@@ -0,0 +1,79 @@+{-# OPTIONS_GHC -O -ddump-simpl-stats #-}+{-  -dverbose-core2core -}+module Main (main) where++import qualified Data.StorableVector.Lazy as SV+import qualified Data.StorableVector.Lazy.Pointer as Pointer++import Data.Tuple.HT (mapFst, )+import Control.Monad (liftM, liftM2, )++import Data.Int (Int16)+import Foreign.Storable (Storable)++import Prelude hiding (zipWith, )+++{-# INLINE zipWith #-}+zipWith :: (Storable a, Storable b, Storable c) =>+      (a -> b -> c)+   -> SV.Vector a+   -> SV.Vector b+   -> SV.Vector c+zipWith f =+   SV.crochetL (\y -> liftM (mapFst (flip f y)) . SV.viewL)+++{-# INLINE zipWithPointer #-}+zipWithPointer :: (Storable a, Storable b, Storable c) =>+      (a -> b -> c)+   -> SV.Vector a+   -> SV.Vector b+   -> SV.Vector c+zipWithPointer f =+   SV.crochetL (\y -> liftM (mapFst (flip f y)) . Pointer.viewL)+    . Pointer.cons+++{-# INLINE zipWithSize #-}+zipWithSize :: (Storable a, Storable b, Storable c) =>+      SV.ChunkSize+   -> (a -> b -> c)+   -> SV.Vector a+   -> SV.Vector b+   -> SV.Vector c+zipWithSize size f =+   curry (SV.unfoldr size (\(xt,yt) ->+      liftM2+         (\(x,xs) (y,ys) -> (f x y, (xs,ys)))+         (SV.viewL xt)+         (SV.viewL yt)))++{-# INLINE zipWithPointerSize #-}+zipWithPointerSize :: (Storable a, Storable b, Storable c) =>+      SV.ChunkSize+   -> (a -> b -> c)+   -> SV.Vector a+   -> SV.Vector b+   -> SV.Vector c+zipWithPointerSize size f a0 b0 =+   SV.unfoldr size (\(xt,yt) ->+      liftM2+         (\(x,xs) (y,ys) -> (f x y, (xs,ys)))+         (Pointer.viewL xt)+         (Pointer.viewL yt))+      (Pointer.cons a0, Pointer.cons b0)+++main :: IO ()+main =+   print $+   SV.foldl' (+) 0 $+   SV.take 10000000 $+   (case 1 of+      0 -> zipWith (+)+      1 -> zipWithPointer (+)+      2 -> zipWithSize SV.defaultChunkSize (+)+      3 -> zipWithPointerSize SV.defaultChunkSize (+))+         (SV.iterate SV.defaultChunkSize (subtract 1) 0)+         (SV.iterate SV.defaultChunkSize (1+) (0::Int16))
storablevector.cabal view
@@ -1,5 +1,5 @@ Name:                storablevector-Version:             0.2.3.1+Version:             0.2.4 Category:            Data Synopsis:            Fast, packed, strict storable arrays with a list interface like ByteString Description:@@ -44,7 +44,7 @@ Source-Repository this   type:     darcs   location: http://code.haskell.org/storablevector/-  tag:      0.2.3.1+  tag:      0.2.4  Library   Build-Depends:@@ -72,6 +72,7 @@     Data.StorableVector.Lazy     Data.StorableVector.Lazy.Builder     Data.StorableVector.Lazy.Pattern+    Data.StorableVector.Lazy.Pointer     Data.StorableVector.ST.Strict     Data.StorableVector.ST.Lazy @@ -80,6 +81,7 @@     Data.StorableVector.Cursor     Data.StorableVector.Memory     Data.StorableVector.ST.Private+    Data.StorableVector.Lazy.PointerPrivate   @@ -102,6 +104,18 @@ Executable speedtest   GHC-Options:         -Wall -funbox-strict-fields   Main-Is:             SpeedTestLazy.hs+  Extensions:          CPP, ForeignFunctionInterface+  Hs-Source-Dirs:      ., slow-foreign-ptr, speedtest+  If flag(splitBase)+    Build-Depends:     base >= 3 && <5+  Else+    Build-Depends:     base >= 1.0 && < 2+  If !flag(buildTests)+    Buildable:         False++Executable speedpointer+  GHC-Options:         -Wall -funbox-strict-fields+  Main-Is:             Pointer.hs   Extensions:          CPP, ForeignFunctionInterface   Hs-Source-Dirs:      ., slow-foreign-ptr, speedtest   If flag(splitBase)