diff --git a/vector/src/Data/Vector.hs b/vector/src/Data/Vector.hs index 6c373bba..76a98ce9 100644 --- a/vector/src/Data/Vector.hs +++ b/vector/src/Data/Vector.hs @@ -4,7 +4,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} - -- | -- Module : Data.Vector -- Copyright : (c) Roman Leshchinskiy 2008-2010 @@ -179,275 +178,21 @@ module Data.Vector ( ) where import Control.Applicative (Applicative) -import Data.Vector.Mutable ( MVector(..) ) -import Data.Primitive.Array -import qualified Data.Vector.Fusion.Bundle as Bundle +import Data.Vector.Mutable.Unsafe ( MVector ) +import Data.Vector.Unsafe import qualified Data.Vector.Generic as G -import Control.DeepSeq ( NFData(rnf), NFData1(liftRnf)) - -import Control.Monad ( MonadPlus(..), liftM, ap ) -import Control.Monad.ST ( ST, runST ) +import Control.Monad.ST ( ST ) import Control.Monad.Primitive -import qualified Control.Monad.Fail as Fail -import Control.Monad.Fix ( MonadFix (mfix) ) -import Control.Monad.Zip -import Data.Function ( fix ) import Prelude - ( Eq, Ord, Num, Enum, Monoid, Functor, Monad, Show, Bool, Ordering(..), Int, Maybe, Either - , compare, mempty, mappend, mconcat, return, showsPrec, fmap, otherwise, id, flip, const - , (>>=), (+), (-), (<), (<=), (>), (>=), (==), (/=), (&&), (.), ($) ) + ( Eq, Ord, Num, Enum, Monoid, Monad, Bool, Ordering(..), Int, Maybe, Either + , id, (==)) -import Data.Functor.Classes (Eq1 (..), Ord1 (..), Read1 (..), Show1 (..)) -import Data.Data ( Data(..) ) -import Text.Read ( Read(..), readListPrecDefault ) -import Data.Semigroup ( Semigroup(..) ) -import qualified Control.Applicative as Applicative -import qualified Data.Foldable as Foldable import qualified Data.Traversable as Traversable -import qualified GHC.Exts as Exts (IsList(..)) - - --- | Boxed vectors, supporting efficient slicing. -data Vector a = Vector {-# UNPACK #-} !Int - {-# UNPACK #-} !Int - {-# UNPACK #-} !(Array a) - -instance NFData a => NFData (Vector a) where - rnf = liftRnf rnf - {-# INLINEABLE rnf #-} - --- | @since 0.12.1.0 -instance NFData1 Vector where - liftRnf elemRnf = foldl' (\_ -> elemRnf) () - {-# INLINEABLE liftRnf #-} - -instance Show a => Show (Vector a) where - showsPrec = G.showsPrec - -instance Read a => Read (Vector a) where - readPrec = G.readPrec - readListPrec = readListPrecDefault - -instance Show1 Vector where - liftShowsPrec = G.liftShowsPrec - -instance Read1 Vector where - liftReadsPrec = G.liftReadsPrec - -instance Exts.IsList (Vector a) where - type Item (Vector a) = a - fromList = Data.Vector.fromList - fromListN = Data.Vector.fromListN - toList = toList - -instance Data a => Data (Vector a) where - gfoldl = G.gfoldl - toConstr _ = G.mkVecConstr "Data.Vector.Vector" - gunfold = G.gunfold - dataTypeOf _ = G.mkVecType "Data.Vector.Vector" - dataCast1 = G.dataCast - -type instance G.Mutable Vector = MVector - -instance G.Vector Vector a where - {-# INLINE basicUnsafeFreeze #-} - basicUnsafeFreeze (MVector i n marr) - = Vector i n `liftM` unsafeFreezeArray marr - - {-# INLINE basicUnsafeThaw #-} - basicUnsafeThaw (Vector i n arr) - = MVector i n `liftM` unsafeThawArray arr - - {-# INLINE basicLength #-} - basicLength (Vector _ n _) = n - - {-# INLINE basicUnsafeSlice #-} - basicUnsafeSlice j n (Vector i _ arr) = Vector (i+j) n arr - - {-# INLINE basicUnsafeIndexM #-} - basicUnsafeIndexM (Vector i _ arr) j = indexArrayM arr (i+j) - - {-# INLINE basicUnsafeCopy #-} - basicUnsafeCopy (MVector i n dst) (Vector j _ src) - = copyArray dst i src j n - --- See http://trac.haskell.org/vector/ticket/12 -instance Eq a => Eq (Vector a) where - {-# INLINE (==) #-} - xs == ys = Bundle.eq (G.stream xs) (G.stream ys) - --- See http://trac.haskell.org/vector/ticket/12 -instance Ord a => Ord (Vector a) where - {-# INLINE compare #-} - compare xs ys = Bundle.cmp (G.stream xs) (G.stream ys) - - {-# INLINE (<) #-} - xs < ys = Bundle.cmp (G.stream xs) (G.stream ys) == LT - - {-# INLINE (<=) #-} - xs <= ys = Bundle.cmp (G.stream xs) (G.stream ys) /= GT - - {-# INLINE (>) #-} - xs > ys = Bundle.cmp (G.stream xs) (G.stream ys) == GT - - {-# INLINE (>=) #-} - xs >= ys = Bundle.cmp (G.stream xs) (G.stream ys) /= LT - -instance Eq1 Vector where - {-# INLINE liftEq #-} - liftEq = eqBy - -instance Ord1 Vector where - {-# INLINE liftCompare #-} - liftCompare = cmpBy - -instance Semigroup (Vector a) where - {-# INLINE (<>) #-} - (<>) = (++) - - {-# INLINE sconcat #-} - sconcat = G.concatNE - -instance Monoid (Vector a) where - {-# INLINE mempty #-} - mempty = empty - - {-# INLINE mappend #-} - mappend = (<>) - - {-# INLINE mconcat #-} - mconcat = concat - -instance Functor Vector where - {-# INLINE fmap #-} - fmap = map - - {-# INLINE (<$) #-} - (<$) = map . const - -instance Monad Vector where - {-# INLINE return #-} - return = Applicative.pure - - {-# INLINE (>>=) #-} - (>>=) = flip concatMap - --- | @since 0.12.1.0 -instance Fail.MonadFail Vector where - {-# INLINE fail #-} - fail _ = empty - -instance MonadPlus Vector where - {-# INLINE mzero #-} - mzero = empty - - {-# INLINE mplus #-} - mplus = (++) - -instance MonadZip Vector where - {-# INLINE mzip #-} - mzip = zip - - {-# INLINE mzipWith #-} - mzipWith = zipWith - {-# INLINE munzip #-} - munzip = unzip - --- | This instance has the same semantics as the one for lists. --- --- @since 0.12.2.0 -instance MonadFix Vector where - -- We take care to dispose of v0 as soon as possible (see headM docs). - -- - -- It's perfectly safe to use non-monadic indexing within generate - -- call since intermediate vector won't be created until result's - -- value is demanded. - {-# INLINE mfix #-} - mfix f - | null v0 = empty - -- We take first element of resulting vector from v0 and create - -- rest using generate. Note that cons should fuse with generate - | otherwise = runST $ do - h <- headM v0 - return $ cons h $ - generate (lv0 - 1) $ - \i -> fix (\a -> f a ! (i + 1)) - where - -- Used to calculate size of resulting vector - v0 = fix (f . head) - !lv0 = length v0 - -instance Applicative.Applicative Vector where - {-# INLINE pure #-} - pure = singleton - - {-# INLINE (<*>) #-} - (<*>) = ap - -instance Applicative.Alternative Vector where - {-# INLINE empty #-} - empty = empty - - {-# INLINE (<|>) #-} - (<|>) = (++) - -instance Foldable.Foldable Vector where - {-# INLINE foldr #-} - foldr = foldr - - {-# INLINE foldl #-} - foldl = foldl - - {-# INLINE foldr1 #-} - foldr1 = foldr1 - - {-# INLINE foldl1 #-} - foldl1 = foldl1 - - {-# INLINE foldr' #-} - foldr' = foldr' - - {-# INLINE foldl' #-} - foldl' = foldl' - - {-# INLINE toList #-} - toList = toList - - {-# INLINE length #-} - length = length - - {-# INLINE null #-} - null = null - - {-# INLINE elem #-} - elem = elem - - {-# INLINE maximum #-} - maximum = maximum - - {-# INLINE minimum #-} - minimum = minimum - - {-# INLINE sum #-} - sum = sum - - {-# INLINE product #-} - product = product - -instance Traversable.Traversable Vector where - {-# INLINE traverse #-} - traverse = traverse - - {-# INLINE mapM #-} - mapM = mapM - - {-# INLINE sequence #-} - sequence = sequence -- Length information -- ------------------ @@ -2281,52 +2026,6 @@ iforA_ :: (Applicative f) iforA_ = G.iforA_ --- Conversions - Arrays --- ----------------------------- - --- | /O(1)/ Convert an array to a vector. --- --- @since 0.12.2.0 -fromArray :: Array a -> Vector a -{-# INLINE fromArray #-} -fromArray arr = Vector 0 (sizeofArray arr) arr - --- | /O(n)/ Convert a vector to an array. --- --- @since 0.12.2.0 -toArray :: Vector a -> Array a -{-# INLINE toArray #-} -toArray (Vector offset len arr) - | offset == 0 && len == sizeofArray arr = arr - | otherwise = cloneArray arr offset len - --- | /O(1)/ Extract the underlying `Array`, offset where vector starts and the --- total number of elements in the vector. Below property always holds: --- --- > let (array, offset, len) = toArraySlice v --- > v === unsafeFromArraySlice len offset array --- --- @since 0.13.0.0 -toArraySlice :: Vector a -> (Array a, Int, Int) -{-# INLINE toArraySlice #-} -toArraySlice (Vector offset len arr) = (arr, offset, len) - - --- | /O(1)/ Convert an array slice to a vector. This function is very unsafe, --- because constructing an invalid vector can yield almost all other safe --- functions in this module unsafe. These are equivalent: --- --- > unsafeFromArraySlice len offset === unsafeTake len . unsafeDrop offset . fromArray --- --- @since 0.13.0.0 -unsafeFromArraySlice :: - Array a -- ^ Immutable boxed array. - -> Int -- ^ Offset - -> Int -- ^ Length - -> Vector a -{-# INLINE unsafeFromArraySlice #-} -unsafeFromArraySlice arr offset len = Vector offset len arr - -- Conversions - Mutable vectors -- ----------------------------- @@ -2389,4 +2088,4 @@ copy = G.copy -- $setup -- >>> :set -Wno-type-defaults --- >>> import Prelude (Char, String, Bool(True, False), min, max, fst, even, undefined, Ord(..)) +-- >>> import Prelude (Char, String, Bool(True, False), min, max, fst, even, undefined, Ord(..), ($), (<>), Num(..)) diff --git a/vector/src/Data/Vector/Mutable.hs b/vector/src/Data/Vector/Mutable.hs index 82a60c67..04714f4d 100644 --- a/vector/src/Data/Vector/Mutable.hs +++ b/vector/src/Data/Vector/Mutable.hs @@ -4,6 +4,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RoleAnnotations #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE PatternSynonyms #-} -- | -- Module : Data.Vector.Mutable -- Copyright : (c) Roman Leshchinskiy 2008-2010 @@ -20,7 +21,8 @@ module Data.Vector.Mutable ( -- * Mutable boxed vectors - MVector(MVector), IOVector, STVector, + MVector, IOVector, STVector, + pattern MVector, -- * Accessors @@ -71,149 +73,21 @@ module Data.Vector.Mutable ( PrimMonad, PrimState, RealWorld ) where -import Control.Monad (when, liftM) -import Control.Monad.ST (ST) import qualified Data.Vector.Generic.Mutable as G -import Data.Vector.Internal.Check +import Data.Vector.Mutable.Unsafe (MVector,IOVector,STVector,toMutableArray,fromMutableArray) +import qualified Data.Vector.Mutable.Unsafe as U import Data.Primitive.Array import Control.Monad.Primitive -import Prelude - ( Ord, Monad, Bool, Ordering(..), Int, Maybe - , compare, return, otherwise, error - , (>>=), (+), (-), (*), (<), (>), (>=), (&&), (||), ($), (>>) ) +import Prelude( Ord, Bool, Ordering(..), Int, Maybe ) #include "vector.h" -type role MVector nominal representational - --- | Mutable boxed vectors keyed on the monad they live in ('IO' or @'ST' s@). -data MVector s a = MVector { _offset :: {-# UNPACK #-} !Int - -- ^ Offset in underlying array - , _size :: {-# UNPACK #-} !Int - -- ^ Size of slice - , _array :: {-# UNPACK #-} !(MutableArray s a) - -- ^ Underlying array - } - -type IOVector = MVector RealWorld -type STVector s = MVector s - --- NOTE: This seems unsafe, see http://trac.haskell.org/vector/ticket/54 -{- -instance NFData a => NFData (MVector s a) where - rnf (MVector i n arr) = unsafeInlineST $ force i - where - force !ix | ix < n = do x <- readArray arr ix - rnf x `seq` force (ix+1) - | otherwise = return () --} - -instance G.MVector MVector a where - {-# INLINE basicLength #-} - basicLength (MVector _ n _) = n - - {-# INLINE basicUnsafeSlice #-} - basicUnsafeSlice j m (MVector i _ arr) = MVector (i+j) m arr - - {-# INLINE basicOverlaps #-} - basicOverlaps (MVector i m arr1) (MVector j n arr2) - = sameMutableArray arr1 arr2 - && (between i j (j+n) || between j i (i+m)) - where - between x y z = x >= y && x < z - - {-# INLINE basicUnsafeNew #-} - basicUnsafeNew n - = do - arr <- newArray n uninitialised - return (MVector 0 n arr) - - {-# INLINE basicInitialize #-} - -- initialization is unnecessary for boxed vectors - basicInitialize _ = return () - - {-# INLINE basicUnsafeReplicate #-} - basicUnsafeReplicate n x - = do - arr <- newArray n x - return (MVector 0 n arr) - - {-# INLINE basicUnsafeRead #-} - basicUnsafeRead (MVector i _ arr) j = readArray arr (i+j) - - {-# INLINE basicUnsafeWrite #-} - basicUnsafeWrite (MVector i _ arr) j x = writeArray arr (i+j) x - - {-# INLINE basicUnsafeCopy #-} - basicUnsafeCopy (MVector i n dst) (MVector j _ src) - = copyMutableArray dst i src j n - - basicUnsafeMove dst@(MVector iDst n arrDst) src@(MVector iSrc _ arrSrc) - = case n of - 0 -> return () - 1 -> readArray arrSrc iSrc >>= writeArray arrDst iDst - 2 -> do - x <- readArray arrSrc iSrc - y <- readArray arrSrc (iSrc + 1) - writeArray arrDst iDst x - writeArray arrDst (iDst + 1) y - _ - | overlaps dst src - -> case compare iDst iSrc of - LT -> moveBackwards arrDst iDst iSrc n - EQ -> return () - GT | (iDst - iSrc) * 2 < n - -> moveForwardsLargeOverlap arrDst iDst iSrc n - | otherwise - -> moveForwardsSmallOverlap arrDst iDst iSrc n - | otherwise -> G.basicUnsafeCopy dst src - - {-# INLINE basicClear #-} - basicClear v = G.set v uninitialised - -{-# INLINE moveBackwards #-} -moveBackwards :: MutableArray s a -> Int -> Int -> Int -> ST s () -moveBackwards !arr !dstOff !srcOff !len = - check Internal "not a backwards move" (dstOff < srcOff) - $ loopM len $ \ i -> readArray arr (srcOff + i) >>= writeArray arr (dstOff + i) - -{-# INLINE moveForwardsSmallOverlap #-} --- Performs a move when dstOff > srcOff, optimized for when the overlap of the intervals is small. -moveForwardsSmallOverlap :: MutableArray s a -> Int -> Int -> Int -> ST s () -moveForwardsSmallOverlap !arr !dstOff !srcOff !len = - check Internal "not a forward move" (dstOff > srcOff) - $ do - tmp <- newArray overlap uninitialised - loopM overlap $ \ i -> readArray arr (dstOff + i) >>= writeArray tmp i - loopM nonOverlap $ \ i -> readArray arr (srcOff + i) >>= writeArray arr (dstOff + i) - loopM overlap $ \ i -> readArray tmp i >>= writeArray arr (dstOff + nonOverlap + i) - where nonOverlap = dstOff - srcOff; overlap = len - nonOverlap - --- Performs a move when dstOff > srcOff, optimized for when the overlap of the intervals is large. -moveForwardsLargeOverlap :: MutableArray s a -> Int -> Int -> Int -> ST s () -moveForwardsLargeOverlap !arr !dstOff !srcOff !len = - check Internal "not a forward move" (dstOff > srcOff) - $ do - queue <- newArray nonOverlap uninitialised - loopM nonOverlap $ \ i -> readArray arr (srcOff + i) >>= writeArray queue i - let mov !i !qTop = when (i < dstOff + len) $ do - x <- readArray arr i - y <- readArray queue qTop - writeArray arr i y - writeArray queue qTop x - mov (i+1) (if qTop + 1 >= nonOverlap then 0 else qTop + 1) - mov dstOff 0 - where nonOverlap = dstOff - srcOff - -{-# INLINE loopM #-} -loopM :: Monad m => Int -> (Int -> m a) -> m () -loopM !n k = let - go i = when (i < n) (k i >> go (i+1)) - in go 0 - -uninitialised :: a -uninitialised = error "Data.Vector.Mutable: uninitialised element. If you are trying to compact a vector, use the 'Data.Vector.force' function to remove uninitialised elements from the underlying array." +pattern MVector :: Int -> Int -> MutableArray s a -> MVector s a +pattern MVector i j arr = U.MVector i j arr +{-# COMPLETE MVector #-} +{-# DEPRECATED MVector "Use constructor exported from Data.Vector.Mutable.Unsafe" #-} + -- Length information -- ------------------ @@ -787,24 +661,5 @@ ifoldrM' :: (PrimMonad m) => (Int -> a -> b -> m b) -> b -> MVector (PrimState m {-# INLINE ifoldrM' #-} ifoldrM' = G.ifoldrM' --- Conversions - Arrays --- ----------------------------- - --- | /O(n)/ Make a copy of a mutable array to a new mutable vector. --- --- @since 0.12.2.0 -fromMutableArray :: PrimMonad m => MutableArray (PrimState m) a -> m (MVector (PrimState m) a) -{-# INLINE fromMutableArray #-} -fromMutableArray marr = - let size = sizeofMutableArray marr - in MVector 0 size `liftM` cloneMutableArray marr 0 size - --- | /O(n)/ Make a copy of a mutable vector into a new mutable array. --- --- @since 0.12.2.0 -toMutableArray :: PrimMonad m => MVector (PrimState m) a -> m (MutableArray (PrimState m) a) -{-# INLINE toMutableArray #-} -toMutableArray (MVector offset size marr) = cloneMutableArray marr offset size - -- $setup --- >>> import Prelude (Integer) +-- >>> import Prelude (Integer,Num(..),($)) diff --git a/vector/src/Data/Vector/Mutable/Unsafe.hs b/vector/src/Data/Vector/Mutable/Unsafe.hs new file mode 100644 index 00000000..aee899e8 --- /dev/null +++ b/vector/src/Data/Vector/Mutable/Unsafe.hs @@ -0,0 +1,181 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE TypeFamilies #-} +-- | +module Data.Vector.Mutable.Unsafe + ( MVector(..) + , IOVector + , STVector + -- * Array conversions + , toMutableArray + , fromMutableArray + ) where + +import Control.Monad (when, liftM) +import Control.Monad.ST (ST) +import qualified Data.Vector.Generic.Mutable as G +import Data.Vector.Internal.Check +import Data.Primitive.Array +import Control.Monad.Primitive + +import Prelude + ( Monad, Ordering(..), Int + , compare, return, otherwise, error + , (>>=), (+), (-), (*), (<), (>), (>=), (&&), (||), ($), (>>) ) + +#include "vector.h" + +type role MVector nominal representational + +-- | Mutable boxed vectors keyed on the monad they live in ('IO' or @'ST' s@). +data MVector s a = MVector { _offset :: {-# UNPACK #-} !Int + -- ^ Offset in underlying array + , _size :: {-# UNPACK #-} !Int + -- ^ Size of slice + , _array :: {-# UNPACK #-} !(MutableArray s a) + -- ^ Underlying array + } + +type IOVector = MVector RealWorld +type STVector s = MVector s + + +-- NOTE: This seems unsafe, see http://trac.haskell.org/vector/ticket/54 +{- +instance NFData a => NFData (MVector s a) where + rnf (MVector i n arr) = unsafeInlineST $ force i + where + force !ix | ix < n = do x <- readArray arr ix + rnf x `seq` force (ix+1) + | otherwise = return () +-} + +instance G.MVector MVector a where + {-# INLINE basicLength #-} + basicLength (MVector _ n _) = n + + {-# INLINE basicUnsafeSlice #-} + basicUnsafeSlice j m (MVector i _ arr) = MVector (i+j) m arr + + {-# INLINE basicOverlaps #-} + basicOverlaps (MVector i m arr1) (MVector j n arr2) + = sameMutableArray arr1 arr2 + && (between i j (j+n) || between j i (i+m)) + where + between x y z = x >= y && x < z + + {-# INLINE basicUnsafeNew #-} + basicUnsafeNew n + = do + arr <- newArray n uninitialised + return (MVector 0 n arr) + + {-# INLINE basicInitialize #-} + -- initialization is unnecessary for boxed vectors + basicInitialize _ = return () + + {-# INLINE basicUnsafeReplicate #-} + basicUnsafeReplicate n x + = do + arr <- newArray n x + return (MVector 0 n arr) + + {-# INLINE basicUnsafeRead #-} + basicUnsafeRead (MVector i _ arr) j = readArray arr (i+j) + + {-# INLINE basicUnsafeWrite #-} + basicUnsafeWrite (MVector i _ arr) j x = writeArray arr (i+j) x + + {-# INLINE basicUnsafeCopy #-} + basicUnsafeCopy (MVector i n dst) (MVector j _ src) + = copyMutableArray dst i src j n + + basicUnsafeMove dst@(MVector iDst n arrDst) src@(MVector iSrc _ arrSrc) + = case n of + 0 -> return () + 1 -> readArray arrSrc iSrc >>= writeArray arrDst iDst + 2 -> do + x <- readArray arrSrc iSrc + y <- readArray arrSrc (iSrc + 1) + writeArray arrDst iDst x + writeArray arrDst (iDst + 1) y + _ + | G.overlaps dst src + -> case compare iDst iSrc of + LT -> moveBackwards arrDst iDst iSrc n + EQ -> return () + GT | (iDst - iSrc) * 2 < n + -> moveForwardsLargeOverlap arrDst iDst iSrc n + | otherwise + -> moveForwardsSmallOverlap arrDst iDst iSrc n + | otherwise -> G.basicUnsafeCopy dst src + + {-# INLINE basicClear #-} + basicClear v = G.set v uninitialised + + +{-# INLINE moveBackwards #-} +moveBackwards :: MutableArray s a -> Int -> Int -> Int -> ST s () +moveBackwards !arr !dstOff !srcOff !len = + check Internal "not a backwards move" (dstOff < srcOff) + $ loopM len $ \ i -> readArray arr (srcOff + i) >>= writeArray arr (dstOff + i) + +{-# INLINE moveForwardsSmallOverlap #-} +-- Performs a move when dstOff > srcOff, optimized for when the overlap of the intervals is small. +moveForwardsSmallOverlap :: MutableArray s a -> Int -> Int -> Int -> ST s () +moveForwardsSmallOverlap !arr !dstOff !srcOff !len = + check Internal "not a forward move" (dstOff > srcOff) + $ do + tmp <- newArray overlap uninitialised + loopM overlap $ \ i -> readArray arr (dstOff + i) >>= writeArray tmp i + loopM nonOverlap $ \ i -> readArray arr (srcOff + i) >>= writeArray arr (dstOff + i) + loopM overlap $ \ i -> readArray tmp i >>= writeArray arr (dstOff + nonOverlap + i) + where nonOverlap = dstOff - srcOff; overlap = len - nonOverlap + +-- Performs a move when dstOff > srcOff, optimized for when the overlap of the intervals is large. +moveForwardsLargeOverlap :: MutableArray s a -> Int -> Int -> Int -> ST s () +moveForwardsLargeOverlap !arr !dstOff !srcOff !len = + check Internal "not a forward move" (dstOff > srcOff) + $ do + queue <- newArray nonOverlap uninitialised + loopM nonOverlap $ \ i -> readArray arr (srcOff + i) >>= writeArray queue i + let mov !i !qTop = when (i < dstOff + len) $ do + x <- readArray arr i + y <- readArray queue qTop + writeArray arr i y + writeArray queue qTop x + mov (i+1) (if qTop + 1 >= nonOverlap then 0 else qTop + 1) + mov dstOff 0 + where nonOverlap = dstOff - srcOff + +{-# INLINE loopM #-} +loopM :: Monad m => Int -> (Int -> m a) -> m () +loopM !n k = let + go i = when (i < n) (k i >> go (i+1)) + in go 0 + +uninitialised :: a +uninitialised = error "Data.Vector.Mutable: uninitialised element. If you are trying to compact a vector, use the 'Data.Vector.force' function to remove uninitialised elements from the underlying array." + + +-- Conversions - Arrays +-- ----------------------------- + +-- | /O(n)/ Make a copy of a mutable array to a new mutable vector. +-- +-- @since 0.12.2.0 +fromMutableArray :: PrimMonad m => MutableArray (PrimState m) a -> m (MVector (PrimState m) a) +{-# INLINE fromMutableArray #-} +fromMutableArray marr = + let size = sizeofMutableArray marr + in MVector 0 size `liftM` cloneMutableArray marr 0 size + +-- | /O(n)/ Make a copy of a mutable vector into a new mutable array. +-- +-- @since 0.12.2.0 +toMutableArray :: PrimMonad m => MVector (PrimState m) a -> m (MutableArray (PrimState m) a) +{-# INLINE toMutableArray #-} +toMutableArray (MVector offset size marr) = cloneMutableArray marr offset size diff --git a/vector/src/Data/Vector/Primitive.hs b/vector/src/Data/Vector/Primitive.hs index dade073f..6996ef56 100644 --- a/vector/src/Data/Vector/Primitive.hs +++ b/vector/src/Data/Vector/Primitive.hs @@ -5,6 +5,7 @@ {-# LANGUAGE RoleAnnotations #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE PatternSynonyms #-} -- | -- Module : Data.Vector.Primitive -- Copyright : (c) Roman Leshchinskiy 2008-2010 @@ -24,7 +25,7 @@ module Data.Vector.Primitive ( -- * Primitive vectors - Vector(..), MVector(..), + Vector, MVector, pattern MVector, pattern Vector, -- * Accessors @@ -163,145 +164,24 @@ module Data.Vector.Primitive ( import Control.Applicative (Applicative) import qualified Data.Vector.Generic as G -import Data.Vector.Primitive.Mutable ( MVector(..) ) -import Data.Vector.Internal.Check -import qualified Data.Vector.Fusion.Bundle as Bundle +import Data.Vector.Primitive.Unsafe (Vector,unsafeCoerceVector,unsafeCast) +import qualified Data.Vector.Primitive.Unsafe as U +import Data.Vector.Primitive.Mutable.Unsafe (MVector) +import Data.Vector.Primitive.Mutable (pattern MVector) +import Data.Primitive ( Prim ) import Data.Primitive.ByteArray -import Data.Primitive ( Prim, sizeOf ) -import Control.DeepSeq ( NFData(rnf), NFData1(liftRnf)) - -import Control.Monad ( liftM ) import Control.Monad.ST ( ST ) import Control.Monad.Primitive import Prelude - ( Eq, Ord, Num, Enum, Monoid, Traversable, Monad, Read, Show, Bool, Ordering(..), Int, Maybe, Either - , compare, mempty, mappend, mconcat, showsPrec, return, otherwise, seq, error, undefined - , (+), (*), (<), (<=), (>), (>=), (==), (/=), ($!) ) - -import Data.Data ( Data(..) ) -import Text.Read ( Read(..), readListPrecDefault ) -import Data.Semigroup ( Semigroup(..) ) - -import Data.Coerce -import Unsafe.Coerce -import qualified GHC.Exts as Exts - -type role Vector nominal - --- | /O(1)/ Unsafely coerce an immutable vector from one element type to another, --- representationally equal type. The operation just changes the type of the --- underlying pointer and does not modify the elements. --- --- This is marginally safer than 'unsafeCast', since this function imposes an --- extra 'Coercible' constraint. The constraint guarantees that the element types --- are representationally equal. It however cannot guarantee --- that their respective 'Prim' instances are compatible. -unsafeCoerceVector :: Coercible a b => Vector a -> Vector b -unsafeCoerceVector = unsafeCoerce - --- | Unboxed vectors of primitive types. -data Vector a = Vector {-# UNPACK #-} !Int -- ^ offset - {-# UNPACK #-} !Int -- ^ length - {-# UNPACK #-} !ByteArray -- ^ underlying byte array - -instance NFData (Vector a) where - rnf (Vector _ _ _) = () - --- | @since 0.12.1.0 -instance NFData1 Vector where - liftRnf _ (Vector _ _ _) = () - -instance (Show a, Prim a) => Show (Vector a) where - showsPrec = G.showsPrec - -instance (Read a, Prim a) => Read (Vector a) where - readPrec = G.readPrec - readListPrec = readListPrecDefault - -instance (Data a, Prim a) => Data (Vector a) where - gfoldl = G.gfoldl - toConstr _ = G.mkVecConstr "Data.Vector.Primitive.Vector" - gunfold = G.gunfold - dataTypeOf _ = G.mkVecType "Data.Vector.Primitive.Vector" - dataCast1 = G.dataCast - - -type instance G.Mutable Vector = MVector - -instance Prim a => G.Vector Vector a where - {-# INLINE basicUnsafeFreeze #-} - basicUnsafeFreeze (MVector i n marr) - = Vector i n `liftM` unsafeFreezeByteArray marr - - {-# INLINE basicUnsafeThaw #-} - basicUnsafeThaw (Vector i n arr) - = MVector i n `liftM` unsafeThawByteArray arr - - {-# INLINE basicLength #-} - basicLength (Vector _ n _) = n - - {-# INLINE basicUnsafeSlice #-} - basicUnsafeSlice j n (Vector i _ arr) = Vector (i+j) n arr - - {-# INLINE basicUnsafeIndexM #-} - basicUnsafeIndexM (Vector i _ arr) j = return $! indexByteArray arr (i+j) - - {-# INLINE basicUnsafeCopy #-} - basicUnsafeCopy (MVector i n dst) (Vector j _ src) - = copyByteArray dst (i*sz) src (j*sz) (n*sz) - where - sz = sizeOf (undefined :: a) - - {-# INLINE elemseq #-} - elemseq _ = seq - --- See http://trac.haskell.org/vector/ticket/12 -instance (Prim a, Eq a) => Eq (Vector a) where - {-# INLINE (==) #-} - xs == ys = Bundle.eq (G.stream xs) (G.stream ys) - --- See http://trac.haskell.org/vector/ticket/12 -instance (Prim a, Ord a) => Ord (Vector a) where - {-# INLINE compare #-} - compare xs ys = Bundle.cmp (G.stream xs) (G.stream ys) - - {-# INLINE (<) #-} - xs < ys = Bundle.cmp (G.stream xs) (G.stream ys) == LT - - {-# INLINE (<=) #-} - xs <= ys = Bundle.cmp (G.stream xs) (G.stream ys) /= GT - - {-# INLINE (>) #-} - xs > ys = Bundle.cmp (G.stream xs) (G.stream ys) == GT - - {-# INLINE (>=) #-} - xs >= ys = Bundle.cmp (G.stream xs) (G.stream ys) /= LT - -instance Prim a => Semigroup (Vector a) where - {-# INLINE (<>) #-} - (<>) = (++) - - {-# INLINE sconcat #-} - sconcat = G.concatNE - -instance Prim a => Monoid (Vector a) where - {-# INLINE mempty #-} - mempty = empty - - {-# INLINE mappend #-} - mappend = (<>) - - {-# INLINE mconcat #-} - mconcat = concat - -instance Prim a => Exts.IsList (Vector a) where - type Item (Vector a) = a - fromList = fromList - fromListN = fromListN - toList = toList + ( Eq, Ord, Num, Enum, Monoid, Traversable, Monad, Bool, Ordering(..), Int, Maybe, Either + , (==)) +pattern Vector :: Int -> Int -> ByteArray -> Vector a +pattern Vector i j arr = U.Vector i j arr +{-# COMPLETE Vector #-} +{-# DEPRECATED Vector "Use constructor exported from Data.Vector.Primitive.Unsafe" #-} -- Length -- ------ @@ -1968,21 +1848,6 @@ iforA_ :: (Applicative f, Prim a) iforA_ = G.iforA_ --- Conversions - Unsafe casts --- -------------------------- - --- | /O(1)/ Unsafely cast a vector from one element type to another. --- This operation just changes the type of the vector and does not --- modify the elements. --- --- This function will throw an error if elements are of mismatching sizes. --- --- | @since 0.13.0.0 -unsafeCast :: forall a b. (HasCallStack, Prim a, Prim b) => Vector a -> Vector b -{-# INLINE unsafeCast #-} -unsafeCast (Vector o n ba) - | sizeOf (undefined :: a) == sizeOf (undefined :: b) = Vector o n ba - | otherwise = error "Element size mismatch" -- Conversions - Mutable vectors -- ----------------------------- @@ -2046,4 +1911,4 @@ copy :: (Prim a, PrimMonad m) => MVector (PrimState m) a -> Vector a -> m () copy = G.copy -- $setup --- >>> import Prelude (($), min, even, max, succ, id, Ord(..)) +-- >>> import Prelude (($), min, even, max, succ, id, Ord(..), Num(..), undefined) diff --git a/vector/src/Data/Vector/Primitive/Mutable.hs b/vector/src/Data/Vector/Primitive/Mutable.hs index 6c8dd884..b91a4434 100644 --- a/vector/src/Data/Vector/Primitive/Mutable.hs +++ b/vector/src/Data/Vector/Primitive/Mutable.hs @@ -3,6 +3,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RoleAnnotations #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE PatternSynonyms #-} -- | -- Module : Data.Vector.Primitive.Mutable -- Copyright : (c) Roman Leshchinskiy 2008-2010 @@ -19,7 +20,8 @@ module Data.Vector.Primitive.Mutable ( -- * Mutable vectors of primitive types - MVector(..), IOVector, STVector, + MVector, IOVector, STVector, + pattern MVector, -- * Accessors @@ -70,99 +72,22 @@ module Data.Vector.Primitive.Mutable ( ) where import qualified Data.Vector.Generic.Mutable as G +import Data.Primitive ( Prim ) import Data.Primitive.ByteArray -import Data.Primitive ( Prim, sizeOf ) -import Data.Vector.Internal.Check -import Data.Word ( Word8 ) +import Data.Vector.Primitive.Mutable.Unsafe + (MVector,IOVector,STVector,unsafeCoerceMVector,unsafeCast) +import qualified Data.Vector.Primitive.Mutable.Unsafe as U import Control.Monad.Primitive -import Control.Monad ( liftM ) -import Control.DeepSeq ( NFData(rnf), NFData1(liftRnf)) - -import Prelude - ( Ord, Bool, Int, Maybe, Ordering(..) - , otherwise, error, undefined, div, show, maxBound - , (+), (*), (<), (>), (>=), (==), (&&), (||), ($), (++) ) - -import Data.Coerce -import Unsafe.Coerce +import Prelude ( Ord, Bool, Int, Maybe, Ordering(..) ) #include "vector.h" -type role MVector nominal nominal - --- | /O(1)/ Unsafely coerce a mutable vector from one element type to another, --- representationally equal type. The operation just changes the type of the --- underlying pointer and does not modify the elements. --- --- Note that this function is unsafe. The @Coercible@ constraint guarantees --- that the element types are representationally equal. It however cannot --- guarantee that their respective 'Prim' instances are compatible. -unsafeCoerceMVector :: Coercible a b => MVector s a -> MVector s b -unsafeCoerceMVector = unsafeCoerce - --- | Mutable vectors of primitive types. -data MVector s a = MVector {-# UNPACK #-} !Int -- ^ offset - {-# UNPACK #-} !Int -- ^ length - {-# UNPACK #-} !(MutableByteArray s) -- ^ underlying mutable byte array - -type IOVector = MVector RealWorld -type STVector s = MVector s - -instance NFData (MVector s a) where - rnf (MVector _ _ _) = () - -instance NFData1 (MVector s) where - liftRnf _ (MVector _ _ _) = () - -instance Prim a => G.MVector MVector a where - basicLength (MVector _ n _) = n - basicUnsafeSlice j m (MVector i _ arr) - = MVector (i+j) m arr - - {-# INLINE basicOverlaps #-} - basicOverlaps (MVector i m arr1) (MVector j n arr2) - = sameMutableByteArray arr1 arr2 - && (between i j (j+n) || between j i (i+m)) - where - between x y z = x >= y && x < z - - {-# INLINE basicUnsafeNew #-} - basicUnsafeNew n - | n < 0 = error $ "Primitive.basicUnsafeNew: negative length: " ++ show n - | n > mx = error $ "Primitive.basicUnsafeNew: length too large: " ++ show n - | otherwise = MVector 0 n `liftM` newByteArray (n * size) - where - size = sizeOf (undefined :: a) - mx = maxBound `div` size :: Int - - {-# INLINE basicInitialize #-} - basicInitialize (MVector off n v) = - setByteArray v (off * size) (n * size) (0 :: Word8) - where - size = sizeOf (undefined :: a) - - - {-# INLINE basicUnsafeRead #-} - basicUnsafeRead (MVector i _ arr) j = readByteArray arr (i+j) - - {-# INLINE basicUnsafeWrite #-} - basicUnsafeWrite (MVector i _ arr) j x = writeByteArray arr (i+j) x - - {-# INLINE basicUnsafeCopy #-} - basicUnsafeCopy (MVector i n dst) (MVector j _ src) - = copyMutableByteArray dst (i*sz) src (j*sz) (n*sz) - where - sz = sizeOf (undefined :: a) - - {-# INLINE basicUnsafeMove #-} - basicUnsafeMove (MVector i n dst) (MVector j _ src) - = moveByteArray dst (i*sz) src (j*sz) (n * sz) - where - sz = sizeOf (undefined :: a) - - {-# INLINE basicSet #-} - basicSet (MVector i n arr) x = setByteArray arr i n x + +pattern MVector :: Int -> Int -> MutableByteArray s -> MVector s a +pattern MVector i j arr = U.MVector i j arr +{-# COMPLETE MVector #-} +{-# DEPRECATED MVector "Use constructor exported from Data.Vector.Primitive.Mutable.Unsafe" #-} -- Length information -- ------------------ @@ -745,18 +670,5 @@ ifoldrM' :: (PrimMonad m, Prim a) => (Int -> a -> b -> m b) -> b -> MVector (Pri {-# INLINE ifoldrM' #-} ifoldrM' = G.ifoldrM' --- Unsafe conversions --- ------------------ - --- | /O(1)/ Unsafely cast a vector from one element type to another. --- This operation just changes the type of the vector and does not --- modify the elements. --- --- This function will throw an error if elements are of mismatching sizes. --- --- | @since 0.13.0.0 -unsafeCast :: forall a b s. (HasCallStack, Prim a, Prim b) => MVector s a -> MVector s b -{-# INLINE unsafeCast #-} -unsafeCast (MVector o n ba) - | sizeOf (undefined :: a) == sizeOf (undefined :: b) = MVector o n ba - | otherwise = error "Element size mismatch" +-- $setup +-- >>> import Prelude (($), Num(..)) diff --git a/vector/src/Data/Vector/Primitive/Mutable/Unsafe.hs b/vector/src/Data/Vector/Primitive/Mutable/Unsafe.hs new file mode 100644 index 00000000..2f99d5b3 --- /dev/null +++ b/vector/src/Data/Vector/Primitive/Mutable/Unsafe.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- | +module Data.Vector.Primitive.Mutable.Unsafe + ( MVector(..) + , IOVector + , STVector + , unsafeCoerceMVector + , unsafeCast + ) where + +import qualified Data.Vector.Generic.Mutable as MG +import Data.Primitive.ByteArray +import Data.Primitive ( Prim, sizeOf ) +import Data.Word ( Word8 ) +import Control.Monad.Primitive +import Control.Monad ( liftM ) +import GHC.Stack (HasCallStack) + +import Control.DeepSeq ( NFData(rnf), NFData1(liftRnf)) + +import Prelude + ( Int, Eq(..), Ord(..) + , otherwise, error, undefined, div, Show(..), maxBound + , (+), (*), (&&), (||), ($), (++) ) + +import Data.Coerce +import Unsafe.Coerce + + + +---------------------------------------------------------------- +-- Mutable +---------------------------------------------------------------- + +type role MVector nominal nominal + +-- | Mutable vectors of primitive types. +data MVector s a = MVector {-# UNPACK #-} !Int -- ^ offset + {-# UNPACK #-} !Int -- ^ length + {-# UNPACK #-} !(MutableByteArray s) -- ^ underlying mutable byte array + +type IOVector = MVector RealWorld +type STVector s = MVector s + +-- | /O(1)/ Unsafely coerce a mutable vector from one element type to another, +-- representationally equal type. The operation just changes the type of the +-- underlying pointer and does not modify the elements. +-- +-- Note that this function is unsafe. The @Coercible@ constraint guarantees +-- that the element types are representationally equal. It however cannot +-- guarantee that their respective 'Prim' instances are compatible. +unsafeCoerceMVector :: Coercible a b => MVector s a -> MVector s b +unsafeCoerceMVector = unsafeCoerce + +-- | /O(1)/ Unsafely cast a vector from one element type to another. +-- This operation just changes the type of the vector and does not +-- modify the elements. +-- +-- This function will throw an error if elements are of mismatching sizes. +-- +-- | @since 0.13.0.0 +unsafeCast :: forall a b s. (HasCallStack, Prim a, Prim b) => MVector s a -> MVector s b +{-# INLINE unsafeCast #-} +unsafeCast (MVector o n ba) + | sizeOf (undefined :: a) == sizeOf (undefined :: b) = MVector o n ba + | otherwise = error "Element size mismatch" + + + +instance NFData (MVector s a) where + rnf (MVector _ _ _) = () + +instance NFData1 (MVector s) where + liftRnf _ (MVector _ _ _) = () + +instance Prim a => MG.MVector MVector a where + basicLength (MVector _ n _) = n + basicUnsafeSlice j m (MVector i _ arr) + = MVector (i+j) m arr + + {-# INLINE basicOverlaps #-} + basicOverlaps (MVector i m arr1) (MVector j n arr2) + = sameMutableByteArray arr1 arr2 + && (between i j (j+n) || between j i (i+m)) + where + between x y z = x >= y && x < z + + {-# INLINE basicUnsafeNew #-} + basicUnsafeNew n + | n < 0 = error $ "Primitive.basicUnsafeNew: negative length: " ++ show n + | n > mx = error $ "Primitive.basicUnsafeNew: length too large: " ++ show n + | otherwise = MVector 0 n `liftM` newByteArray (n * size) + where + size = sizeOf (undefined :: a) + mx = maxBound `div` size :: Int + + {-# INLINE basicInitialize #-} + basicInitialize (MVector off n v) = + setByteArray v (off * size) (n * size) (0 :: Word8) + where + size = sizeOf (undefined :: a) + + + {-# INLINE basicUnsafeRead #-} + basicUnsafeRead (MVector i _ arr) j = readByteArray arr (i+j) + + {-# INLINE basicUnsafeWrite #-} + basicUnsafeWrite (MVector i _ arr) j x = writeByteArray arr (i+j) x + + {-# INLINE basicUnsafeCopy #-} + basicUnsafeCopy (MVector i n dst) (MVector j _ src) + = copyMutableByteArray dst (i*sz) src (j*sz) (n*sz) + where + sz = sizeOf (undefined :: a) + + {-# INLINE basicUnsafeMove #-} + basicUnsafeMove (MVector i n dst) (MVector j _ src) + = moveByteArray dst (i*sz) src (j*sz) (n * sz) + where + sz = sizeOf (undefined :: a) + + {-# INLINE basicSet #-} + basicSet (MVector i n arr) x = setByteArray arr i n x + diff --git a/vector/src/Data/Vector/Primitive/Unsafe.hs b/vector/src/Data/Vector/Primitive/Unsafe.hs new file mode 100644 index 00000000..a8db1bdd --- /dev/null +++ b/vector/src/Data/Vector/Primitive/Unsafe.hs @@ -0,0 +1,169 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- | +module Data.Vector.Primitive.Unsafe + ( -- * Mutable vector + Vector(..) + , unsafeCoerceVector + , unsafeCast + ) where + +import qualified Data.Vector.Generic as G +import qualified Data.Vector.Fusion.Bundle as Bundle +import Data.Data +import Data.Semigroup (Semigroup(..)) +import Data.Monoid (Monoid(..)) +import Data.Primitive.ByteArray +import Data.Primitive ( Prim, sizeOf ) +import Control.Monad ( liftM ) +import Text.Read ( Read(..), readListPrecDefault ) +import qualified GHC.Exts as Exts +import GHC.Stack (HasCallStack) + +import Control.DeepSeq ( NFData(rnf), NFData1(liftRnf) ) + +import Prelude + ( Ord, Int, Ordering(..), Monad(..), Eq(..), Ord(..) + , undefined, Show(..), seq, otherwise, error + , (+), (*), ($!)) + +import Data.Coerce +import Unsafe.Coerce + +import Data.Vector.Primitive.Mutable.Unsafe (MVector(..)) +---------------------------------------------------------------- +-- Immutable +---------------------------------------------------------------- + +type role Vector nominal + +-- | Unboxed vectors of primitive types. +data Vector a = Vector {-# UNPACK #-} !Int -- ^ offset + {-# UNPACK #-} !Int -- ^ length + {-# UNPACK #-} !ByteArray -- ^ underlying byte array + +type instance G.Mutable Vector = MVector + +-- | /O(1)/ Unsafely coerce an immutable vector from one element type to another, +-- representationally equal type. The operation just changes the type of the +-- underlying pointer and does not modify the elements. +-- +-- This is marginally safer than 'unsafeCast', since this function imposes an +-- extra 'Coercible' constraint. The constraint guarantees that the element types +-- are representationally equal. It however cannot guarantee +-- that their respective 'Prim' instances are compatible. +unsafeCoerceVector :: Coercible a b => Vector a -> Vector b +unsafeCoerceVector = unsafeCoerce + +-- | /O(1)/ Unsafely cast a vector from one element type to another. +-- This operation just changes the type of the vector and does not +-- modify the elements. +-- +-- This function will throw an error if elements are of mismatching sizes. +-- +-- | @since 0.13.0.0 +unsafeCast :: forall a b. (HasCallStack, Prim a, Prim b) => Vector a -> Vector b +{-# INLINE unsafeCast #-} +unsafeCast (Vector o n ba) + | sizeOf (undefined :: a) == sizeOf (undefined :: b) = Vector o n ba + | otherwise = error "Element size mismatch" + + +instance Prim a => G.Vector Vector a where + {-# INLINE basicUnsafeFreeze #-} + basicUnsafeFreeze (MVector i n marr) + = Vector i n `liftM` unsafeFreezeByteArray marr + + {-# INLINE basicUnsafeThaw #-} + basicUnsafeThaw (Vector i n arr) + = MVector i n `liftM` unsafeThawByteArray arr + + {-# INLINE basicLength #-} + basicLength (Vector _ n _) = n + + {-# INLINE basicUnsafeSlice #-} + basicUnsafeSlice j n (Vector i _ arr) = Vector (i+j) n arr + + {-# INLINE basicUnsafeIndexM #-} + basicUnsafeIndexM (Vector i _ arr) j = return $! indexByteArray arr (i+j) + + {-# INLINE basicUnsafeCopy #-} + basicUnsafeCopy (MVector i n dst) (Vector j _ src) + = copyByteArray dst (i*sz) src (j*sz) (n*sz) + where + sz = sizeOf (undefined :: a) + + {-# INLINE elemseq #-} + elemseq _ = seq + + +instance NFData (Vector a) where + rnf (Vector _ _ _) = () + +-- | @since 0.12.1.0 +instance NFData1 Vector where + liftRnf _ (Vector _ _ _) = () + +instance (Show a, Prim a) => Show (Vector a) where + showsPrec = G.showsPrec + +instance (Read a, Prim a) => Read (Vector a) where + readPrec = G.readPrec + readListPrec = readListPrecDefault + +instance (Data a, Prim a) => Data (Vector a) where + gfoldl = G.gfoldl + toConstr _ = G.mkVecConstr "Data.Vector.Primitive.Vector" + gunfold = G.gunfold + dataTypeOf _ = G.mkVecType "Data.Vector.Primitive.Vector" + dataCast1 = G.dataCast + + +-- See http://trac.haskell.org/vector/ticket/12 +instance (Prim a, Eq a) => Eq (Vector a) where + {-# INLINE (==) #-} + xs == ys = Bundle.eq (G.stream xs) (G.stream ys) + +-- See http://trac.haskell.org/vector/ticket/12 +instance (Prim a, Ord a) => Ord (Vector a) where + {-# INLINE compare #-} + compare xs ys = Bundle.cmp (G.stream xs) (G.stream ys) + + {-# INLINE (<) #-} + xs < ys = Bundle.cmp (G.stream xs) (G.stream ys) == LT + + {-# INLINE (<=) #-} + xs <= ys = Bundle.cmp (G.stream xs) (G.stream ys) /= GT + + {-# INLINE (>) #-} + xs > ys = Bundle.cmp (G.stream xs) (G.stream ys) == GT + + {-# INLINE (>=) #-} + xs >= ys = Bundle.cmp (G.stream xs) (G.stream ys) /= LT + +instance Prim a => Semigroup (Vector a) where + {-# INLINE (<>) #-} + (<>) = (G.++) + + {-# INLINE sconcat #-} + sconcat = G.concatNE + +instance Prim a => Monoid (Vector a) where + {-# INLINE mempty #-} + mempty = G.empty + + {-# INLINE mappend #-} + mappend = (<>) + + {-# INLINE mconcat #-} + mconcat = G.concat + +instance Prim a => Exts.IsList (Vector a) where + type Item (Vector a) = a + fromList = G.fromList + fromListN = G.fromListN + toList = G.toList diff --git a/vector/src/Data/Vector/Storable.hs b/vector/src/Data/Vector/Storable.hs index fb32941a..a348bdb0 100644 --- a/vector/src/Data/Vector/Storable.hs +++ b/vector/src/Data/Vector/Storable.hs @@ -5,6 +5,7 @@ {-# LANGUAGE RoleAnnotations #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE PatternSynonyms #-} -- | -- Module : Data.Vector.Storable -- Copyright : (c) Roman Leshchinskiy 2009-2010 @@ -21,7 +22,7 @@ module Data.Vector.Storable ( -- * Storable vectors - Vector, MVector(..), + Vector, MVector, pattern MVector, -- * Accessors @@ -169,148 +170,20 @@ module Data.Vector.Storable ( import Control.Applicative (Applicative) import qualified Data.Vector.Generic as G -import Data.Vector.Storable.Mutable ( MVector(..) ) -import Data.Vector.Storable.Internal -import qualified Data.Vector.Fusion.Bundle as Bundle - -import Foreign.Storable -import Foreign.ForeignPtr -import Foreign.Ptr -import Foreign.Marshal.Array ( advancePtr, copyArray ) - -import Control.DeepSeq ( NFData(rnf), NFData1(liftRnf)) +import Data.Vector.Storable.Mutable ( MVector, pattern MVector ) +import Data.Vector.Storable.Unsafe import Control.Monad.ST ( ST ) import Control.Monad.Primitive - +import Foreign.Storable +import Foreign.ForeignPtr import Prelude - ( Eq, Ord, Num, Enum, Monoid, Traversable, Monad, Read, Show, Bool, Ordering(..), Int, Maybe, Either, IO - , compare, mempty, mappend, mconcat, showsPrec, return, seq, undefined, div - , (*), (<), (<=), (>), (>=), (==), (/=), (&&), (.), ($) ) - -import Data.Data ( Data(..) ) -import Text.Read ( Read(..), readListPrecDefault ) -import Data.Semigroup ( Semigroup(..) ) -import Data.Coerce -import qualified GHC.Exts as Exts -import Unsafe.Coerce + ( Eq, Ord, Num, Enum, Monoid, Traversable, Monad, Bool, Ordering(..), Int, Maybe, Either + , undefined, div + , (*), (==), (&&)) #include "vector.h" -type role Vector nominal - --- | /O(1)/ Unsafely coerce a mutable vector from one element type to another, --- representationally equal type. The operation just changes the type of the --- underlying pointer and does not modify the elements. --- --- This is marginally safer than 'unsafeCast', since this function imposes an --- extra 'Coercible' constraint. This function is still not safe, however, --- since it cannot guarantee that the two types have memory-compatible --- 'Storable' instances. -unsafeCoerceVector :: Coercible a b => Vector a -> Vector b -unsafeCoerceVector = unsafeCoerce - --- | 'Storable'-based vectors. -data Vector a = Vector {-# UNPACK #-} !Int - {-# UNPACK #-} !(ForeignPtr a) - -instance NFData (Vector a) where - rnf (Vector _ _) = () - --- | @since 0.12.1.0 -instance NFData1 Vector where - liftRnf _ (Vector _ _) = () - -instance (Show a, Storable a) => Show (Vector a) where - showsPrec = G.showsPrec - -instance (Read a, Storable a) => Read (Vector a) where - readPrec = G.readPrec - readListPrec = readListPrecDefault - -instance (Data a, Storable a) => Data (Vector a) where - gfoldl = G.gfoldl - toConstr _ = G.mkVecConstr "Data.Vector.Storable.Vector" - gunfold = G.gunfold - dataTypeOf _ = G.mkVecType "Data.Vector.Storable.Vector" - dataCast1 = G.dataCast - - -type instance G.Mutable Vector = MVector - -instance Storable a => G.Vector Vector a where - {-# INLINE basicUnsafeFreeze #-} - basicUnsafeFreeze (MVector n fp) = return $ Vector n fp - - {-# INLINE basicUnsafeThaw #-} - basicUnsafeThaw (Vector n fp) = return $ MVector n fp - - {-# INLINE basicLength #-} - basicLength (Vector n _) = n - - {-# INLINE basicUnsafeSlice #-} - basicUnsafeSlice i n (Vector _ fp) = Vector n (updPtr (`advancePtr` i) fp) - - {-# INLINE basicUnsafeIndexM #-} - basicUnsafeIndexM (Vector _ fp) i = return - . unsafeInlineIO - $ unsafeWithForeignPtr fp $ \p -> - peekElemOff p i - - {-# INLINE basicUnsafeCopy #-} - basicUnsafeCopy (MVector n fp) (Vector _ fq) - = unsafePrimToPrim - $ unsafeWithForeignPtr fp $ \p -> - unsafeWithForeignPtr fq $ \q -> - copyArray p q n - - {-# INLINE elemseq #-} - elemseq _ = seq - --- See http://trac.haskell.org/vector/ticket/12 -instance (Storable a, Eq a) => Eq (Vector a) where - {-# INLINE (==) #-} - xs == ys = Bundle.eq (G.stream xs) (G.stream ys) - --- See http://trac.haskell.org/vector/ticket/12 -instance (Storable a, Ord a) => Ord (Vector a) where - {-# INLINE compare #-} - compare xs ys = Bundle.cmp (G.stream xs) (G.stream ys) - - {-# INLINE (<) #-} - xs < ys = Bundle.cmp (G.stream xs) (G.stream ys) == LT - - {-# INLINE (<=) #-} - xs <= ys = Bundle.cmp (G.stream xs) (G.stream ys) /= GT - - {-# INLINE (>) #-} - xs > ys = Bundle.cmp (G.stream xs) (G.stream ys) == GT - - {-# INLINE (>=) #-} - xs >= ys = Bundle.cmp (G.stream xs) (G.stream ys) /= LT - -instance Storable a => Semigroup (Vector a) where - {-# INLINE (<>) #-} - (<>) = (++) - - {-# INLINE sconcat #-} - sconcat = G.concatNE - -instance Storable a => Monoid (Vector a) where - {-# INLINE mempty #-} - mempty = empty - - {-# INLINE mappend #-} - mappend = (<>) - - {-# INLINE mconcat #-} - mconcat = concat - -instance Storable a => Exts.IsList (Vector a) where - type Item (Vector a) = a - fromList = fromList - fromListN = fromListN - toList = toList -- Length -- ------ @@ -2093,58 +1966,6 @@ copy = G.copy -- Conversions - Raw pointers -- -------------------------- --- | /O(1)/ Create a vector from a 'ForeignPtr' with an offset and a length. --- --- The data may not be modified through the pointer 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_FUSED unsafeFromForeignPtr #-} -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 pointer afterwards. -unsafeFromForeignPtr0 :: 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 :: 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 that the pointer points directly to the data (no offset). --- --- The data may not be modified through the 'ForeignPtr'. -unsafeToForeignPtr0 :: 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. -unsafeWith :: Storable a => Vector a -> (Ptr a -> IO b) -> IO b -{-# INLINE unsafeWith #-} -unsafeWith (Vector _ fp) = withForeignPtr fp -- $setup -- >>> import Prelude (Bool(..), Double, ($), (+), (/), succ, even, min, max, id, Ord(..)) diff --git a/vector/src/Data/Vector/Storable/Mutable.hs b/vector/src/Data/Vector/Storable/Mutable.hs index 2e3c3cd2..395e81fc 100644 --- a/vector/src/Data/Vector/Storable/Mutable.hs +++ b/vector/src/Data/Vector/Storable/Mutable.hs @@ -4,6 +4,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RoleAnnotations #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE PatternSynonyms #-} -- | -- Module : Data.Vector.Storable.Mutable -- Copyright : (c) Roman Leshchinskiy 2009-2010 @@ -20,7 +21,8 @@ module Data.Vector.Storable.Mutable( -- * Mutable vectors of 'Storable' types - MVector(..), IOVector, STVector, + MVector, IOVector, STVector, + pattern MVector, -- * Accessors @@ -76,191 +78,26 @@ module Data.Vector.Storable.Mutable( Storable, PrimMonad, PrimState, RealWorld ) where -import Control.DeepSeq ( NFData(rnf), NFData1(liftRnf)) - import qualified Data.Vector.Generic.Mutable as G -import Data.Vector.Storable.Internal - +import Data.Vector.Storable.Mutable.Unsafe( + MVector,IOVector,STVector,unsafeCast,unsafeWith,unsafeCoerceMVector, + unsafeToForeignPtr,unsafeToForeignPtr0,unsafeFromForeignPtr,unsafeFromForeignPtr0) +import qualified Data.Vector.Storable.Mutable.Unsafe as U import Foreign.Storable -import Foreign.ForeignPtr - -import GHC.ForeignPtr (mallocPlainForeignPtrAlignedBytes) -import GHC.Base ( Int(..) ) - -import Foreign.Ptr (castPtr,plusPtr) -import Foreign.Marshal.Array ( advancePtr, copyArray, moveArray ) import Control.Monad.Primitive -import Data.Primitive.Types (Prim) -import qualified Data.Primitive.Types as DPT +import Foreign.ForeignPtr (ForeignPtr) -import GHC.Word (Word8, Word16, Word32, Word64) -import GHC.Ptr (Ptr(..)) +import Prelude (Int, Ord, Bool, Maybe, Ordering(..) ) -import Prelude - ( Ord, Bool, Maybe, IO, Ordering(..) - , return, otherwise, error, undefined, max, div, quot, maxBound, show - , (-), (*), (<), (>), (>=), (==), (&&), (||), (.), ($), (++) ) +#include "vector.h" -import Data.Coerce -import Unsafe.Coerce -#include "vector.h" +pattern MVector :: Int -> ForeignPtr a -> MVector s a +pattern MVector i ptr = U.MVector i ptr +{-# COMPLETE MVector #-} +{-# DEPRECATED MVector "Use constructor exported from Data.Vector.Strict.Mutable.Unsafe" #-} -type role MVector nominal nominal - --- | /O(1)/ Unsafely coerce a mutable vector from one element type to another, --- representationally equal type. The operation just changes the type of the --- underlying pointer and does not modify the elements. --- --- This is marginally safer than 'unsafeCast', since this function imposes an --- extra 'Coercible' constraint. This function is still not safe, however, --- since it cannot guarantee that the two types have memory-compatible --- 'Storable' instances. -unsafeCoerceMVector :: Coercible a b => MVector s a -> MVector s b -unsafeCoerceMVector = unsafeCoerce - --- | Mutable 'Storable'-based vectors. -data MVector s a = MVector {-# UNPACK #-} !Int - {-# UNPACK #-} !(ForeignPtr a) - -type IOVector = MVector RealWorld -type STVector s = MVector s - -instance NFData (MVector s a) where - rnf (MVector _ _) = () - -instance NFData1 (MVector s) where - liftRnf _ (MVector _ _) = () - -instance Storable a => G.MVector MVector a where - {-# INLINE basicLength #-} - basicLength (MVector n _) = n - - {-# INLINE basicUnsafeSlice #-} - basicUnsafeSlice j m (MVector _ fp) = MVector m (updPtr (`advancePtr` j) fp) - - -- FIXME: this relies on non-portable pointer comparisons - {-# INLINE basicOverlaps #-} - basicOverlaps (MVector m fp) (MVector n fq) - = between p q (q `advancePtr` n) || between q p (p `advancePtr` m) - where - between x y z = x >= y && x < z - p = getPtr fp - q = getPtr fq - - {-# INLINE basicUnsafeNew #-} - basicUnsafeNew n - | n < 0 = error $ "Storable.basicUnsafeNew: negative length: " ++ show n - | n > mx = error $ "Storable.basicUnsafeNew: length too large: " ++ show n - | otherwise = unsafePrimToPrim $ do - fp <- mallocVector n - return $ MVector n fp - where - size = sizeOf (undefined :: a) `max` 1 - mx = maxBound `quot` size :: Int - - {-# INLINE basicInitialize #-} - basicInitialize = storableZero - - {-# INLINE basicUnsafeRead #-} - basicUnsafeRead (MVector _ fp) i - = unsafePrimToPrim - $ unsafeWithForeignPtr fp (`peekElemOff` i) - - {-# INLINE basicUnsafeWrite #-} - basicUnsafeWrite (MVector _ fp) i x - = unsafePrimToPrim - $ unsafeWithForeignPtr fp $ \p -> pokeElemOff p i x - - {-# INLINE basicSet #-} - basicSet = storableSet - - {-# INLINE basicUnsafeCopy #-} - basicUnsafeCopy (MVector n fp) (MVector _ fq) - = unsafePrimToPrim - $ unsafeWithForeignPtr fp $ \p -> - unsafeWithForeignPtr fq $ \q -> - copyArray p q n - - {-# INLINE basicUnsafeMove #-} - basicUnsafeMove (MVector n fp) (MVector _ fq) - = unsafePrimToPrim - $ unsafeWithForeignPtr fp $ \p -> - unsafeWithForeignPtr fq $ \q -> - moveArray p q n - -storableZero :: forall a m. (Storable a, PrimMonad m) => MVector (PrimState m) a -> m () -{-# INLINE storableZero #-} -storableZero (MVector n fp) = unsafePrimToPrim . unsafeWithForeignPtr fp $ \ptr-> do - memsetPrimPtr_vector (castPtr ptr) byteSize (0 :: Word8) - where - x :: a - x = undefined - byteSize :: Int - byteSize = n * sizeOf x - -storableSet :: (Storable a, PrimMonad m) => MVector (PrimState m) a -> a -> m () -{-# INLINE storableSet #-} -storableSet (MVector n fp) x - | n == 0 = return () - | otherwise = unsafePrimToPrim $ - case sizeOf x of - 1 -> storableSetAsPrim n fp x (undefined :: Word8) - 2 -> storableSetAsPrim n fp x (undefined :: Word16) - 4 -> storableSetAsPrim n fp x (undefined :: Word32) -#if !defined(ghcjs_HOST_OS) - 8 -> storableSetAsPrim n fp x (undefined :: Word64) -#endif - _ -> unsafeWithForeignPtr fp $ \p -> do - poke p x - - let do_set i - | 2*i < n = do - copyArray (p `advancePtr` i) p i - do_set (2*i) - | otherwise = copyArray (p `advancePtr` i) p (n-i) - - do_set 1 - -storableSetAsPrim - :: forall a b . (Storable a, Prim b) => Int -> ForeignPtr a -> a -> b -> IO () -{-# INLINE [0] storableSetAsPrim #-} -storableSetAsPrim n fp x _y = unsafeWithForeignPtr fp $ \ ptr -> do - poke ptr x - -- we don't equate storable and prim reps, so we need to write to a slot - -- in storable - -- then read it back as a prim - w<- peakPrimPtr_vector (castPtr ptr :: Ptr b) 0 - memsetPrimPtr_vector (castPtr ptr `plusPtr` sizeOf x ) (n-1) w - - - -{- -AFTER primitive 0.7 is pretty old, move to using setPtr. which is really -a confusing misnomer for what's often called memset (initialize) --} --- Fill a memory block with the given value. The length is in --- elements of type @a@ rather than in bytes. -memsetPrimPtr_vector :: forall a c m. (Prim c, PrimMonad m) => Ptr a -> Int -> c -> m () -memsetPrimPtr_vector (Ptr addr#) (I# n#) x = primitive_ (DPT.setOffAddr# addr# 0# n# x) -{-# INLINE memsetPrimPtr_vector #-} - - --- Read a value from a memory position given by an address and an offset. --- The offset is in elements of type @a@ rather than in bytes. -peakPrimPtr_vector :: (Prim a, PrimMonad m) => Ptr a -> Int -> m a -peakPrimPtr_vector (Ptr addr#) (I# i#) = primitive (DPT.readOffAddr# addr# i#) -{-# INLINE peakPrimPtr_vector #-} - -{-# INLINE mallocVector #-} -mallocVector :: Storable a => Int -> IO (ForeignPtr a) -mallocVector = - doMalloc undefined - where - doMalloc :: Storable b => b -> Int -> IO (ForeignPtr b) - doMalloc dummy size = - mallocPlainForeignPtrAlignedBytes (size * sizeOf dummy) (alignment dummy) -- Length information -- ------------------ @@ -846,79 +683,5 @@ ifoldrM' :: (PrimMonad m, Storable a) => (Int -> a -> b -> m b) -> b -> MVector {-# INLINE ifoldrM' #-} ifoldrM' = G.ifoldrM' --- Unsafe conversions --- ------------------ - --- | /O(1)/ Unsafely cast a mutable vector from one element type to another. --- The operation just changes the type of the underlying pointer and does not --- modify the elements. --- --- The resulting vector contains as many elements as can fit into the --- underlying memory block. -unsafeCast :: forall a b s. - (Storable a, Storable b) => MVector s a -> MVector s b -{-# INLINE unsafeCast #-} -unsafeCast (MVector n fp) - = MVector ((n * sizeOf (undefined :: a)) `div` sizeOf (undefined :: b)) - (castForeignPtr fp) - --- Raw pointers --- ------------ - --- | /O(1)/ 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_FUSED unsafeFromForeignPtr #-} -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 that 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 :: ForeignPtr a -- ^ pointer - -> Int -- ^ length - -> MVector s a -{-# INLINE unsafeFromForeignPtr0 #-} -unsafeFromForeignPtr0 fp n = MVector n fp - --- | /O(1)/ 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 been frozen before the modification. -unsafeToForeignPtr :: 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 that the pointer points directly to the data (no offset). --- --- Modifying the data through the 'ForeignPtr' is unsafe if the vector could --- have been frozen before the modification. -unsafeToForeignPtr0 :: 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 --- the modification. -unsafeWith :: Storable a => IOVector a -> (Ptr a -> IO b) -> IO b -{-# INLINE unsafeWith #-} -unsafeWith (MVector _ fp) = withForeignPtr fp +-- $setup +-- >>> import Prelude (($), Num(..)) diff --git a/vector/src/Data/Vector/Storable/Mutable/Unsafe.hs b/vector/src/Data/Vector/Storable/Mutable/Unsafe.hs new file mode 100644 index 00000000..086d3b42 --- /dev/null +++ b/vector/src/Data/Vector/Storable/Mutable/Unsafe.hs @@ -0,0 +1,282 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- | +module Data.Vector.Storable.Mutable.Unsafe + ( MVector(..) + , IOVector + , STVector + -- * Unsafe conversions + , unsafeCast + , unsafeCoerceMVector + -- * Working with raw pointers + , unsafeFromForeignPtr, unsafeFromForeignPtr0 + , unsafeToForeignPtr, unsafeToForeignPtr0 + , unsafeWith + ) where + +import Control.DeepSeq (NFData(rnf), NFData1(liftRnf)) + +import qualified Data.Vector.Generic.Mutable as G +import Data.Vector.Storable.Internal + +import Foreign.Storable +import Foreign.ForeignPtr + +import GHC.ForeignPtr (mallocPlainForeignPtrAlignedBytes) +import GHC.Base ( Int(..) ) + +import Foreign.Ptr (castPtr,plusPtr) +import Foreign.Marshal.Array ( advancePtr, copyArray, moveArray ) + +import Control.Monad.Primitive +import Data.Primitive.Types (Prim) +import qualified Data.Primitive.Types as DPT + +import GHC.Word (Word8, Word16, Word32, Word64) +import GHC.Ptr (Ptr(..)) + +import Prelude + ( IO, return, otherwise, error, undefined, max, div, quot, maxBound, show + , (-), (*), (<), (>), (>=), (==), (&&), (||), (.), ($), (++) ) + +import Data.Coerce +import Unsafe.Coerce + +#include "vector.h" + + +type role MVector nominal nominal + +-- | Mutable 'Storable'-based vectors. +data MVector s a = MVector {-# UNPACK #-} !Int + {-# UNPACK #-} !(ForeignPtr a) + +type IOVector = MVector RealWorld +type STVector s = MVector s + +instance NFData (MVector s a) where + rnf (MVector _ _) = () + +instance NFData1 (MVector s) where + liftRnf _ (MVector _ _) = () + +instance Storable a => G.MVector MVector a where + {-# INLINE basicLength #-} + basicLength (MVector n _) = n + + {-# INLINE basicUnsafeSlice #-} + basicUnsafeSlice j m (MVector _ fp) = MVector m (updPtr (`advancePtr` j) fp) + + -- FIXME: this relies on non-portable pointer comparisons + {-# INLINE basicOverlaps #-} + basicOverlaps (MVector m fp) (MVector n fq) + = between p q (q `advancePtr` n) || between q p (p `advancePtr` m) + where + between x y z = x >= y && x < z + p = getPtr fp + q = getPtr fq + + {-# INLINE basicUnsafeNew #-} + basicUnsafeNew n + | n < 0 = error $ "Storable.basicUnsafeNew: negative length: " ++ show n + | n > mx = error $ "Storable.basicUnsafeNew: length too large: " ++ show n + | otherwise = unsafePrimToPrim $ do + fp <- mallocVector n + return $ MVector n fp + where + size = sizeOf (undefined :: a) `max` 1 + mx = maxBound `quot` size :: Int + + {-# INLINE basicInitialize #-} + basicInitialize = storableZero + + {-# INLINE basicUnsafeRead #-} + basicUnsafeRead (MVector _ fp) i + = unsafePrimToPrim + $ unsafeWithForeignPtr fp (`peekElemOff` i) + + {-# INLINE basicUnsafeWrite #-} + basicUnsafeWrite (MVector _ fp) i x + = unsafePrimToPrim + $ unsafeWithForeignPtr fp $ \p -> pokeElemOff p i x + + {-# INLINE basicSet #-} + basicSet = storableSet + + {-# INLINE basicUnsafeCopy #-} + basicUnsafeCopy (MVector n fp) (MVector _ fq) + = unsafePrimToPrim + $ unsafeWithForeignPtr fp $ \p -> + unsafeWithForeignPtr fq $ \q -> + copyArray p q n + + {-# INLINE basicUnsafeMove #-} + basicUnsafeMove (MVector n fp) (MVector _ fq) + = unsafePrimToPrim + $ unsafeWithForeignPtr fp $ \p -> + unsafeWithForeignPtr fq $ \q -> + moveArray p q n + + +{-# INLINE mallocVector #-} +mallocVector :: Storable a => Int -> IO (ForeignPtr a) +mallocVector = + doMalloc undefined + where + doMalloc :: Storable b => b -> Int -> IO (ForeignPtr b) + doMalloc dummy size = + mallocPlainForeignPtrAlignedBytes (size * sizeOf dummy) (alignment dummy) + +storableZero :: forall a m. (Storable a, PrimMonad m) => MVector (PrimState m) a -> m () +{-# INLINE storableZero #-} +storableZero (MVector n fp) = unsafePrimToPrim . unsafeWithForeignPtr fp $ \ptr-> do + memsetPrimPtr_vector (castPtr ptr) byteSize (0 :: Word8) + where + x :: a + x = undefined + byteSize :: Int + byteSize = n * sizeOf x + +storableSet :: (Storable a, PrimMonad m) => MVector (PrimState m) a -> a -> m () +{-# INLINE storableSet #-} +storableSet (MVector n fp) x + | n == 0 = return () + | otherwise = unsafePrimToPrim $ + case sizeOf x of + 1 -> storableSetAsPrim n fp x (undefined :: Word8) + 2 -> storableSetAsPrim n fp x (undefined :: Word16) + 4 -> storableSetAsPrim n fp x (undefined :: Word32) +#if !defined(ghcjs_HOST_OS) + 8 -> storableSetAsPrim n fp x (undefined :: Word64) +#endif + _ -> unsafeWithForeignPtr fp $ \p -> do + poke p x + + let do_set i + | 2*i < n = do + copyArray (p `advancePtr` i) p i + do_set (2*i) + | otherwise = copyArray (p `advancePtr` i) p (n-i) + + do_set 1 + +storableSetAsPrim + :: forall a b . (Storable a, Prim b) => Int -> ForeignPtr a -> a -> b -> IO () +{-# INLINE [0] storableSetAsPrim #-} +storableSetAsPrim n fp x _y = unsafeWithForeignPtr fp $ \ ptr -> do + poke ptr x + -- we don't equate storable and prim reps, so we need to write to a slot + -- in storable + -- then read it back as a prim + w<- peakPrimPtr_vector (castPtr ptr :: Ptr b) 0 + memsetPrimPtr_vector (castPtr ptr `plusPtr` sizeOf x ) (n-1) w + +{- +AFTER primitive 0.7 is pretty old, move to using setPtr. which is really +a confusing misnomer for what's often called memset (initialize) +-} +-- Fill a memory block with the given value. The length is in +-- elements of type @a@ rather than in bytes. +memsetPrimPtr_vector :: forall a c m. (Prim c, PrimMonad m) => Ptr a -> Int -> c -> m () +memsetPrimPtr_vector (Ptr addr#) (I# n#) x = primitive_ (DPT.setOffAddr# addr# 0# n# x) +{-# INLINE memsetPrimPtr_vector #-} + + +-- Read a value from a memory position given by an address and an offset. +-- The offset is in elements of type @a@ rather than in bytes. +peakPrimPtr_vector :: (Prim a, PrimMonad m) => Ptr a -> Int -> m a +peakPrimPtr_vector (Ptr addr#) (I# i#) = primitive (DPT.readOffAddr# addr# i#) +{-# INLINE peakPrimPtr_vector #-} + + +-- Unsafe conversions +-- ------------------ + +-- | /O(1)/ Unsafely cast a mutable vector from one element type to another. +-- The operation just changes the type of the underlying pointer and does not +-- modify the elements. +-- +-- The resulting vector contains as many elements as can fit into the +-- underlying memory block. +unsafeCast :: forall a b s. + (Storable a, Storable b) => MVector s a -> MVector s b +{-# INLINE unsafeCast #-} +unsafeCast (MVector n fp) + = MVector ((n * sizeOf (undefined :: a)) `div` sizeOf (undefined :: b)) + (castForeignPtr fp) + +-- | /O(1)/ Unsafely coerce a mutable vector from one element type to another, +-- representationally equal type. The operation just changes the type of the +-- underlying pointer and does not modify the elements. +-- +-- This is marginally safer than 'unsafeCast', since this function imposes an +-- extra 'Coercible' constraint. This function is still not safe, however, +-- since it cannot guarantee that the two types have memory-compatible +-- 'Storable' instances. +unsafeCoerceMVector :: Coercible a b => MVector s a -> MVector s b +unsafeCoerceMVector = unsafeCoerce + +-- Raw pointers +-- ------------ + +-- | /O(1)/ 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_FUSED unsafeFromForeignPtr #-} +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 that 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 :: ForeignPtr a -- ^ pointer + -> Int -- ^ length + -> MVector s a +{-# INLINE unsafeFromForeignPtr0 #-} +unsafeFromForeignPtr0 fp n = MVector n fp + +-- | /O(1)/ 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 been frozen before the modification. +unsafeToForeignPtr :: 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 that the pointer points directly to the data (no offset). +-- +-- Modifying the data through the 'ForeignPtr' is unsafe if the vector could +-- have been frozen before the modification. +unsafeToForeignPtr0 :: 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 +-- the modification. +unsafeWith :: Storable a => IOVector a -> (Ptr a -> IO b) -> IO b +{-# INLINE unsafeWith #-} +unsafeWith (MVector _ fp) = withForeignPtr fp diff --git a/vector/src/Data/Vector/Storable/Unsafe.hs b/vector/src/Data/Vector/Storable/Unsafe.hs new file mode 100644 index 00000000..f8224bfe --- /dev/null +++ b/vector/src/Data/Vector/Storable/Unsafe.hs @@ -0,0 +1,213 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +-- | +module Data.Vector.Storable.Unsafe + ( Vector(..) + , unsafeCoerceVector + -- * Raw pointers + , unsafeFromForeignPtr, unsafeFromForeignPtr0 + , unsafeToForeignPtr, unsafeToForeignPtr0 + , unsafeWith + ) where + +import qualified Data.Vector.Generic as G +import Data.Vector.Storable.Mutable.Unsafe ( MVector(..) ) +import Data.Vector.Storable.Internal +import qualified Data.Vector.Fusion.Bundle as Bundle + +import Foreign.Storable +import Foreign.ForeignPtr +import Foreign.Ptr +import Foreign.Marshal.Array ( advancePtr, copyArray ) + +import Control.DeepSeq ( NFData(rnf), NFData1(liftRnf)) + +import Control.Monad.Primitive + +import Prelude + ( Eq, Ord, Monoid, Read, Show, Ordering(..), Int, IO + , compare, mempty, mappend, mconcat, showsPrec, return, seq + , (<), (<=), (>), (>=), (==), (/=), (.), ($) ) + +import Data.Data ( Data(..) ) +import Text.Read ( Read(..), readListPrecDefault ) +import Data.Semigroup ( Semigroup(..) ) +import Data.Coerce +import qualified GHC.Exts as Exts +import Unsafe.Coerce + +#include "vector.h" + +type role Vector nominal + +-- | /O(1)/ Unsafely coerce a mutable vector from one element type to another, +-- representationally equal type. The operation just changes the type of the +-- underlying pointer and does not modify the elements. +-- +-- This is marginally safer than 'unsafeCast', since this function imposes an +-- extra 'Coercible' constraint. This function is still not safe, however, +-- since it cannot guarantee that the two types have memory-compatible +-- 'Storable' instances. +unsafeCoerceVector :: Coercible a b => Vector a -> Vector b +unsafeCoerceVector = unsafeCoerce + +-- | 'Storable'-based vectors. +data Vector a = Vector {-# UNPACK #-} !Int + {-# UNPACK #-} !(ForeignPtr a) + +instance NFData (Vector a) where + rnf (Vector _ _) = () + +-- | @since 0.12.1.0 +instance NFData1 Vector where + liftRnf _ (Vector _ _) = () + +instance (Show a, Storable a) => Show (Vector a) where + showsPrec = G.showsPrec + +instance (Read a, Storable a) => Read (Vector a) where + readPrec = G.readPrec + readListPrec = readListPrecDefault + +instance (Data a, Storable a) => Data (Vector a) where + gfoldl = G.gfoldl + toConstr _ = G.mkVecConstr "Data.Vector.Storable.Vector" + gunfold = G.gunfold + dataTypeOf _ = G.mkVecType "Data.Vector.Storable.Vector" + dataCast1 = G.dataCast + + +type instance G.Mutable Vector = MVector + +instance Storable a => G.Vector Vector a where + {-# INLINE basicUnsafeFreeze #-} + basicUnsafeFreeze (MVector n fp) = return $ Vector n fp + + {-# INLINE basicUnsafeThaw #-} + basicUnsafeThaw (Vector n fp) = return $ MVector n fp + + {-# INLINE basicLength #-} + basicLength (Vector n _) = n + + {-# INLINE basicUnsafeSlice #-} + basicUnsafeSlice i n (Vector _ fp) = Vector n (updPtr (`advancePtr` i) fp) + + {-# INLINE basicUnsafeIndexM #-} + basicUnsafeIndexM (Vector _ fp) i = return + . unsafeInlineIO + $ unsafeWithForeignPtr fp $ \p -> + peekElemOff p i + + {-# INLINE basicUnsafeCopy #-} + basicUnsafeCopy (MVector n fp) (Vector _ fq) + = unsafePrimToPrim + $ unsafeWithForeignPtr fp $ \p -> + unsafeWithForeignPtr fq $ \q -> + copyArray p q n + + {-# INLINE elemseq #-} + elemseq _ = seq + +-- See http://trac.haskell.org/vector/ticket/12 +instance (Storable a, Eq a) => Eq (Vector a) where + {-# INLINE (==) #-} + xs == ys = Bundle.eq (G.stream xs) (G.stream ys) + +-- See http://trac.haskell.org/vector/ticket/12 +instance (Storable a, Ord a) => Ord (Vector a) where + {-# INLINE compare #-} + compare xs ys = Bundle.cmp (G.stream xs) (G.stream ys) + + {-# INLINE (<) #-} + xs < ys = Bundle.cmp (G.stream xs) (G.stream ys) == LT + + {-# INLINE (<=) #-} + xs <= ys = Bundle.cmp (G.stream xs) (G.stream ys) /= GT + + {-# INLINE (>) #-} + xs > ys = Bundle.cmp (G.stream xs) (G.stream ys) == GT + + {-# INLINE (>=) #-} + xs >= ys = Bundle.cmp (G.stream xs) (G.stream ys) /= LT + +instance Storable a => Semigroup (Vector a) where + {-# INLINE (<>) #-} + (<>) = (G.++) + + {-# INLINE sconcat #-} + sconcat = G.concatNE + +instance Storable a => Monoid (Vector a) where + {-# INLINE mempty #-} + mempty = G.empty + + {-# INLINE mappend #-} + mappend = (<>) + + {-# INLINE mconcat #-} + mconcat = G.concat + +instance Storable a => Exts.IsList (Vector a) where + type Item (Vector a) = a + fromList = G.fromList + fromListN = G.fromListN + toList = G.toList + + +-- | /O(1)/ Create a vector from a 'ForeignPtr' with an offset and a length. +-- +-- The data may not be modified through the pointer 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_FUSED unsafeFromForeignPtr #-} +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 pointer afterwards. +unsafeFromForeignPtr0 :: 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 :: 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 that the pointer points directly to the data (no offset). +-- +-- The data may not be modified through the 'ForeignPtr'. +unsafeToForeignPtr0 :: 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. +unsafeWith :: Storable a => Vector a -> (Ptr a -> IO b) -> IO b +{-# INLINE unsafeWith #-} +unsafeWith (Vector _ fp) = withForeignPtr fp diff --git a/vector/src/Data/Vector/Strict.hs b/vector/src/Data/Vector/Strict.hs index 58db6d3f..5c5490c0 100644 --- a/vector/src/Data/Vector/Strict.hs +++ b/vector/src/Data/Vector/Strict.hs @@ -178,220 +178,17 @@ module Data.Vector.Strict ( ) where import Control.Applicative (Applicative) -import Data.Coerce -import Data.Vector.Strict.Mutable ( MVector(..) ) -import Data.Primitive.Array +import Control.Monad.Primitive +import Data.Vector.Strict.Mutable.Unsafe ( MVector(..) ) +import Data.Vector.Strict.Unsafe import qualified Data.Vector.Generic as G -import qualified Data.Vector as V - -import Control.DeepSeq ( NFData(rnf), NFData1(liftRnf)) +import qualified Data.Traversable as Traversable -import Control.Monad ( MonadPlus(..), ap ) -import Control.Monad.ST ( ST, runST ) -import Control.Monad.Primitive -import qualified Control.Monad.Fail as Fail -import Control.Monad.Fix ( MonadFix (mfix) ) -import Control.Monad.Zip -import Data.Function ( fix ) +import Control.Monad.ST ( ST ) import Prelude - ( Eq(..), Ord(..), Num, Enum, Monoid, Functor, Monad, Show, Bool, Ordering(..), Int, Maybe, Either - , return, showsPrec, fmap, otherwise, id, flip, const - , (>>=), (+), (-), (.), ($), seq) - -import Data.Functor.Classes (Eq1 (..), Ord1 (..), Read1 (..), Show1 (..)) -import Data.Data ( Data(..) ) -import Text.Read ( Read(..), readListPrecDefault ) -import Data.Semigroup ( Semigroup(..) ) - -import qualified Control.Applicative as Applicative -import qualified Data.Foldable as Foldable -import qualified Data.Traversable as Traversable - -import qualified GHC.Exts as Exts (IsList(..)) - - --- | Strict boxed vectors, supporting efficient slicing. -newtype Vector a = Vector (V.Vector a) - deriving (Foldable.Foldable, Semigroup, Monoid) - --- NOTE: [GND for strict vector] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- Strict boxed vectors (both mutable an immutable) are newtypes over --- lazy ones. This makes it possible to use GND to derive instances. --- However one must take care to preserve strictness since Vector --- instance for lazy vectors would be used. --- --- In general it's OK to derive instances where vectors are passed as --- parameters (e.g. Eq, Ord) and not OK to derive ones where new --- vector is created (e.g. Read, Functor) - -instance NFData a => NFData (Vector a) where - rnf = liftRnf rnf - {-# INLINEABLE rnf #-} - --- | @since 0.13.2.0 -instance NFData1 Vector where - liftRnf elemRnf = foldl' (\_ -> elemRnf) () - {-# INLINEABLE liftRnf #-} - -instance Show a => Show (Vector a) where - showsPrec = G.showsPrec - -instance Read a => Read (Vector a) where - readPrec = G.readPrec - readListPrec = readListPrecDefault - -instance Show1 Vector where - liftShowsPrec = G.liftShowsPrec - -instance Read1 Vector where - liftReadsPrec = G.liftReadsPrec - -instance Exts.IsList (Vector a) where - type Item (Vector a) = a - fromList = Data.Vector.Strict.fromList - fromListN = Data.Vector.Strict.fromListN - toList = toList - -instance Data a => Data (Vector a) where - gfoldl = G.gfoldl - toConstr _ = G.mkVecConstr "Data.Vector.Strict.Vector" - gunfold = G.gunfold - dataTypeOf _ = G.mkVecType "Data.Vector.Strict.Vector" - dataCast1 = G.dataCast - -type instance G.Mutable Vector = MVector - -instance G.Vector Vector a where - {-# INLINE basicUnsafeFreeze #-} - basicUnsafeFreeze = coerce (G.basicUnsafeFreeze @V.Vector @a) - {-# INLINE basicUnsafeThaw #-} - basicUnsafeThaw = coerce (G.basicUnsafeThaw @V.Vector @a) - {-# INLINE basicLength #-} - basicLength = coerce (G.basicLength @V.Vector @a) - {-# INLINE basicUnsafeSlice #-} - basicUnsafeSlice = coerce (G.basicUnsafeSlice @V.Vector @a) - {-# INLINE basicUnsafeIndexM #-} - basicUnsafeIndexM = coerce (G.basicUnsafeIndexM @V.Vector @a) - {-# INLINE basicUnsafeCopy #-} - basicUnsafeCopy = coerce (G.basicUnsafeCopy @V.Vector @a) - {-# INLINE elemseq #-} - elemseq _ = seq - --- See NOTE: [GND for strict vector] --- --- Deriving strategies are only available since 8.2. So we can't use --- deriving newtype until we drop support for 8.0 -instance Eq a => Eq (Vector a) where - {-# INLINE (==) #-} - (==) = coerce ((==) @(V.Vector a)) - --- See NOTE: [GND for strict vector] -instance Ord a => Ord (Vector a) where - {-# INLINE compare #-} - compare = coerce (compare @(V.Vector a)) - {-# INLINE (<) #-} - (<) = coerce ((<) @(V.Vector a)) - {-# INLINE (<=) #-} - (<=) = coerce ((<=) @(V.Vector a)) - {-# INLINE (>) #-} - (>) = coerce ((>) @(V.Vector a)) - {-# INLINE (>=) #-} - (>=) = coerce ((>=) @(V.Vector a)) - -instance Eq1 Vector where - {-# INLINE liftEq #-} - liftEq = eqBy - -instance Ord1 Vector where - {-# INLINE liftCompare #-} - liftCompare = cmpBy - -instance Functor Vector where - {-# INLINE fmap #-} - fmap = map - - {-# INLINE (<$) #-} - (<$) = map . const - -instance Monad Vector where - {-# INLINE return #-} - return = Applicative.pure - - {-# INLINE (>>=) #-} - (>>=) = flip concatMap - --- | @since 0.13.2.0 -instance Fail.MonadFail Vector where - {-# INLINE fail #-} - fail _ = empty - -instance MonadPlus Vector where - {-# INLINE mzero #-} - mzero = empty - - {-# INLINE mplus #-} - mplus = (++) - -instance MonadZip Vector where - {-# INLINE mzip #-} - mzip = zip - - {-# INLINE mzipWith #-} - mzipWith = zipWith - - {-# INLINE munzip #-} - munzip = unzip - --- | This instance has the same semantics as the one for lists. --- --- @since 0.13.2.0 -instance MonadFix Vector where - -- We take care to dispose of v0 as soon as possible (see headM docs). - -- - -- It's perfectly safe to use non-monadic indexing within generate - -- call since intermediate vector won't be created until result's - -- value is demanded. - {-# INLINE mfix #-} - mfix f - | null v0 = empty - -- We take first element of resulting vector from v0 and create - -- rest using generate. Note that cons should fuse with generate - | otherwise = runST $ do - h <- headM v0 - return $ cons h $ - generate (lv0 - 1) $ - \i -> fix (\a -> f a ! (i + 1)) - where - -- Used to calculate size of resulting vector - v0 = fix (f . head) - !lv0 = length v0 - -instance Applicative.Applicative Vector where - {-# INLINE pure #-} - pure = singleton - - {-# INLINE (<*>) #-} - (<*>) = ap - -instance Applicative.Alternative Vector where - {-# INLINE empty #-} - empty = empty - - {-# INLINE (<|>) #-} - (<|>) = (++) - -instance Traversable.Traversable Vector where - {-# INLINE traverse #-} - traverse = traverse - - {-# INLINE mapM #-} - mapM = mapM - - {-# INLINE sequence #-} - sequence = sequence + ( Eq(..), Ord(..), Num, Enum, Monoid, Monad, Bool, Ordering(..), Int, Maybe, Either + , id) -- Length information -- ------------------ @@ -2549,67 +2346,6 @@ iforA_ :: (Applicative f) iforA_ = G.iforA_ --- Conversions - Lazy vectors --- ----------------------------- - --- | /O(1)/ Convert strict array to lazy array -toLazy :: Vector a -> V.Vector a -toLazy (Vector v) = v - --- | /O(n)/ Convert lazy array to strict array. This function reduces --- each element of vector to WHNF. -fromLazy :: V.Vector a -> Vector a -fromLazy vec = liftRnf (`seq` ()) v `seq` v where v = Vector vec - - --- Conversions - Arrays --- ----------------------------- - --- | /O(n)/ Convert an array to a vector and reduce each element to WHNF. --- --- @since 0.13.2.0 -fromArray :: Array a -> Vector a -{-# INLINE fromArray #-} -fromArray arr = liftRnf (`seq` ()) vec `seq` vec - where - vec = Vector $ V.fromArray arr - --- | /O(n)/ Convert a vector to an array. --- --- @since 0.13.2.0 -toArray :: Vector a -> Array a -{-# INLINE toArray #-} -toArray (Vector v) = V.toArray v - --- | /O(1)/ Extract the underlying `Array`, offset where vector starts and the --- total number of elements in the vector. Below property always holds: --- --- > let (array, offset, len) = toArraySlice v --- > v === unsafeFromArraySlice len offset array --- --- @since 0.13.2.0 -toArraySlice :: Vector a -> (Array a, Int, Int) -{-# INLINE toArraySlice #-} -toArraySlice (Vector v) = V.toArraySlice v - - --- | /O(n)/ Convert an array slice to a vector and reduce each element to WHNF. --- --- This function is very unsafe, because constructing an invalid --- vector can yield almost all other safe functions in this module --- unsafe. These are equivalent: --- --- > unsafeFromArraySlice len offset === unsafeTake len . unsafeDrop offset . fromArray --- --- @since 0.13.2.0 -unsafeFromArraySlice :: - Array a -- ^ Immutable boxed array. - -> Int -- ^ Offset - -> Int -- ^ Length - -> Vector a -{-# INLINE unsafeFromArraySlice #-} -unsafeFromArraySlice arr offset len = liftRnf (`seq` ()) vec `seq` vec - where vec = Vector (V.unsafeFromArraySlice arr offset len) @@ -2687,4 +2423,4 @@ copy = G.copy -- $setup -- >>> :set -Wno-type-defaults --- >>> import Prelude (Char, String, Bool(True, False), min, max, fst, even, undefined, Ord(..)) +-- >>> import Prelude (Char, String, Bool(..), min, max, fst, even, undefined, Ord(..), (<>), Num(..),($)) diff --git a/vector/src/Data/Vector/Strict/Mutable.hs b/vector/src/Data/Vector/Strict/Mutable.hs index 7af79a75..c746b9ea 100644 --- a/vector/src/Data/Vector/Strict/Mutable.hs +++ b/vector/src/Data/Vector/Strict/Mutable.hs @@ -6,6 +6,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE PatternSynonyms #-} -- | -- Module : Data.Vector.Strict.Mutable -- Copyright : (c) Roman Leshchinskiy 2008-2010 @@ -24,7 +25,8 @@ -- are set to ⊥. module Data.Vector.Strict.Mutable ( -- * Mutable boxed vectors - MVector(MVector), IOVector, STVector, + MVector, IOVector, STVector, + pattern MVector, -- * Accessors @@ -76,52 +78,21 @@ module Data.Vector.Strict.Mutable ( PrimMonad, PrimState, RealWorld ) where -import Data.Coerce import qualified Data.Vector.Generic.Mutable as G -import qualified Data.Vector.Mutable as MV -import Data.Primitive.Array +import qualified Data.Vector.Mutable as MV +import Data.Vector.Strict.Mutable.Unsafe + (MVector,IOVector,STVector,toLazy,fromLazy,toMutableArray,fromMutableArray) +import qualified Data.Vector.Strict.Mutable.Unsafe as U import Control.Monad.Primitive -import Prelude - ( Ord, Monad(..), Bool, Int, Maybe, Ordering(..) - , return, ($), (<$>) ) +import Prelude ( Ord, Bool, Int, Maybe, Ordering(..)) #include "vector.h" -type role MVector nominal representational - --- | Mutable boxed vectors keyed on the monad they live in ('IO' or @'ST' s@). -newtype MVector s a = MVector (MV.MVector s a) - -type IOVector = MVector RealWorld -type STVector s = MVector s - -instance G.MVector MVector a where - {-# INLINE basicLength #-} - basicLength = coerce (G.basicLength @MV.MVector @a) - {-# INLINE basicUnsafeSlice #-} - basicUnsafeSlice = coerce (G.basicUnsafeSlice @MV.MVector @a) - {-# INLINE basicOverlaps #-} - basicOverlaps = coerce (G.basicOverlaps @MV.MVector @a) - {-# INLINE basicUnsafeNew #-} - basicUnsafeNew = coerce (G.basicUnsafeNew @MV.MVector @a) - {-# INLINE basicInitialize #-} - -- initialization is unnecessary for boxed vectors - basicInitialize _ = return () - {-# INLINE basicUnsafeReplicate #-} - basicUnsafeReplicate n !x = coerce (G.basicUnsafeReplicate @MV.MVector @a) n x - {-# INLINE basicUnsafeRead #-} - basicUnsafeRead = coerce (G.basicUnsafeRead @MV.MVector @a) - {-# INLINE basicUnsafeWrite #-} - basicUnsafeWrite vec j !x = (coerce (G.basicUnsafeWrite @MV.MVector @a)) vec j x - - {-# INLINE basicUnsafeCopy #-} - basicUnsafeCopy = coerce (G.basicUnsafeCopy @MV.MVector @a) - - {-# INLINE basicUnsafeMove #-} - basicUnsafeMove = coerce (G.basicUnsafeMove @MV.MVector @a) - {-# INLINE basicClear #-} - basicClear = coerce (G.basicClear @MV.MVector @a) +pattern MVector :: MV.MVector s a -> MVector s a +pattern MVector v = U.MVector v +{-# COMPLETE MVector #-} +{-# DEPRECATED MVector "Use constructor exported from Data.Vector.Strict.Unsafe" #-} -- Length information @@ -769,44 +740,6 @@ ifoldrM' :: (PrimMonad m) => (Int -> a -> b -> m b) -> b -> MVector (PrimState m {-# INLINE ifoldrM' #-} ifoldrM' = G.ifoldrM' --- Conversions - Lazy vectors --- ----------------------------- - --- | /O(1)/ Convert strict mutable vector to lazy mutable --- vector. Vectors will share mutable buffer -toLazy :: MVector s a -> MV.MVector s a -{-# INLINE toLazy #-} -toLazy (MVector vec) = vec - --- | /O(n)/ Convert lazy mutable vector to strict mutable --- vector. Vectors will share mutable buffer. This function evaluates --- vector elements to WHNF. -fromLazy :: PrimMonad m => MV.MVector (PrimState m) a -> m (MVector (PrimState m) a) -fromLazy mvec = stToPrim $ do - G.foldM' (\_ !_ -> return ()) () mvec - return $ MVector mvec - - --- Conversions - Arrays --- ----------------------------- - --- | /O(n)/ Make a copy of a mutable array to a new mutable --- vector. All elements of a vector are evaluated to WHNF --- --- @since 0.13.2.0 -fromMutableArray :: PrimMonad m => MutableArray (PrimState m) a -> m (MVector (PrimState m) a) -{-# INLINE fromMutableArray #-} -fromMutableArray marr = stToPrim $ do - mvec <- MVector <$> MV.fromMutableArray marr - foldM' (\_ !_ -> return ()) () mvec - return mvec - --- | /O(n)/ Make a copy of a mutable vector into a new mutable array. --- --- @since 0.13.2.0 -toMutableArray :: PrimMonad m => MVector (PrimState m) a -> m (MutableArray (PrimState m) a) -{-# INLINE toMutableArray #-} -toMutableArray (MVector v) = MV.toMutableArray v -- $setup --- >>> import Prelude (Integer,Num(..)) +-- >>> import Prelude (Integer,Num(..),($)) diff --git a/vector/src/Data/Vector/Strict/Mutable/Unsafe.hs b/vector/src/Data/Vector/Strict/Mutable/Unsafe.hs new file mode 100644 index 00000000..017df219 --- /dev/null +++ b/vector/src/Data/Vector/Strict/Mutable/Unsafe.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- | +module Data.Vector.Strict.Mutable.Unsafe + ( MVector(..) + , IOVector + , STVector + -- * Conversions + , toLazy + , fromLazy + , toMutableArray + , fromMutableArray + ) where + +import Data.Coerce +import qualified Data.Vector.Generic.Mutable as G +import qualified Data.Vector.Mutable as MV +import Data.Primitive.Array +import Control.Monad.Primitive + +import Prelude ( Monad(..), return, ($), (<$>) ) + +#include "vector.h" + +type role MVector nominal representational + +-- | Mutable boxed vectors keyed on the monad they live in ('IO' or @'ST' s@). +newtype MVector s a = MVector (MV.MVector s a) + +type IOVector = MVector RealWorld +type STVector s = MVector s + +instance G.MVector MVector a where + {-# INLINE basicLength #-} + basicLength = coerce (G.basicLength @MV.MVector @a) + {-# INLINE basicUnsafeSlice #-} + basicUnsafeSlice = coerce (G.basicUnsafeSlice @MV.MVector @a) + {-# INLINE basicOverlaps #-} + basicOverlaps = coerce (G.basicOverlaps @MV.MVector @a) + {-# INLINE basicUnsafeNew #-} + basicUnsafeNew = coerce (G.basicUnsafeNew @MV.MVector @a) + {-# INLINE basicInitialize #-} + -- initialization is unnecessary for boxed vectors + basicInitialize _ = return () + {-# INLINE basicUnsafeReplicate #-} + basicUnsafeReplicate n !x = coerce (G.basicUnsafeReplicate @MV.MVector @a) n x + {-# INLINE basicUnsafeRead #-} + basicUnsafeRead = coerce (G.basicUnsafeRead @MV.MVector @a) + {-# INLINE basicUnsafeWrite #-} + basicUnsafeWrite vec j !x = (coerce (G.basicUnsafeWrite @MV.MVector @a)) vec j x + + {-# INLINE basicUnsafeCopy #-} + basicUnsafeCopy = coerce (G.basicUnsafeCopy @MV.MVector @a) + + {-# INLINE basicUnsafeMove #-} + basicUnsafeMove = coerce (G.basicUnsafeMove @MV.MVector @a) + {-# INLINE basicClear #-} + basicClear = coerce (G.basicClear @MV.MVector @a) + + + +-- Conversions - Lazy vectors +-- ----------------------------- + +-- | /O(1)/ Convert strict mutable vector to lazy mutable +-- vector. Vectors will share mutable buffer +toLazy :: MVector s a -> MV.MVector s a +{-# INLINE toLazy #-} +toLazy (MVector vec) = vec + +-- | /O(n)/ Convert lazy mutable vector to strict mutable +-- vector. Vectors will share mutable buffer. This function evaluates +-- vector elements to WHNF. +fromLazy :: PrimMonad m => MV.MVector (PrimState m) a -> m (MVector (PrimState m) a) +fromLazy mvec = stToPrim $ do + G.foldM' (\_ !_ -> return ()) () mvec + return $ MVector mvec + + +-- Conversions - Arrays +-- ----------------------------- + +-- | /O(n)/ Make a copy of a mutable array to a new mutable +-- vector. All elements of a vector are evaluated to WHNF +-- +-- @since 0.13.2.0 +fromMutableArray :: PrimMonad m => MutableArray (PrimState m) a -> m (MVector (PrimState m) a) +{-# INLINE fromMutableArray #-} +fromMutableArray marr = stToPrim $ do + mvec <- MVector <$> MV.fromMutableArray marr + G.foldM' (\_ !_ -> return ()) () mvec + return mvec + +-- | /O(n)/ Make a copy of a mutable vector into a new mutable array. +-- +-- @since 0.13.2.0 +toMutableArray :: PrimMonad m => MVector (PrimState m) a -> m (MutableArray (PrimState m) a) +{-# INLINE toMutableArray #-} +toMutableArray (MVector v) = MV.toMutableArray v diff --git a/vector/src/Data/Vector/Strict/Unsafe.hs b/vector/src/Data/Vector/Strict/Unsafe.hs new file mode 100644 index 00000000..4377dcc3 --- /dev/null +++ b/vector/src/Data/Vector/Strict/Unsafe.hs @@ -0,0 +1,302 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +-- | +module Data.Vector.Strict.Unsafe + ( Vector(..) + -- * Vector conversions + , toLazy + , fromLazy + -- * Array conversions + , toArray + , fromArray + , toArraySlice + , unsafeFromArraySlice + ) where + + +import Data.Coerce +import Data.Vector.Strict.Mutable.Unsafe ( MVector(..) ) +import Data.Primitive.Array +import qualified Data.Vector.Generic as G +import Data.Vector.Generic ((!)) +import qualified Data.Vector as V + +import Control.DeepSeq ( NFData(rnf), NFData1(liftRnf)) + +import Control.Monad ( MonadPlus(..), ap ) +import Control.Monad.ST ( runST ) +import qualified Control.Monad.Fail as Fail +import Control.Monad.Fix ( MonadFix (mfix) ) +import Control.Monad.Zip +import Data.Function ( fix ) + +import Prelude + ( Eq(..), Ord(..), Monoid, Functor, Monad, Show, Int + , return, showsPrec, fmap, otherwise, flip, const + , (>>=), (+), (-), (.), ($), seq) + +import Data.Functor.Classes (Eq1 (..), Ord1 (..), Read1 (..), Show1 (..)) +import Data.Data ( Data(..) ) +import Text.Read ( Read(..), readListPrecDefault ) +import Data.Semigroup ( Semigroup(..) ) + +import qualified Control.Applicative as Applicative +import qualified Data.Foldable as Foldable +import qualified Data.Traversable as Traversable + +import qualified GHC.Exts as Exts (IsList(..)) + +-- | Strict boxed vectors, supporting efficient slicing. +newtype Vector a = Vector (V.Vector a) + deriving (Foldable.Foldable, Semigroup, Monoid) + +-- NOTE: [GND for strict vector] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- Strict boxed vectors (both mutable an immutable) are newtypes over +-- lazy ones. This makes it possible to use GND to derive instances. +-- However one must take care to preserve strictness since Vector +-- instance for lazy vectors would be used. +-- +-- In general it's OK to derive instances where vectors are passed as +-- parameters (e.g. Eq, Ord) and not OK to derive ones where new +-- vector is created (e.g. Read, Functor) + +liftRnfV :: (a -> ()) -> Vector a -> () +liftRnfV elemRnf = G.foldl' (\_ -> elemRnf) () + +instance NFData a => NFData (Vector a) where + rnf = liftRnfV rnf + {-# INLINEABLE rnf #-} + +-- | @since 0.13.2.0 +instance NFData1 Vector where + liftRnf = liftRnfV + {-# INLINEABLE liftRnf #-} + +instance Show a => Show (Vector a) where + showsPrec = G.showsPrec + +instance Read a => Read (Vector a) where + readPrec = G.readPrec + readListPrec = readListPrecDefault + +instance Show1 Vector where + liftShowsPrec = G.liftShowsPrec + +instance Read1 Vector where + liftReadsPrec = G.liftReadsPrec + +instance Exts.IsList (Vector a) where + type Item (Vector a) = a + fromList = G.fromList + fromListN = G.fromListN + toList = G.toList + +instance Data a => Data (Vector a) where + gfoldl = G.gfoldl + toConstr _ = G.mkVecConstr "Data.Vector.Strict.Vector" + gunfold = G.gunfold + dataTypeOf _ = G.mkVecType "Data.Vector.Strict.Vector" + dataCast1 = G.dataCast + +type instance G.Mutable Vector = MVector + +instance G.Vector Vector a where + {-# INLINE basicUnsafeFreeze #-} + basicUnsafeFreeze = coerce (G.basicUnsafeFreeze @V.Vector @a) + {-# INLINE basicUnsafeThaw #-} + basicUnsafeThaw = coerce (G.basicUnsafeThaw @V.Vector @a) + {-# INLINE basicLength #-} + basicLength = coerce (G.basicLength @V.Vector @a) + {-# INLINE basicUnsafeSlice #-} + basicUnsafeSlice = coerce (G.basicUnsafeSlice @V.Vector @a) + {-# INLINE basicUnsafeIndexM #-} + basicUnsafeIndexM = coerce (G.basicUnsafeIndexM @V.Vector @a) + {-# INLINE basicUnsafeCopy #-} + basicUnsafeCopy = coerce (G.basicUnsafeCopy @V.Vector @a) + {-# INLINE elemseq #-} + elemseq _ = seq + +-- See NOTE: [GND for strict vector] +-- +-- Deriving strategies are only available since 8.2. So we can't use +-- deriving newtype until we drop support for 8.0 +instance Eq a => Eq (Vector a) where + {-# INLINE (==) #-} + (==) = coerce ((==) @(V.Vector a)) + +-- See NOTE: [GND for strict vector] +instance Ord a => Ord (Vector a) where + {-# INLINE compare #-} + compare = coerce (compare @(V.Vector a)) + {-# INLINE (<) #-} + (<) = coerce ((<) @(V.Vector a)) + {-# INLINE (<=) #-} + (<=) = coerce ((<=) @(V.Vector a)) + {-# INLINE (>) #-} + (>) = coerce ((>) @(V.Vector a)) + {-# INLINE (>=) #-} + (>=) = coerce ((>=) @(V.Vector a)) + +instance Eq1 Vector where + {-# INLINE liftEq #-} + liftEq = G.eqBy + +instance Ord1 Vector where + {-# INLINE liftCompare #-} + liftCompare = G.cmpBy + +instance Functor Vector where + {-# INLINE fmap #-} + fmap = G.map + + {-# INLINE (<$) #-} + (<$) = G.map . const + +instance Monad Vector where + {-# INLINE return #-} + return = Applicative.pure + + {-# INLINE (>>=) #-} + (>>=) = flip G.concatMap + +-- | @since 0.13.2.0 +instance Fail.MonadFail Vector where + {-# INLINE fail #-} + fail _ = G.empty + +instance MonadPlus Vector where + {-# INLINE mzero #-} + mzero = G.empty + + {-# INLINE mplus #-} + mplus = (G.++) + +instance MonadZip Vector where + {-# INLINE mzip #-} + mzip = G.zip + + {-# INLINE mzipWith #-} + mzipWith = G.zipWith + + {-# INLINE munzip #-} + munzip = G.unzip + +-- | This instance has the same semantics as the one for lists. +-- +-- @since 0.13.2.0 +instance MonadFix Vector where + -- We take care to dispose of v0 as soon as possible (see headM docs). + -- + -- It's perfectly safe to use non-monadic indexing within generate + -- call since intermediate vector won't be created until result's + -- value is demanded. + {-# INLINE mfix #-} + mfix f + | G.null v0 = G.empty + -- We take first element of resulting vector from v0 and create + -- rest using generate. Note that cons should fuse with generate + | otherwise = runST $ do + h <- G.headM v0 + return $ G.cons h $ + G.generate (lv0 - 1) $ + \i -> fix (\a -> f a ! (i + 1)) + where + -- Used to calculate size of resulting vector + v0 = fix (f . G.head) + !lv0 = G.length v0 + +instance Applicative.Applicative Vector where + {-# INLINE pure #-} + pure = G.singleton + + {-# INLINE (<*>) #-} + (<*>) = ap + +instance Applicative.Alternative Vector where + {-# INLINE empty #-} + empty = G.empty + + {-# INLINE (<|>) #-} + (<|>) = (G.++) + +instance Traversable.Traversable Vector where + {-# INLINE traverse #-} + traverse = G.traverse + + {-# INLINE mapM #-} + mapM = G.mapM + + {-# INLINE sequence #-} + sequence = G.sequence + + +-- Conversions - Lazy vectors +-- ----------------------------- + +-- | /O(1)/ Convert strict array to lazy array +toLazy :: Vector a -> V.Vector a +toLazy (Vector v) = v + +-- | /O(n)/ Convert lazy array to strict array. This function reduces +-- each element of vector to WHNF. +fromLazy :: V.Vector a -> Vector a +fromLazy vec = liftRnf (`seq` ()) v `seq` v where v = Vector vec + + +-- Conversions - Arrays +-- ----------------------------- + +-- | /O(n)/ Convert an array to a vector and reduce each element to WHNF. +-- +-- @since 0.13.2.0 +fromArray :: Array a -> Vector a +{-# INLINE fromArray #-} +fromArray arr = liftRnf (`seq` ()) vec `seq` vec + where + vec = Vector $ V.fromArray arr + +-- | /O(n)/ Convert a vector to an array. +-- +-- @since 0.13.2.0 +toArray :: Vector a -> Array a +{-# INLINE toArray #-} +toArray (Vector v) = V.toArray v + +-- | /O(1)/ Extract the underlying `Array`, offset where vector starts and the +-- total number of elements in the vector. Below property always holds: +-- +-- > let (array, offset, len) = toArraySlice v +-- > v === unsafeFromArraySlice len offset array +-- +-- @since 0.13.2.0 +toArraySlice :: Vector a -> (Array a, Int, Int) +{-# INLINE toArraySlice #-} +toArraySlice (Vector v) = V.toArraySlice v + + +-- | /O(n)/ Convert an array slice to a vector and reduce each element to WHNF. +-- +-- This function is very unsafe, because constructing an invalid +-- vector can yield almost all other safe functions in this module +-- unsafe. These are equivalent: +-- +-- > unsafeFromArraySlice len offset === unsafeTake len . unsafeDrop offset . fromArray +-- +-- @since 0.13.2.0 +unsafeFromArraySlice :: + Array a -- ^ Immutable boxed array. + -> Int -- ^ Offset + -> Int -- ^ Length + -> Vector a +{-# INLINE unsafeFromArraySlice #-} +unsafeFromArraySlice arr offset len = liftRnf (`seq` ()) vec `seq` vec + where vec = Vector (V.unsafeFromArraySlice arr offset len) diff --git a/vector/src/Data/Vector/Unboxed.hs b/vector/src/Data/Vector/Unboxed.hs index 980c5335..f413c020 100644 --- a/vector/src/Data/Vector/Unboxed.hs +++ b/vector/src/Data/Vector/Unboxed.hs @@ -68,7 +68,10 @@ -- @ module Data.Vector.Unboxed ( -- * Unboxed vectors - Vector(V_UnboxAs, V_UnboxViaPrim, V_UnboxViaStorable,V_DoNotUnboxLazy,V_DoNotUnboxStrict,V_DoNotUnboxNormalForm), + Vector(V_UnboxAs, V_UnboxViaPrim, V_UnboxViaStorable,V_DoNotUnboxLazy,V_DoNotUnboxStrict,V_DoNotUnboxNormalForm, + V_Int,V_Int8,V_Int16,V_Int32,V_Int64,V_Word,V_Word8,V_Word16,V_Word32,V_Word64,V_Float,V_Double, + V_Char,V_Bool,V_Complex,V_Identity,V_Down,V_Dual,V_Sum,V_Product,V_Min,V_Max,V_First,V_Last, + V_WrappedMonoid,V_Arg,V_Any,V_All,V_Const,V_Alt,V_Compose), MVector(..), Unbox, -- * Accessors @@ -212,21 +215,22 @@ module Data.Vector.Unboxed ( freeze, thaw, copy, unsafeFreeze, unsafeThaw, unsafeCopy, -- ** Deriving via - UnboxViaPrim(..), - As(..), - IsoUnbox(..), - UnboxViaStorable(..), + U.UnboxViaPrim(..), + U.As(..), + U.IsoUnbox(..), + U.UnboxViaStorable(..), -- *** /Lazy/ boxing - DoNotUnboxLazy(..), + U.DoNotUnboxLazy(..), -- *** /Strict/ boxing - DoNotUnboxStrict(..), - DoNotUnboxNormalForm(..) + U.DoNotUnboxStrict(..), + U.DoNotUnboxNormalForm(..) ) where import Control.Applicative (Applicative) -import Data.Vector.Unboxed.Base +import Data.Vector.Unboxed.Unsafe (Vector,MVector,Unbox) +import qualified Data.Vector.Unboxed.Unsafe as U import qualified Data.Vector.Generic as G import qualified Data.Vector.Fusion.Bundle as Bundle import Data.Vector.Fusion.Util ( delayed_min ) @@ -2175,7 +2179,7 @@ copy = G.copy -- | /O(1)/ Zip 2 vectors. zip :: (Unbox a, Unbox b) => Vector a -> Vector b -> Vector (a, b) {-# INLINE_FUSED zip #-} -zip as bs = V_2 len (unsafeSlice 0 len as) (unsafeSlice 0 len bs) +zip as bs = U.V_2 len (unsafeSlice 0 len as) (unsafeSlice 0 len bs) where len = length as `delayed_min` length bs {-# RULES "stream/zip [Vector.Unboxed]" forall as bs . G.stream (zip as bs) = Bundle.zipWith (,) (G.stream as) @@ -2185,14 +2189,14 @@ zip as bs = V_2 len (unsafeSlice 0 len as) (unsafeSlice 0 len bs) unzip :: (Unbox a, Unbox b) => Vector (a, b) -> (Vector a, Vector b) {-# INLINE unzip #-} -unzip (V_2 _ as bs) = (as, bs) +unzip (U.V_2 _ as bs) = (as, bs) -- | /O(1)/ Zip 3 vectors. zip3 :: (Unbox a, Unbox b, Unbox c) => Vector a -> Vector b -> Vector c -> Vector (a, b, c) {-# INLINE_FUSED zip3 #-} -zip3 as bs cs = V_3 len (unsafeSlice 0 len as) +zip3 as bs cs = U.V_3 len (unsafeSlice 0 len as) (unsafeSlice 0 len bs) (unsafeSlice 0 len cs) where @@ -2207,7 +2211,7 @@ unzip3 :: (Unbox a, Unbox b, Unbox c) => Vector (a, b, c) -> (Vector a, Vector b, Vector c) {-# INLINE unzip3 #-} -unzip3 (V_3 _ as bs cs) = (as, bs, cs) +unzip3 (U.V_3 _ as bs cs) = (as, bs, cs) -- | /O(1)/ Zip 4 vectors. zip4 :: (Unbox a, Unbox b, Unbox c, Unbox d) => Vector a -> @@ -2215,7 +2219,7 @@ zip4 :: (Unbox a, Unbox b, Unbox c, Unbox d) => Vector a -> Vector c -> Vector d -> Vector (a, b, c, d) {-# INLINE_FUSED zip4 #-} -zip4 as bs cs ds = V_4 len (unsafeSlice 0 len as) +zip4 as bs cs ds = U.V_4 len (unsafeSlice 0 len as) (unsafeSlice 0 len bs) (unsafeSlice 0 len cs) (unsafeSlice 0 len ds) @@ -2239,7 +2243,7 @@ unzip4 :: (Unbox a, Vector c, Vector d) {-# INLINE unzip4 #-} -unzip4 (V_4 _ as bs cs ds) = (as, bs, cs, ds) +unzip4 (U.V_4 _ as bs cs ds) = (as, bs, cs, ds) -- | /O(1)/ Zip 5 vectors. zip5 :: (Unbox a, @@ -2252,7 +2256,7 @@ zip5 :: (Unbox a, Vector d -> Vector e -> Vector (a, b, c, d, e) {-# INLINE_FUSED zip5 #-} -zip5 as bs cs ds es = V_5 len (unsafeSlice 0 len as) +zip5 as bs cs ds es = U.V_5 len (unsafeSlice 0 len as) (unsafeSlice 0 len bs) (unsafeSlice 0 len cs) (unsafeSlice 0 len ds) @@ -2285,7 +2289,7 @@ unzip5 :: (Unbox a, Vector d, Vector e) {-# INLINE unzip5 #-} -unzip5 (V_5 _ as bs cs ds es) = (as, bs, cs, ds, es) +unzip5 (U.V_5 _ as bs cs ds es) = (as, bs, cs, ds, es) -- | /O(1)/ Zip 6 vectors. zip6 :: (Unbox a, @@ -2300,7 +2304,7 @@ zip6 :: (Unbox a, Vector e -> Vector f -> Vector (a, b, c, d, e, f) {-# INLINE_FUSED zip6 #-} -zip6 as bs cs ds es fs = V_6 len (unsafeSlice 0 len as) +zip6 as bs cs ds es fs = U.V_6 len (unsafeSlice 0 len as) (unsafeSlice 0 len bs) (unsafeSlice 0 len cs) (unsafeSlice 0 len ds) @@ -2339,7 +2343,7 @@ unzip6 :: (Unbox a, Vector e, Vector f) {-# INLINE unzip6 #-} -unzip6 (V_6 _ as bs cs ds es fs) = (as, bs, cs, ds, es, fs) +unzip6 (U.V_6 _ as bs cs ds es fs) = (as, bs, cs, ds, es, fs) -- $setup diff --git a/vector/src/Data/Vector/Unboxed/Mutable.hs b/vector/src/Data/Vector/Unboxed/Mutable.hs index 3667af1f..e41bc7e2 100644 --- a/vector/src/Data/Vector/Unboxed/Mutable.hs +++ b/vector/src/Data/Vector/Unboxed/Mutable.hs @@ -1,5 +1,5 @@ {-# LANGUAGE CPP #-} - +{-# LANGUAGE PatternSynonyms #-} -- | -- Module : Data.Vector.Unboxed.Mutable -- Copyright : (c) Roman Leshchinskiy 2009-2010 @@ -16,7 +16,11 @@ module Data.Vector.Unboxed.Mutable ( -- * Mutable vectors of primitive types - MVector(..), IOVector, STVector, Unbox, + MVector(MV_UnboxViaPrim, MV_UnboxViaStorable, MV_DoNotUnboxLazy, MV_DoNotUnboxStrict, MV_DoNotUnboxNormalForm, MV_UnboxAs, + MV_Int,MV_Int8,MV_Int16,MV_Int32,MV_Int64,MV_Word,MV_Word8,MV_Word16,MV_Word32,MV_Word64,MV_Float,MV_Double, + MV_Char,MV_Bool,MV_Complex,MV_Identity,MV_Down,MV_Dual,MV_Sum,MV_Product,MV_Min,MV_Max,MV_First,MV_Last, + MV_WrappedMonoid,MV_Arg,MV_Any,MV_All,MV_Const,MV_Alt,MV_Compose), + IOVector, STVector, Unbox, -- * Accessors @@ -65,10 +69,14 @@ module Data.Vector.Unboxed.Mutable ( -- ** Filling and copying set, copy, move, unsafeCopy, unsafeMove, -- * Re-exports - PrimMonad, PrimState, RealWorld + PrimMonad, PrimState, RealWorld, + -- * Deprecated + pattern MV_Unit, + pattern MV_2, pattern MV_3, pattern MV_4, pattern MV_5, pattern MV_6 ) where -import Data.Vector.Unboxed.Base +import Data.Vector.Unboxed.Unsafe (MVector, STVector,Unbox,IOVector) +import qualified Data.Vector.Unboxed.Unsafe as U import qualified Data.Vector.Generic.Mutable as G import Data.Vector.Fusion.Util ( delayed_min ) import Control.Monad.Primitive @@ -671,20 +679,20 @@ ifoldrM' = G.ifoldrM' zip :: (Unbox a, Unbox b) => MVector s a -> MVector s b -> MVector s (a, b) {-# INLINE_FUSED zip #-} -zip as bs = MV_2 len (unsafeSlice 0 len as) (unsafeSlice 0 len bs) +zip as bs = U.MV_2 len (unsafeSlice 0 len as) (unsafeSlice 0 len bs) where len = length as `delayed_min` length bs -- | /O(1)/ Unzip 2 vectors. unzip :: (Unbox a, Unbox b) => MVector s (a, b) -> (MVector s a, MVector s b) {-# INLINE unzip #-} -unzip (MV_2 _ as bs) = (as, bs) +unzip (U.MV_2 _ as bs) = (as, bs) -- | /O(1)/ Zip 3 vectors. zip3 :: (Unbox a, Unbox b, Unbox c) => MVector s a -> MVector s b -> MVector s c -> MVector s (a, b, c) {-# INLINE_FUSED zip3 #-} -zip3 as bs cs = MV_3 len (unsafeSlice 0 len as) +zip3 as bs cs = U.MV_3 len (unsafeSlice 0 len as) (unsafeSlice 0 len bs) (unsafeSlice 0 len cs) where @@ -696,7 +704,7 @@ unzip3 :: (Unbox a, MVector s b, MVector s c) {-# INLINE unzip3 #-} -unzip3 (MV_3 _ as bs cs) = (as, bs, cs) +unzip3 (U.MV_3 _ as bs cs) = (as, bs, cs) -- | /O(1)/ Zip 4 vectors. zip4 :: (Unbox a, Unbox b, Unbox c, Unbox d) => MVector s a -> @@ -704,7 +712,7 @@ zip4 :: (Unbox a, Unbox b, Unbox c, Unbox d) => MVector s a -> MVector s c -> MVector s d -> MVector s (a, b, c, d) {-# INLINE_FUSED zip4 #-} -zip4 as bs cs ds = MV_4 len (unsafeSlice 0 len as) +zip4 as bs cs ds = U.MV_4 len (unsafeSlice 0 len as) (unsafeSlice 0 len bs) (unsafeSlice 0 len cs) (unsafeSlice 0 len ds) @@ -722,7 +730,7 @@ unzip4 :: (Unbox a, MVector s c, MVector s d) {-# INLINE unzip4 #-} -unzip4 (MV_4 _ as bs cs ds) = (as, bs, cs, ds) +unzip4 (U.MV_4 _ as bs cs ds) = (as, bs, cs, ds) -- | /O(1)/ Zip 5 vectors. zip5 :: (Unbox a, @@ -735,7 +743,7 @@ zip5 :: (Unbox a, MVector s d -> MVector s e -> MVector s (a, b, c, d, e) {-# INLINE_FUSED zip5 #-} -zip5 as bs cs ds es = MV_5 len (unsafeSlice 0 len as) +zip5 as bs cs ds es = U.MV_5 len (unsafeSlice 0 len as) (unsafeSlice 0 len bs) (unsafeSlice 0 len cs) (unsafeSlice 0 len ds) @@ -757,7 +765,7 @@ unzip5 :: (Unbox a, MVector s d, MVector s e) {-# INLINE unzip5 #-} -unzip5 (MV_5 _ as bs cs ds es) = (as, bs, cs, ds, es) +unzip5 (U.MV_5 _ as bs cs ds es) = (as, bs, cs, ds, es) -- | /O(1)/ Zip 6 vectors. zip6 :: (Unbox a, @@ -772,7 +780,7 @@ zip6 :: (Unbox a, MVector s e -> MVector s f -> MVector s (a, b, c, d, e, f) {-# INLINE_FUSED zip6 #-} -zip6 as bs cs ds es fs = MV_6 len (unsafeSlice 0 len as) +zip6 as bs cs ds es fs = U.MV_6 len (unsafeSlice 0 len as) (unsafeSlice 0 len bs) (unsafeSlice 0 len cs) (unsafeSlice 0 len ds) @@ -798,7 +806,40 @@ unzip6 :: (Unbox a, MVector s e, MVector s f) {-# INLINE unzip6 #-} -unzip6 (MV_6 _ as bs cs ds es fs) = (as, bs, cs, ds, es, fs) +unzip6 (U.MV_6 _ as bs cs ds es fs) = (as, bs, cs, ds, es, fs) -- $setup -- >>> import Prelude (Char, (*), ($)) + + +pattern MV_Unit :: Int -> MVector s () +pattern MV_Unit i = U.MV_Unit i +{-# COMPLETE MV_Unit #-} +{-# DEPRECATED MV_Unit "Import constructor from Data.Vector.Unboxed.Unsafe" #-} + +pattern MV_2 :: Int -> MVector s a -> MVector s b -> MVector s (a,b) +pattern MV_2 i va vb = U.MV_2 i va vb +{-# COMPLETE MV_2 #-} +{-# DEPRECATED MV_2 "Import constructor from Data.Vector.Unboxed.Unsafe" #-} + +pattern MV_3 :: Int -> MVector s a -> MVector s b -> MVector s c -> MVector s (a,b,c) +pattern MV_3 i va vb vc = U.MV_3 i va vb vc +{-# COMPLETE MV_3 #-} +{-# DEPRECATED MV_3 "Import constructor from Data.Vector.Unboxed.Unsafe" #-} + +pattern MV_4 :: Int -> MVector s a -> MVector s b -> MVector s c -> MVector s d -> MVector s (a,b,c,d) +pattern MV_4 i va vb vc vd = U.MV_4 i va vb vc vd +{-# COMPLETE MV_4 #-} +{-# DEPRECATED MV_4 "Import constructor from Data.Vector.Unboxed.Unsafe" #-} + +pattern MV_5 :: Int -> MVector s a -> MVector s b -> MVector s c -> MVector s d + -> MVector s e -> MVector s (a,b,c,d,e) +pattern MV_5 i va vb vc vd ve = U.MV_5 i va vb vc vd ve +{-# COMPLETE MV_5 #-} +{-# DEPRECATED MV_5 "Import constructor from Data.Vector.Unboxed.Unsafe" #-} + +pattern MV_6 :: Int -> MVector s a -> MVector s b -> MVector s c -> MVector s d + -> MVector s e -> MVector s f -> MVector s (a,b,c,d,e,f) +pattern MV_6 i va vb vc vd ve vf = U.MV_6 i va vb vc vd ve vf +{-# COMPLETE MV_6 #-} +{-# DEPRECATED MV_6 "Import constructor from Data.Vector.Unboxed.Unsafe" #-} diff --git a/vector/src/Data/Vector/Unboxed/Base.hs b/vector/src/Data/Vector/Unboxed/Unsafe.hs similarity index 99% rename from vector/src/Data/Vector/Unboxed/Base.hs rename to vector/src/Data/Vector/Unboxed/Unsafe.hs index d962bc71..8de104b2 100644 --- a/vector/src/Data/Vector/Unboxed/Base.hs +++ b/vector/src/Data/Vector/Unboxed/Unsafe.hs @@ -11,7 +11,6 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE DerivingVia #-} -{-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Vector.Unboxed.Base -- Copyright : (c) Roman Leshchinskiy 2009-2010 @@ -26,7 +25,7 @@ -- -- Adaptive unboxed vectors: basic implementation. -module Data.Vector.Unboxed.Base ( +module Data.Vector.Unboxed.Unsafe ( MVector(..), IOVector, STVector, Vector(..), Unbox, UnboxViaPrim(..), UnboxViaStorable(..), As(..), IsoUnbox(..), DoNotUnboxLazy(..), DoNotUnboxNormalForm(..), DoNotUnboxStrict(..) diff --git a/vector/src/Data/Vector/Unsafe.hs b/vector/src/Data/Vector/Unsafe.hs new file mode 100644 index 00000000..e5af5cd3 --- /dev/null +++ b/vector/src/Data/Vector/Unsafe.hs @@ -0,0 +1,334 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +-- | +module Data.Vector.Unsafe + ( Vector(..) + -- * Array conversions + , toArray, fromArray + , toArraySlice, unsafeFromArraySlice + ) where + +import Data.Vector.Mutable.Unsafe ( MVector(..) ) +import Data.Primitive.Array +import qualified Data.Vector.Fusion.Bundle as Bundle +import qualified Data.Vector.Generic as G +import Data.Vector.Generic ((!)) + +import Control.DeepSeq ( NFData(rnf), NFData1(liftRnf) ) + +import Control.Monad ( MonadPlus(..), liftM, ap ) +import Control.Monad.ST ( runST ) +import qualified Control.Monad.Fail as Fail +import Control.Monad.Fix ( MonadFix (mfix) ) +import Control.Monad.Zip +import Data.Function ( fix ) + +import Prelude + ( Eq, Ord, Monoid, Functor, Monad, Show, Ordering(..), Int + , compare, mempty, mappend, mconcat, return, showsPrec, fmap, otherwise, flip, const + , (>>=), (+), (-), (<), (<=), (>), (>=), (==), (/=), (&&), (.), ($) ) + +import Data.Functor.Classes (Eq1 (..), Ord1 (..), Read1 (..), Show1 (..)) +import Data.Data ( Data(..) ) +import Text.Read ( Read(..), readListPrecDefault ) +import Data.Semigroup ( Semigroup(..) ) + +import qualified Control.Applicative as Applicative +import qualified Data.Foldable as Foldable +import qualified Data.Traversable as Traversable + +import qualified GHC.Exts as Exts (IsList(..)) + + +-- | Boxed vectors, supporting efficient slicing. +data Vector a = Vector {-# UNPACK #-} !Int + {-# UNPACK #-} !Int + {-# UNPACK #-} !(Array a) + +liftRnfV :: (a -> ()) -> Vector a -> () +liftRnfV elemRnf = G.foldl' (\_ -> elemRnf) () + +instance NFData a => NFData (Vector a) where + rnf = liftRnfV rnf + {-# INLINEABLE rnf #-} + +-- | @since 0.12.1.0 +instance NFData1 Vector where + liftRnf = liftRnfV + {-# INLINEABLE liftRnf #-} + +instance Show a => Show (Vector a) where + showsPrec = G.showsPrec + +instance Read a => Read (Vector a) where + readPrec = G.readPrec + readListPrec = readListPrecDefault + +instance Show1 Vector where + liftShowsPrec = G.liftShowsPrec + +instance Read1 Vector where + liftReadsPrec = G.liftReadsPrec + +instance Exts.IsList (Vector a) where + type Item (Vector a) = a + fromList = G.fromList + fromListN = G.fromListN + toList = G.toList + +instance Data a => Data (Vector a) where + gfoldl = G.gfoldl + toConstr _ = G.mkVecConstr "Data.Vector.Vector" + gunfold = G.gunfold + dataTypeOf _ = G.mkVecType "Data.Vector.Vector" + dataCast1 = G.dataCast + +type instance G.Mutable Vector = MVector + +instance G.Vector Vector a where + {-# INLINE basicUnsafeFreeze #-} + basicUnsafeFreeze (MVector i n marr) + = Vector i n `liftM` unsafeFreezeArray marr + + {-# INLINE basicUnsafeThaw #-} + basicUnsafeThaw (Vector i n arr) + = MVector i n `liftM` unsafeThawArray arr + + {-# INLINE basicLength #-} + basicLength (Vector _ n _) = n + + {-# INLINE basicUnsafeSlice #-} + basicUnsafeSlice j n (Vector i _ arr) = Vector (i+j) n arr + + {-# INLINE basicUnsafeIndexM #-} + basicUnsafeIndexM (Vector i _ arr) j = indexArrayM arr (i+j) + + {-# INLINE basicUnsafeCopy #-} + basicUnsafeCopy (MVector i n dst) (Vector j _ src) + = copyArray dst i src j n + +-- See http://trac.haskell.org/vector/ticket/12 +instance Eq a => Eq (Vector a) where + {-# INLINE (==) #-} + xs == ys = Bundle.eq (G.stream xs) (G.stream ys) + +-- See http://trac.haskell.org/vector/ticket/12 +instance Ord a => Ord (Vector a) where + {-# INLINE compare #-} + compare xs ys = Bundle.cmp (G.stream xs) (G.stream ys) + + {-# INLINE (<) #-} + xs < ys = Bundle.cmp (G.stream xs) (G.stream ys) == LT + + {-# INLINE (<=) #-} + xs <= ys = Bundle.cmp (G.stream xs) (G.stream ys) /= GT + + {-# INLINE (>) #-} + xs > ys = Bundle.cmp (G.stream xs) (G.stream ys) == GT + + {-# INLINE (>=) #-} + xs >= ys = Bundle.cmp (G.stream xs) (G.stream ys) /= LT + +instance Eq1 Vector where + {-# INLINE liftEq #-} + liftEq = G.eqBy + +instance Ord1 Vector where + {-# INLINE liftCompare #-} + liftCompare = G.cmpBy + +instance Semigroup (Vector a) where + {-# INLINE (<>) #-} + (<>) = (G.++) + + {-# INLINE sconcat #-} + sconcat = G.concatNE + +instance Monoid (Vector a) where + {-# INLINE mempty #-} + mempty = G.empty + + {-# INLINE mappend #-} + mappend = (<>) + + {-# INLINE mconcat #-} + mconcat = G.concat + +instance Functor Vector where + {-# INLINE fmap #-} + fmap = G.map + + {-# INLINE (<$) #-} + (<$) = G.map . const + +instance Monad Vector where + {-# INLINE return #-} + return = Applicative.pure + + {-# INLINE (>>=) #-} + (>>=) = flip G.concatMap + + +-- | @since 0.12.1.0 +instance Fail.MonadFail Vector where + {-# INLINE fail #-} + fail _ = G.empty + +instance MonadPlus Vector where + {-# INLINE mzero #-} + mzero = G.empty + + {-# INLINE mplus #-} + mplus = (G.++) + +instance MonadZip Vector where + {-# INLINE mzip #-} + mzip = G.zip + + {-# INLINE mzipWith #-} + mzipWith = G.zipWith + + {-# INLINE munzip #-} + munzip = G.unzip + +-- | This instance has the same semantics as the one for lists. +-- +-- @since 0.12.2.0 +instance MonadFix Vector where + -- We take care to dispose of v0 as soon as possible (see headM docs). + -- + -- It's perfectly safe to use non-monadic indexing within generate + -- call since intermediate vector won't be created until result's + -- value is demanded. + {-# INLINE mfix #-} + mfix f + | G.null v0 = G.empty + -- We take first element of resulting vector from v0 and create + -- rest using generate. Note that cons should fuse with generate + | otherwise = runST $ do + h <- G.headM v0 + return $ G.cons h $ + G.generate (lv0 - 1) $ + \i -> fix (\a -> f a ! (i + 1)) + where + -- Used to calculate size of resulting vector + v0 = fix (f . G.head) + !lv0 = G.length v0 + +instance Applicative.Applicative Vector where + {-# INLINE pure #-} + pure = G.singleton + + {-# INLINE (<*>) #-} + (<*>) = ap + +instance Applicative.Alternative Vector where + {-# INLINE empty #-} + empty = G.empty + + {-# INLINE (<|>) #-} + (<|>) = (G.++) + +instance Foldable.Foldable Vector where + {-# INLINE foldr #-} + foldr = G.foldr + + {-# INLINE foldl #-} + foldl = G.foldl + + {-# INLINE foldr1 #-} + foldr1 = G.foldr1 + + {-# INLINE foldl1 #-} + foldl1 = G.foldl1 + + {-# INLINE foldr' #-} + foldr' = G.foldr' + + {-# INLINE foldl' #-} + foldl' = G.foldl' + + {-# INLINE toList #-} + toList = G.toList + + {-# INLINE length #-} + length = G.length + + {-# INLINE null #-} + null = G.null + + {-# INLINE elem #-} + elem = G.elem + + {-# INLINE maximum #-} + maximum = G.maximum + + {-# INLINE minimum #-} + minimum = G.minimum + + {-# INLINE sum #-} + sum = G.sum + + {-# INLINE product #-} + product = G.product + +instance Traversable.Traversable Vector where + {-# INLINE traverse #-} + traverse = G.traverse + + {-# INLINE mapM #-} + mapM = G.mapM + + {-# INLINE sequence #-} + sequence = G.sequence + + +-- Conversions - Arrays +-- ----------------------------- + +-- | /O(1)/ Convert an array to a vector. +-- +-- @since 0.12.2.0 +fromArray :: Array a -> Vector a +{-# INLINE fromArray #-} +fromArray arr = Vector 0 (sizeofArray arr) arr + +-- | /O(n)/ Convert a vector to an array. +-- +-- @since 0.12.2.0 +toArray :: Vector a -> Array a +{-# INLINE toArray #-} +toArray (Vector offset len arr) + | offset == 0 && len == sizeofArray arr = arr + | otherwise = cloneArray arr offset len + +-- | /O(1)/ Extract the underlying `Array`, offset where vector starts and the +-- total number of elements in the vector. Below property always holds: +-- +-- > let (array, offset, len) = toArraySlice v +-- > v === unsafeFromArraySlice len offset array +-- +-- @since 0.13.0.0 +toArraySlice :: Vector a -> (Array a, Int, Int) +{-# INLINE toArraySlice #-} +toArraySlice (Vector offset len arr) = (arr, offset, len) + + +-- | /O(1)/ Convert an array slice to a vector. This function is very unsafe, +-- because constructing an invalid vector can yield almost all other safe +-- functions in this module unsafe. These are equivalent: +-- +-- > unsafeFromArraySlice len offset === unsafeTake len . unsafeDrop offset . fromArray +-- +-- @since 0.13.0.0 +unsafeFromArraySlice :: + Array a -- ^ Immutable boxed array. + -> Int -- ^ Offset + -> Int -- ^ Length + -> Vector a +{-# INLINE unsafeFromArraySlice #-} +unsafeFromArraySlice arr offset len = Vector offset len arr diff --git a/vector/tests/doctests.hs b/vector/tests/doctests.hs index 172f033d..c943beda 100644 --- a/vector/tests/doctests.hs +++ b/vector/tests/doctests.hs @@ -21,21 +21,29 @@ main = mapM_ run modGroups modGroups = [ [ "src/Data/Vector/Storable/Mutable.hs" , "src/Data/Vector/Storable.hs" + , "src/Data/Vector/Storable/Mutable/Unsafe.hs" + , "src/Data/Vector/Storable/Unsafe.hs" ] , [ "src/Data/Vector.hs" , "src/Data/Vector/Mutable.hs" + , "src/Data/Vector/Unsafe.hs" + , "src/Data/Vector/Mutable/Unsafe.hs" ] , [ "src/Data/Vector/Strict.hs" + , "src/Data/Vector/Strict/Unsafe.hs" , "src/Data/Vector/Strict/Mutable.hs" + , "src/Data/Vector/Strict/Mutable/Unsafe.hs" ] , [ "src/Data/Vector/Generic.hs" , "src/Data/Vector/Generic/Mutable.hs" ] , [ "src/Data/Vector/Primitive.hs" + , "src/Data/Vector/Primitive/Unsafe.hs" , "src/Data/Vector/Primitive/Mutable.hs" + , "src/Data/Vector/Primitive/Mutable/Unsafe.hs" ] , [ "src/Data/Vector/Unboxed.hs" , "src/Data/Vector/Unboxed/Mutable.hs" - , "src/Data/Vector/Unboxed/Base.hs" + , "src/Data/Vector/Unboxed/Unsafe.hs" ] ] diff --git a/vector/vector.cabal b/vector/vector.cabal index e868e95f..7c697409 100644 --- a/vector/vector.cabal +++ b/vector/vector.cabal @@ -128,22 +128,30 @@ Library Data.Vector.Generic.New Data.Vector.Generic - Data.Vector.Primitive.Mutable Data.Vector.Primitive + Data.Vector.Primitive.Mutable + Data.Vector.Primitive.Mutable.Unsafe + Data.Vector.Primitive.Unsafe + Data.Vector.Storable Data.Vector.Storable.Internal Data.Vector.Storable.Mutable - Data.Vector.Storable + Data.Vector.Storable.Mutable.Unsafe + Data.Vector.Storable.Unsafe - Data.Vector.Unboxed.Base + Data.Vector.Unboxed.Unsafe Data.Vector.Unboxed.Mutable Data.Vector.Unboxed Data.Vector.Strict.Mutable Data.Vector.Strict + Data.Vector.Strict.Mutable.Unsafe + Data.Vector.Strict.Unsafe Data.Vector.Mutable Data.Vector + Data.Vector.Mutable.Unsafe + Data.Vector.Unsafe Hs-Source-Dirs: src