diff --git a/Data/Vector/Fusion/Stream/Monadic.hs b/Data/Vector/Fusion/Stream/Monadic.hs --- a/Data/Vector/Fusion/Stream/Monadic.hs +++ b/Data/Vector/Fusion/Stream/Monadic.hs @@ -104,7 +104,12 @@ {-# ANN type SPEC ForceSpecConstr #-} #endif +emptyStream :: String +{-# NOINLINE emptyStream #-} +emptyStream = "empty stream" +#define EMPTY_STREAM (\s -> ERROR s emptyStream) + -- | Result of taking a single step in a stream data Step s a = Yield a s -- ^ a new element and a new seed | Skip s -- ^ just a new seed @@ -230,7 +235,7 @@ case r of Yield x _ -> return x Skip s' -> head_loop SPEC s' - Done -> BOUNDS_ERROR(emptyStream) "head" + Done -> EMPTY_STREAM "head" @@ -245,7 +250,7 @@ case r of Yield x s' -> last_loop1 SPEC x s' Skip s' -> last_loop0 SPEC s' - Done -> BOUNDS_ERROR(emptyStream) "last" + Done -> EMPTY_STREAM "last" last_loop1 !sPEC x s = do @@ -259,7 +264,7 @@ -- | Element at the given position (!!) :: Monad m => Stream m a -> Int -> m a {-# INLINE (!!) #-} -Stream step s _ !! i | i < 0 = BOUNDS_ERROR(error) "!!" "negative index" +Stream step s _ !! i | i < 0 = ERROR "!!" "negative index" | otherwise = index_loop SPEC s i where index_loop !sPEC s i @@ -270,7 +275,7 @@ Yield x s' | i == 0 -> return x | otherwise -> index_loop SPEC s' (i-1) Skip s' -> index_loop SPEC s' i - Done -> BOUNDS_ERROR(emptyStream) "!!" + Done -> EMPTY_STREAM "!!" infixl 9 !? -- | Element at the given position or 'Nothing' if out of bounds @@ -309,7 +314,7 @@ case r of Yield x s' -> Skip (Just x, s') Skip s' -> Skip (Nothing, s') - Done -> BOUNDS_ERROR(emptyStream) "init" + Done -> EMPTY_STREAM "init" ) (step s) step' (Just x, s) = liftM (\r -> @@ -329,7 +334,7 @@ case r of Yield x s' -> Skip (Right s') Skip s' -> Skip (Left s') - Done -> BOUNDS_ERROR(emptyStream) "tail" + Done -> EMPTY_STREAM "tail" ) (step s) step' (Right s) = liftM (\r -> @@ -797,7 +802,7 @@ case r of Yield x s' -> foldlM f x (Stream step s' (sz - 1)) Skip s' -> foldl1M_loop SPEC s' - Done -> BOUNDS_ERROR(emptyStream) "foldl1M" + Done -> EMPTY_STREAM "foldl1M" -- | Same as 'foldl1M' fold1M :: Monad m => (a -> a -> m a) -> Stream m a -> m a @@ -845,7 +850,7 @@ case r of Yield x s' -> foldlM' f x (Stream step s' (sz - 1)) Skip s' -> foldl1M'_loop SPEC s' - Done -> BOUNDS_ERROR(emptyStream) "foldl1M'" + Done -> EMPTY_STREAM "foldl1M'" -- | Same as 'foldl1M'' fold1M' :: Monad m => (a -> a -> m a) -> Stream m a -> m a @@ -886,7 +891,7 @@ case r of Yield x s' -> foldr1M_loop1 SPEC x s' Skip s' -> foldr1M_loop0 SPEC s' - Done -> BOUNDS_ERROR(emptyStream) "foldr1M" + Done -> EMPTY_STREAM "foldr1M" foldr1M_loop1 !sPEC x s = do @@ -1147,7 +1152,7 @@ case r of Yield x s' -> return $ Yield x (s', Just x) Skip s' -> return $ Skip (s', Nothing) - Done -> BOUNDS_ERROR(emptyStream) "scanl1M" + Done -> EMPTY_STREAM "scanl1M" step' (s, Just x) = do r <- step s @@ -1175,7 +1180,7 @@ case r of Yield x s' -> x `seq` return (Yield x (s', Just x)) Skip s' -> return $ Skip (s', Nothing) - Done -> BOUNDS_ERROR(emptyStream) "scanl1M" + Done -> EMPTY_STREAM "scanl1M" step' (s, Just x) = x `seq` do diff --git a/Data/Vector/Internal/Check.hs b/Data/Vector/Internal/Check.hs --- a/Data/Vector/Internal/Check.hs +++ b/Data/Vector/Internal/Check.hs @@ -10,16 +10,42 @@ -- Bounds checking infrastructure -- +{-# LANGUAGE MagicHash #-} + module Data.Vector.Internal.Check ( Checks(..), doChecks, - error, emptyStream, - check, assert, checkIndex, checkLength, checkSlice + error, internalError, + check, checkIndex, checkLength, checkSlice ) where -import Prelude hiding( error ) +import GHC.Base( Int(..) ) +import GHC.Prim( Int# ) +import Prelude hiding( error, (&&), (||), not ) import qualified Prelude as P +-- NOTE: This is a workaround for GHC's weird behaviour where it doesn't inline +-- these functions into unfoldings which makes the intermediate code size +-- explode. See http://hackage.haskell.org/trac/ghc/ticket/5539. +infixr 2 || +infixr 3 && + +not :: Bool -> Bool +{-# INLINE not #-} +not True = False +not False = True + +(&&) :: Bool -> Bool -> Bool +{-# INLINE (&&) #-} +False && x = False +True && x = x + +(||) :: Bool -> Bool -> Bool +{-# INLINE (||) #-} +True || x = True +False || x = x + + data Checks = Bounds | Unsafe | Internal deriving( Eq ) doBoundsChecks :: Bool @@ -50,37 +76,44 @@ doChecks Unsafe = doUnsafeChecks doChecks Internal = doInternalChecks -error :: String -> Int -> Checks -> String -> String -> a -error file line kind loc msg - = P.error $ unlines $ - (if kind == Internal - then (["*** Internal error in package vector ***" - ,"*** Please submit a bug report at http://trac.haskell.org/vector"]++) - else id) $ - [ file ++ ":" ++ show line ++ " (" ++ loc ++ "): " ++ msg ] +error_msg :: String -> Int -> String -> String -> String +error_msg file line loc msg = file ++ ":" ++ show line ++ " (" ++ loc ++ "): " ++ msg -emptyStream :: String -> Int -> Checks -> String -> a -{-# NOINLINE emptyStream #-} -emptyStream file line kind loc - = error file line kind loc "empty stream" +error :: String -> Int -> String -> String -> a +{-# NOINLINE error #-} +error file line loc msg + = P.error $ error_msg file line loc msg +internalError :: String -> Int -> String -> String -> a +{-# NOINLINE internalError #-} +internalError file line loc msg + = P.error $ unlines + ["*** Internal error in package vector ***" + ,"*** Please submit a bug report at http://trac.haskell.org/vector" + ,error_msg file line loc msg] + + +checkError :: String -> Int -> Checks -> String -> String -> a +{-# NOINLINE checkError #-} +checkError file line kind loc msg + = case kind of + Internal -> internalError file line loc msg + _ -> error file line loc msg + check :: String -> Int -> Checks -> String -> String -> Bool -> a -> a {-# INLINE check #-} check file line kind loc msg cond x | not (doChecks kind) || cond = x - | otherwise = error file line kind loc msg - -assert_msg :: String -assert_msg = "assertion failure" - -assert :: String -> Int -> Checks -> String -> Bool -> a -> a -{-# INLINE assert #-} -assert file line kind loc = check file line kind loc assert_msg + | otherwise = checkError file line kind loc msg checkIndex_msg :: Int -> Int -> String -{-# NOINLINE checkIndex_msg #-} -checkIndex_msg i n = "index out of bounds " ++ show (i,n) +{-# INLINE checkIndex_msg #-} +checkIndex_msg (I# i#) (I# n#) = checkIndex_msg# i# n# +checkIndex_msg# :: Int# -> Int# -> String +{-# NOINLINE checkIndex_msg# #-} +checkIndex_msg# i# n# = "index out of bounds " ++ show (I# i#, I# n#) + checkIndex :: String -> Int -> Checks -> String -> Int -> Int -> a -> a {-# INLINE checkIndex #-} checkIndex file line kind loc i n x @@ -88,9 +121,13 @@ checkLength_msg :: Int -> String -{-# NOINLINE checkLength_msg #-} -checkLength_msg n = "negative length " ++ show n +{-# INLINE checkLength_msg #-} +checkLength_msg (I# n#) = checkLength_msg# n# +checkLength_msg# :: Int# -> String +{-# NOINLINE checkLength_msg# #-} +checkLength_msg# n# = "negative length " ++ show (I# n#) + checkLength :: String -> Int -> Checks -> String -> Int -> a -> a {-# INLINE checkLength #-} checkLength file line kind loc n x @@ -98,8 +135,12 @@ checkSlice_msg :: Int -> Int -> Int -> String -{-# NOINLINE checkSlice_msg #-} -checkSlice_msg i m n = "invalid slice " ++ show (i,m,n) +{-# INLINE checkSlice_msg #-} +checkSlice_msg (I# i#) (I# m#) (I# n#) = checkSlice_msg# i# m# n# + +checkSlice_msg# :: Int# -> Int# -> Int# -> String +{-# NOINLINE checkSlice_msg# #-} +checkSlice_msg# i# m# n# = "invalid slice " ++ show (I# i#, I# m#, I# n#) checkSlice :: String -> Int -> Checks -> String -> Int -> Int -> Int -> a -> a {-# INLINE checkSlice #-} diff --git a/Data/Vector/Storable.hs b/Data/Vector/Storable.hs --- a/Data/Vector/Storable.hs +++ b/Data/Vector/Storable.hs @@ -131,7 +131,9 @@ freeze, thaw, copy, unsafeFreeze, unsafeThaw, unsafeCopy, -- * Raw pointers - unsafeFromForeignPtr, unsafeToForeignPtr, unsafeWith + unsafeFromForeignPtr, unsafeFromForeignPtr0, + unsafeToForeignPtr, unsafeToForeignPtr0, + unsafeWith ) where import qualified Data.Vector.Generic as G @@ -1359,20 +1361,52 @@ -- -------------------------- -- | /O(1)/ Create a vector from a 'ForeignPtr' with an offset and a length. +-- -- The data may not be modified through the 'ForeignPtr' afterwards. +-- +-- If your offset is 0 it is more efficient to use 'unsafeFromForeignPtr0'. unsafeFromForeignPtr :: Storable a => ForeignPtr a -- ^ pointer -> Int -- ^ offset -> Int -- ^ length -> Vector a {-# INLINE unsafeFromForeignPtr #-} -unsafeFromForeignPtr fp i n = Vector n (updPtr (`advancePtr` i) fp) +unsafeFromForeignPtr fp i n = unsafeFromForeignPtr0 fp' n + where + fp' = updPtr (`advancePtr` i) fp +{-# RULES +"unsafeFromForeignPtr fp 0 n -> unsafeFromForeignPtr0 fp n " forall fp n. + unsafeFromForeignPtr fp 0 n = unsafeFromForeignPtr0 fp n + #-} + +-- | /O(1)/ Create a vector from a 'ForeignPtr' and a length. +-- +-- It is assumed the pointer points directly to the data (no offset). +-- Use `unsafeFromForeignPtr` if you need to specify an offset. +-- +-- The data may not be modified through the 'ForeignPtr' afterwards. +unsafeFromForeignPtr0 :: Storable a + => ForeignPtr a -- ^ pointer + -> Int -- ^ length + -> Vector a +{-# INLINE unsafeFromForeignPtr0 #-} +unsafeFromForeignPtr0 fp n = Vector n fp + -- | /O(1)/ Yield the underlying 'ForeignPtr' together with the offset to the -- data and its length. The data may not be modified through the 'ForeignPtr'. unsafeToForeignPtr :: Storable a => Vector a -> (ForeignPtr a, Int, Int) {-# INLINE unsafeToForeignPtr #-} unsafeToForeignPtr (Vector n fp) = (fp, 0, n) + +-- | /O(1)/ Yield the underlying 'ForeignPtr' together with its length. +-- +-- You can assume the pointer points directly to the data (no offset). +-- +-- The data may not be modified through the 'ForeignPtr'. +unsafeToForeignPtr0 :: Storable a => Vector a -> (ForeignPtr a, Int) +{-# INLINE unsafeToForeignPtr0 #-} +unsafeToForeignPtr0 (Vector n fp) = (fp, n) -- | Pass a pointer to the vector's data to the IO action. The data may not be -- modified through the 'Ptr. diff --git a/Data/Vector/Storable/Mutable.hs b/Data/Vector/Storable/Mutable.hs --- a/Data/Vector/Storable/Mutable.hs +++ b/Data/Vector/Storable/Mutable.hs @@ -52,7 +52,9 @@ unsafeCast, -- * Raw pointers - unsafeFromForeignPtr, unsafeToForeignPtr, unsafeWith + unsafeFromForeignPtr, unsafeFromForeignPtr0, + unsafeToForeignPtr, unsafeToForeignPtr0, + unsafeWith ) where import qualified Data.Vector.Generic.Mutable as G @@ -386,22 +388,56 @@ -- ------------ -- | Create a mutable vector from a 'ForeignPtr' with an offset and a length. +-- -- Modifying data through the 'ForeignPtr' afterwards is unsafe if the vector -- could have been frozen before the modification. +-- +-- If your offset is 0 it is more efficient to use 'unsafeFromForeignPtr0'. unsafeFromForeignPtr :: Storable a => ForeignPtr a -- ^ pointer -> Int -- ^ offset -> Int -- ^ length -> MVector s a {-# INLINE unsafeFromForeignPtr #-} -unsafeFromForeignPtr fp i n = MVector n (updPtr (`advancePtr` i) fp) +unsafeFromForeignPtr fp i n = unsafeFromForeignPtr0 fp' n + where + fp' = updPtr (`advancePtr` i) fp +{-# RULES +"unsafeFromForeignPtr fp 0 n -> unsafeFromForeignPtr0 fp n " forall fp n. + unsafeFromForeignPtr fp 0 n = unsafeFromForeignPtr0 fp n + #-} + +-- | /O(1)/ Create a mutable vector from a 'ForeignPtr' and a length. +-- +-- It is assumed the pointer points directly to the data (no offset). +-- Use `unsafeFromForeignPtr` if you need to specify an offset. +-- +-- Modifying data through the 'ForeignPtr' afterwards is unsafe if the vector +-- could have been frozen before the modification. +unsafeFromForeignPtr0 :: Storable a + => ForeignPtr a -- ^ pointer + -> Int -- ^ length + -> MVector s a +{-# INLINE unsafeFromForeignPtr0 #-} +unsafeFromForeignPtr0 fp n = MVector n fp + -- | Yield the underlying 'ForeignPtr' together with the offset to the data -- and its length. Modifying the data through the 'ForeignPtr' is -- unsafe if the vector could have frozen before the modification. unsafeToForeignPtr :: Storable a => MVector s a -> (ForeignPtr a, Int, Int) {-# INLINE unsafeToForeignPtr #-} unsafeToForeignPtr (MVector n fp) = (fp, 0, n) + +-- | /O(1)/ Yield the underlying 'ForeignPtr' together with its length. +-- +-- You can assume the pointer points directly to the data (no offset). +-- +-- Modifying the data through the 'ForeignPtr' is unsafe if the vector could +-- have frozen before the modification. +unsafeToForeignPtr0 :: Storable a => MVector s a -> (ForeignPtr a, Int) +{-# INLINE unsafeToForeignPtr0 #-} +unsafeToForeignPtr0 (MVector n fp) = (fp, n) -- | Pass a pointer to the vector's data to the IO action. Modifying data -- through the pointer is unsafe if the vector could have been frozen before diff --git a/benchmarks/vector-benchmarks.cabal b/benchmarks/vector-benchmarks.cabal --- a/benchmarks/vector-benchmarks.cabal +++ b/benchmarks/vector-benchmarks.cabal @@ -1,5 +1,5 @@ Name: vector-benchmarks -Version: 0.8 +Version: 0.9.1 License: BSD3 License-File: LICENSE Author: Roman Leshchinskiy @@ -14,7 +14,7 @@ Build-Depends: base >= 2 && < 5, array, criterion >= 0.5 && < 0.6, mwc-random >= 0.5 && < 0.11, - vector == 0.8 + vector == 0.9.1 if impl(ghc<6.13) Ghc-Options: -finline-if-enough-args -fno-method-sharing diff --git a/include/vector.h b/include/vector.h --- a/include/vector.h +++ b/include/vector.h @@ -8,24 +8,12 @@ import qualified Data.Vector.Internal.Check as Ck #endif -#define ERROR(f) (Ck.f __FILE__ __LINE__) -#define ASSERT (Ck.assert __FILE__ __LINE__) -#define ENSURE (Ck.f __FILE__ __LINE__) -#define CHECK(f) (Ck.f __FILE__ __LINE__) +#define ERROR (Ck.error __FILE__ __LINE__) +#define INTERNAL_ERROR (Ck.internalError __FILE__ __LINE__) -#define BOUNDS_ERROR(f) (ERROR(f) Ck.Bounds) -#define BOUNDS_ASSERT (ASSERT Ck.Bounds) -#define BOUNDS_ENSURE (ENSURE Ck.Bounds) +#define CHECK(f) (Ck.f __FILE__ __LINE__) #define BOUNDS_CHECK(f) (CHECK(f) Ck.Bounds) - -#define UNSAFE_ERROR(f) (ERROR(f) Ck.Unsafe) -#define UNSAFE_ASSERT (ASSERT Ck.Unsafe) -#define UNSAFE_ENSURE (ENSURE Ck.Unsafe) #define UNSAFE_CHECK(f) (CHECK(f) Ck.Unsafe) - -#define INTERNAL_ERROR(f) (ERROR(f) Ck.Internal) -#define INTERNAL_ASSERT (ASSERT Ck.Internal) -#define INTERNAL_ENSURE (ENSURE Ck.Internal) #define INTERNAL_CHECK(f) (CHECK(f) Ck.Internal) diff --git a/tests/vector-tests.cabal b/tests/vector-tests.cabal --- a/tests/vector-tests.cabal +++ b/tests/vector-tests.cabal @@ -1,5 +1,5 @@ Name: vector-tests -Version: 0.8 +Version: 0.9.1 License: BSD3 License-File: LICENSE Author: Max Bolingbroke, Roman Leshchinskiy @@ -18,7 +18,7 @@ Executable "vector-tests-O0" Main-Is: Main.hs - Build-Depends: base >= 4 && < 5, template-haskell, vector == 0.8, + Build-Depends: base >= 4 && < 5, template-haskell, vector == 0.9.1, random, QuickCheck >= 2, test-framework, test-framework-quickcheck2 @@ -38,7 +38,7 @@ Executable "vector-tests-O2" Main-Is: Main.hs - Build-Depends: base >= 4 && < 5, template-haskell, vector == 0.8, + Build-Depends: base >= 4 && < 5, template-haskell, vector == 0.9.1, random, QuickCheck >= 2, test-framework, test-framework-quickcheck2 diff --git a/vector.cabal b/vector.cabal --- a/vector.cabal +++ b/vector.cabal @@ -1,5 +1,5 @@ Name: vector -Version: 0.9 +Version: 0.9.1 License: BSD3 License-File: LICENSE Author: Roman Leshchinskiy @@ -41,6 +41,14 @@ . * . + Changes in version 0.9.1 + . + * New functions: @unsafeFromForeignPtr0@ and @unsafeToForeignPtr0@ + . + * Small performance improvements + . + * Fixes for GHC 7.4 + . Changes in version 0.9 . * 'MonadPlus' instance for boxed vectors @@ -162,7 +170,7 @@ Install-Includes: vector.h - Build-Depends: base >= 4 && < 5, primitive >= 0.4.0.1 && < 0.5 + Build-Depends: base >= 4 && < 5, primitive >= 0.4.0.1 && < 0.5, ghc-prim if impl(ghc<6.13) Ghc-Options: -finline-if-enough-args -fno-method-sharing