diff --git a/Benchmarks/Index.hs b/Benchmarks/Index.hs deleted file mode 100644 --- a/Benchmarks/Index.hs +++ /dev/null @@ -1,51 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE ScopedTypeVariables #-} - --- | Benchmark the folding functions. As these functions need several tables to --- read data from, we have to initialize some stuff. The benchmarks test access --- and calculation patterns that are common in bioinformatics. --- --- For best results, compile with "-Odph -fllvm" (6.13) or "-Odph" (6.12). This --- is for the unboxed vectors. Both benchmarks should clock at about 10us. - -module Main where - -import Criterion.Main -import Control.DeepSeq -import System.Random -import qualified Data.Vector.Unboxed as VU - -import Data.PrimitiveArray -import Data.PrimitiveArray.Ix -import Data.Primitive.Types - - - -hi = 999 - -main = do - rng <- getStdGen - let (table :: PrimArray (Int,Int) Int) = fromAssocs (0,0) (hi,hi) 0 $ zip - [ (i,j) - | i<-[0..hi] - , j<-[0..hi] - ] $ randomRs (0,hi) rng - print $ table ! (0,0) - print $ table ! (hi,hi) - defaultMain - [ bgroup "compare" - [ bench "unsafeIndex" $ - whnf (\k -> {-# CORE "sum/unsafeIndex" #-} - VU.foldl' min 999999 $ - VU.map (\ij -> table ! ij) $ - VU.generate k (\z -> (z,z)) - ) hi - , bench "twiceIndex" $ - whnf (\k -> {-# CORE "sum/twiceIndex" #-} - VU.foldl' min 999999 $ - VU.map (\(i,j) -> (table ! (i,0)) + (table ! (0,j))) $ - VU.generate k (\z -> (z,z)) - ) hi - ] - ] diff --git a/Data/PrimitiveArray.hs b/Data/PrimitiveArray.hs --- a/Data/PrimitiveArray.hs +++ b/Data/PrimitiveArray.hs @@ -1,94 +1,46 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RankNTypes #-} --- | Unboxed, primitive, multidimensional tables. In instance for 'Ix'-type --- keys comes with the package. This package trades safety for speed. The index --- operator (!) is basically the only function that does bounds-checking and --- only with an assertion. This, however, is by design. The only way to get an --- immutable table from a mutable one is by the 'unsafeFreezeM' operation. --- Again, it is by design that both data structures share the same memory --- pointer internally. +-- | Primitive arrays with a small set of operations. Modelled after repa +-- arrays and indexing. -- --- TODO We kind-of lost all but the ST monad for monadic operations. +-- Array indexing is between [i..j] per dimension. +-- +-- All operations are UNSAFE. In interpreted code, "assert" provides a safety +-- net. module Data.PrimitiveArray where import Control.Monad.Primitive (PrimMonad) +import Data.Array.Repa.Shape (Shape) import Control.Exception (assert) -import Text.Read.Lex as L -import Text.Read -import Text.ParserCombinators.ReadP --- * The PrimArray class. -class PrimArrayOps a b where - -- | PrimArray data type - data PrimArray a b :: * - unsafeIndex :: PrimArray a b -> a -> b -- ^ Index an array without bounds-checking - assocs :: PrimArray a b -> [(a,b)] -- ^ All associations of (key,value) - fromAssocs :: a -> a -> b -> [(a,b)] -> PrimArray a b -- ^ Pure build function - bounds :: PrimArray a b -> (a,a) -- ^ Min- and maxbound of all dimensions - checkBounds :: PrimArray a b -> a -> Bool -- ^ Check if index is within bounds - fromList :: a -> a -> [b] -> PrimArray a b -- ^ Build the /complete/ table from a list - toList :: PrimArray a b -> [b] -- ^ Read the complete table as a list +class Shape sh => PrimArrayOps sh elm where + data PrimArray sh elm :: * + unsafeIndex :: PrimArray sh elm -> sh -> elm + bounds :: PrimArray sh elm -> (sh,sh) + inBounds :: PrimArray sh elm -> sh -> Bool + fromAssocs :: sh -> sh -> elm -> [(sh,elm)] -> PrimArray sh elm + assocs :: PrimArray sh elm -> [(sh,elm)] -class (PrimMonad s) => PrimArrayOpsM a b s where - -- | Monadic data type - data PrimArrayM a b s :: * - readM :: PrimArrayM a b s -> a -> s b -- ^ Monadic read - writeM :: PrimArrayM a b s -> a -> b -> s () -- ^ Monadic write - boundsM :: PrimArrayM a b s -> s (a,a) -- ^ Monadic bounds - fromAssocsM :: a -> a -> b -> [(a,b)] -> s (PrimArrayM a b s) -- ^ Build monadic array from assocs - unsafeFreezeM :: PrimArrayM a b s -> s (PrimArray a b) -- ^ UNSAFE freezing of array. - fromListM :: a -> a -> [b] -> s (PrimArrayM a b s) -- ^ Build the /complete/ monadic table from a list - toListM :: PrimArrayM a b s -> s [b] -- ^ Read the complete monadic table as a list +class (PrimMonad m, Shape sh) => PrimArrayOpsM sh elm m where + data PrimArrayM sh elm m :: * + readM :: PrimArrayM sh elm m -> sh -> m elm + writeM :: PrimArrayM sh elm m -> sh -> elm -> m () + -- | Create a monadic array from a list of associations + fromAssocsM :: sh -> sh -> elm -> [(sh,elm)] -> m (PrimArrayM sh elm m) + unsafeFreezeM :: PrimArrayM sh elm m -> m (PrimArray sh elm) + boundsM :: PrimArrayM sh elm m -> (sh,sh) + inBoundsM :: PrimArrayM sh elm m -> sh -> Bool --- * Helper functions. - --- | Asserting 'unsafeIndex'. Debug-code is checked for out-of-bounds --- occurances while production code uses unsafeIndex directly. +-- * Helper functions -(!) :: (PrimArrayOps a b) => PrimArray a b -> a -> b -(!) pa idx = assert (checkBounds pa idx) $ unsafeIndex pa idx +(!) :: PrimArrayOps sh elm => PrimArray sh elm -> sh -> elm +(!) pa idx = assert (inBounds pa idx) $ unsafeIndex pa idx {-# INLINE (!) #-} --- | Create a new array from an old one, mapping a function over all values. - -amap :: (PrimArrayOps a b, PrimArrayOps a c) => (b -> c) -> PrimArray a b -> PrimArray a c -amap f pa = fromList lb ub $ map f $ toList pa where - (lb,ub) = bounds pa - - - --- * Read and show instances - --- | The Show instance looks a bit like Show for Data.Vector.Unboxed - -instance (Bounded a, Show a, Show b, PrimArrayOps a b) => Show (PrimArray a b) where - show pa = "fromList " ++ show l ++ " " ++ show u ++ " " ++ (show $ toList pa) ++ " :: Data.PrimitiveArray.PrimitiveArray" where - (l,u) = bounds pa - --- | The Read instance follows Read for Data.Vector.Unboxed - -instance (Bounded a, Read a, Read b, PrimArrayOps a b) => Read (PrimArray a b) where - readPrec = - parens $ do - lift $ skipSpaces - L.Ident "fromList" <- lexP - lift $ skipSpaces - (l :: a) <- readPrec - lift $ skipSpaces - (u :: a) <- readPrec - (vals :: [b]) <- readPrec - lift $ skipSpaces - lift $ string "::" - lift $ skipSpaces - lift $ string "Data.PrimitiveArray.PrimitiveArray" - lift $ skipSpaces - return $ fromList l u vals - readListPrec = readListPrecDefault - readList = readListDefault diff --git a/Data/PrimitiveArray/Internal.hs b/Data/PrimitiveArray/Internal.hs deleted file mode 100644 --- a/Data/PrimitiveArray/Internal.hs +++ /dev/null @@ -1,23 +0,0 @@ - --- | Helper functions for creating new arrays. - -module Data.PrimitiveArray.Internal where - -import Data.Primitive -import Control.Monad.ST -import Control.Monad (forM_) - --- | Create a new m-array with a default value. - -newWith :: (Prim a) => Int -> a -> ST s (MutableByteArray s) -newWith l z = do - marr <- new l z - forM_ [0..l-1] $ \k -> (writeByteArray marr k z) - return marr - --- | In 'new', 'z' is not used. - -new :: (Prim a) => Int -> a -> ST s (MutableByteArray s) -new l z = do - marr <- newByteArray (l * sizeOf z) - return marr diff --git a/Data/PrimitiveArray/Ix.hs b/Data/PrimitiveArray/Ix.hs deleted file mode 100644 --- a/Data/PrimitiveArray/Ix.hs +++ /dev/null @@ -1,68 +0,0 @@ - -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE MultiParamTypeClasses #-} - --- | PrimitiveArray with 'Ix' keys. - -module Data.PrimitiveArray.Ix where - -import Data.Primitive -import Control.Monad.ST -import Control.Monad (liftM, forM_, zipWithM_, forM) -import Data.Primitive.Types -import qualified GHC.Arr as A - -import Data.PrimitiveArray -import Data.PrimitiveArray.Internal - - - -instance (Bounded a, A.Ix a, Prim b) => PrimArrayOps a b where - data PrimArray a b = PaIxP !a !a {-# UNPACK #-} !ByteArray - unsafeIndex (PaIxP lb ub arr) i = indexByteArray arr (A.unsafeIndex (lb,ub) i) - assocs (pa@(PaIxP lb ub _)) = [(i, unsafeIndex pa i) | i<-A.range(lb,ub) ] - fromAssocs l u z xs = runST $ do - pam <- fromAssocsM l u z xs - unsafeFreezeM pam - bounds (PaIxP lb ub _) = (lb,ub) - checkBounds (PaIxP lb ub _) i = A.inRange (lb,ub) i - fromList l u xs = runST $ do - pam <- fromListM l u xs - unsafeFreezeM pam - toList pa@(PaIxP lb ub _) = [unsafeIndex pa i | i <- A.range(lb,ub)] - {-# INLINE unsafeIndex #-} - {-# INLINE assocs #-} - {-# INLINE fromAssocs #-} - {-# INLINE bounds #-} - {-# INLINE checkBounds #-} - {-# INLINE fromList #-} - {-# INLINE toList #-} - -instance (Bounded a, A.Ix a, Prim b) => PrimArrayOpsM a b (ST s) where - data PrimArrayM a b (ST s) = PaIxPM !a !a {-# UNPACK #-} !(MutableByteArray s) - readM (PaIxPM lb ub marr) i = readByteArray marr (A.unsafeIndex (lb,ub) i) - writeM (PaIxPM lb ub marr) i val = writeByteArray marr (A.unsafeIndex (lb,ub) i) val - boundsM (PaIxPM lb ub _) = return (lb,ub) - fromAssocsM lb ub z xs = do - let l = A.rangeSize (lb,ub) - pam <- PaIxPM lb ub `liftM` newWith l z - forM_ xs $ uncurry (writeM pam) - return pam - unsafeFreezeM (PaIxPM lb ub marr) = do - arr <- unsafeFreezeByteArray marr - return $ PaIxP lb ub arr - fromListM lb ub xs = do - let l = A.rangeSize (lb,ub) - pam <- PaIxPM lb ub `liftM` new l (undefined `asTypeOf` head xs) - zipWithM_ (writeM pam) (A.range (lb,ub)) xs - return pam - toListM pam@(PaIxPM lb ub _) = forM (A.range (lb,ub)) (readM pam) - {-# INLINE readM #-} - {-# INLINE writeM #-} - {-# INLINE boundsM #-} - {-# INLINE fromAssocsM #-} - {-# INLINE unsafeFreezeM #-} - {-# INLINE fromListM #-} - {-# INLINE toListM #-} - diff --git a/Data/PrimitiveArray/Unboxed.hs b/Data/PrimitiveArray/Unboxed.hs new file mode 100644 --- /dev/null +++ b/Data/PrimitiveArray/Unboxed.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} + +module Data.PrimitiveArray.Unboxed where + +import qualified Data.Vector.Unboxed.Mutable as VUM +import qualified Data.Vector.Unboxed as VU +import Control.Monad.ST +import Control.Monad +import Data.Array.Repa.Shape +import Control.Exception (assert) + +import Data.PrimitiveArray + +import Data.Array.Repa.Index + + + +instance (VU.Unbox elm, Shape sh, Show elm, Show sh) => PrimArrayOps sh elm where + -- | An immutable PrimArray has a lower bound (lsh), and upper bound (ush) + -- and an upper bound minus unitDim (ush'), returned by bounds + data PrimArray sh elm = PrimArray sh sh sh (VU.Vector elm) + unsafeIndex (PrimArray lsh ush ush' v) idx = assert (inShapeRange lsh ush idx) + $ v `VU.unsafeIndex` (toIndex ush idx - toIndex ush lsh) + bounds (PrimArray lsh ush ush' _) = (lsh,ush') + inBounds (PrimArray lsh ush ush' _) idx = inShapeRange lsh ush idx + fromAssocs lsh ush' def xs = + let ush = ush' `addDim` unitDim + in PrimArray lsh ush ush' + $ VU.replicate (size ush - size lsh) def + VU.// map (\(k,v) -> if (inShapeRange lsh ush k) + then (toIndex ush k - toIndex ush lsh,v) + else error $ show (lsh,ush,k,v) + ) xs + assocs (PrimArray lsh ush ush' v) = map (\(k,v) -> (fromIndex ush $ k + toIndex ush lsh, v)) + . VU.toList + . VU.indexed + $ v + {-# INLINE unsafeIndex #-} + {-# INLINE bounds #-} + {-# INLINE inBounds #-} + {-# INLINE fromAssocs #-} + +deriving instance (Show elm, Show sh, VU.Unbox elm) => Show (PrimArray sh elm) + +deriving instance (Read elm, Read sh, VU.Unbox elm) => Read (PrimArray sh elm) + + + +instance (VUM.Unbox elm, Shape sh) => PrimArrayOpsM sh elm (ST s) where + data PrimArrayM sh elm (ST s) = PrimArrayST sh sh sh (VUM.STVector s elm) + readM (PrimArrayST lsh ush ush' v) sh = VUM.unsafeRead v (toIndex ush sh - toIndex ush lsh) + writeM (PrimArrayST lsh ush suh' v) sh e = VUM.unsafeWrite v (toIndex ush sh - toIndex ush lsh) e + fromAssocsM lsh ush' def xs = do + let ush = ush' `addDim` unitDim + v <- VUM.new (size ush - size lsh) + VUM.set v def + forM_ xs $ \(k,e) -> assert (inShapeRange lsh ush k) + $ VUM.unsafeWrite v (toIndex ush k - toIndex ush lsh) e + return $ PrimArrayST lsh ush ush' v + unsafeFreezeM (PrimArrayST lsh ush ush' v) = do + v' <- VU.unsafeFreeze v + return $ PrimArray lsh ush ush' v' + boundsM (PrimArrayST lsh ush ush' _) = (lsh,ush') + inBoundsM (PrimArrayST lsh ush ush' _) idx = inShapeRange lsh ush idx + {-# INLINE readM #-} + {-# INLINE writeM #-} + {-# INLINE fromAssocsM #-} + {-# INLINE unsafeFreezeM #-} + {-# INLINE boundsM #-} + {-# INLINE inBoundsM #-} + +instance (VUM.Unbox elm, Shape sh) => PrimArrayOpsM sh elm IO where + data PrimArrayM sh elm IO = PrimArrayIO sh sh sh (VUM.IOVector elm) + readM (PrimArrayIO lsh ush ush' v) sh = VUM.unsafeRead v (toIndex ush sh - toIndex ush lsh) + writeM (PrimArrayIO lsh ush suh' v) sh e = VUM.unsafeWrite v (toIndex ush sh - toIndex ush lsh) e + fromAssocsM lsh ush' def xs = do + let ush = ush' `addDim` unitDim + v <- VUM.new (size ush - size lsh) + VUM.set v def + forM_ xs $ \(k,e) -> assert (inShapeRange lsh ush k) + $ VUM.unsafeWrite v (toIndex ush k - toIndex ush lsh) e + return $ PrimArrayIO lsh ush ush' v + unsafeFreezeM (PrimArrayIO lsh ush ush' v) = do + v' <- VU.unsafeFreeze v + return $ PrimArray lsh ush ush' v' + boundsM (PrimArrayIO lsh ush ush' _) = (lsh,ush') + inBoundsM (PrimArrayIO lsh ush ush' _) idx = inShapeRange lsh ush idx + {-# INLINE readM #-} + {-# INLINE writeM #-} + {-# INLINE fromAssocsM #-} + {-# INLINE unsafeFreezeM #-} + {-# INLINE boundsM #-} + {-# INLINE inBoundsM #-} + diff --git a/PrimitiveArray.cabal b/PrimitiveArray.cabal --- a/PrimitiveArray.cabal +++ b/PrimitiveArray.cabal @@ -1,34 +1,40 @@ Name: PrimitiveArray -Version: 0.0.4.0 +Version: 0.1.1.2 License: BSD3 License-file: LICENSE Author: Christian Hoener zu Siederdissen Maintainer: choener@tbi.univie.ac.at -Copyright: Christian Hoener zu Siederdissen, 2010-2011 +Copyright: Christian Hoener zu Siederdissen, 2010-2012 Homepage: http://www.tbi.univie.ac.at/~choener/ Stability: Experimental Category: Data Build-type: Simple -Cabal-version: >=1.2 +Cabal-version: >=1.6 Synopsis: - Unboxed, multidimensional arrays based on the primitive - package. + Efficient multidimensional arrays Description: - Provides unboxed multidimensional tables with a small - interface. Comes with an instance for Ix keys. Read and Show - instances are provided for serialization. - -extra-source-files: - Benchmarks/Index.hs + This library provides efficient multidimensional arrays. All + arrays are 0-based and indexed using repa-shapes. + . + Please note that this version only has the name (and author) in + common with the previous 0.0.4.0 version. The basic idea of the + library remains the same: provide efficient access to immutable + arrays. Library Exposed-modules: Data.PrimitiveArray - Data.PrimitiveArray.Ix - Data.PrimitiveArray.Internal + Data.PrimitiveArray.Unboxed Build-depends: base >= 4 && <5, - primitive >= 0.4.0.1 && < 0.5 + primitive >= 0.4, + vector >= 0.9, + repa >= 2.0 ghc-options: - -O2 + -Odph + -funbox-strict-fields + +source-repository head + type: git + location: git://github.com/choener/PrimitiveArray