From 0925bc24ba5d8e62375ccd69e447c9af7419274a Mon Sep 17 00:00:00 2001 From: Alexey Khudyakov Date: Wed, 3 Sep 2025 15:22:50 +0300 Subject: [PATCH 1/8] Primitive: add Unsafe modules They contain publicly accessible definitions of vector data types and unsafe operations on structure. --- vector/src/Data/Vector/Primitive.hs | 155 +--------------- vector/src/Data/Vector/Primitive/Mutable.hs | 110 +----------- .../Data/Vector/Primitive/Mutable/Unsafe.hs | 129 +++++++++++++ vector/src/Data/Vector/Primitive/Unsafe.hs | 169 ++++++++++++++++++ vector/tests/doctests.hs | 2 + vector/vector.cabal | 4 +- 6 files changed, 315 insertions(+), 254 deletions(-) create mode 100644 vector/src/Data/Vector/Primitive/Mutable/Unsafe.hs create mode 100644 vector/src/Data/Vector/Primitive/Unsafe.hs diff --git a/vector/src/Data/Vector/Primitive.hs b/vector/src/Data/Vector/Primitive.hs index dade073f..0be32760 100644 --- a/vector/src/Data/Vector/Primitive.hs +++ b/vector/src/Data/Vector/Primitive.hs @@ -163,144 +163,16 @@ 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.Primitive.ByteArray -import Data.Primitive ( Prim, sizeOf ) +import Data.Vector.Primitive.Unsafe (Vector(..),unsafeCoerceVector,unsafeCast) +import Data.Vector.Primitive.Mutable.Unsafe (MVector(..)) +import Data.Primitive ( Prim ) -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 + , (==)) -- Length @@ -1968,21 +1840,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 +1903,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..a9657951 100644 --- a/vector/src/Data/Vector/Primitive/Mutable.hs +++ b/vector/src/Data/Vector/Primitive/Mutable.hs @@ -70,100 +70,15 @@ module Data.Vector.Primitive.Mutable ( ) where import qualified Data.Vector.Generic.Mutable as G -import Data.Primitive.ByteArray -import Data.Primitive ( Prim, sizeOf ) -import Data.Vector.Internal.Check -import Data.Word ( Word8 ) +import Data.Primitive ( Prim ) +import Data.Vector.Primitive.Mutable.Unsafe + (MVector,IOVector,STVector,unsafeCoerceMVector,unsafeCast) 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 - -- Length information -- ------------------ @@ -745,18 +660,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/tests/doctests.hs b/vector/tests/doctests.hs index 172f033d..6fa02698 100644 --- a/vector/tests/doctests.hs +++ b/vector/tests/doctests.hs @@ -32,7 +32,9 @@ main = mapM_ run modGroups , "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" diff --git a/vector/vector.cabal b/vector/vector.cabal index e868e95f..2d0713a8 100644 --- a/vector/vector.cabal +++ b/vector/vector.cabal @@ -128,8 +128,10 @@ 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.Internal Data.Vector.Storable.Mutable From 74ecbcecffef1677462bebd603de4eeffe2da2fc Mon Sep 17 00:00:00 2001 From: Alexey Khudyakov Date: Wed, 10 Sep 2025 21:27:12 +0300 Subject: [PATCH 2/8] Storable: add Unsafe modules --- vector/src/Data/Vector/Storable.hs | 192 +----------- vector/src/Data/Vector/Storable/Mutable.hs | 257 +--------------- .../Data/Vector/Storable/Mutable/Unsafe.hs | 282 ++++++++++++++++++ vector/src/Data/Vector/Storable/Unsafe.hs | 213 +++++++++++++ vector/tests/doctests.hs | 2 + vector/vector.cabal | 4 +- 6 files changed, 511 insertions(+), 439 deletions(-) create mode 100644 vector/src/Data/Vector/Storable/Mutable/Unsafe.hs create mode 100644 vector/src/Data/Vector/Storable/Unsafe.hs diff --git a/vector/src/Data/Vector/Storable.hs b/vector/src/Data/Vector/Storable.hs index fb32941a..bb7a173e 100644 --- a/vector/src/Data/Vector/Storable.hs +++ b/vector/src/Data/Vector/Storable.hs @@ -170,147 +170,19 @@ 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.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 +1965,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..f586f958 100644 --- a/vector/src/Data/Vector/Storable/Mutable.hs +++ b/vector/src/Data/Vector/Storable/Mutable.hs @@ -76,191 +76,18 @@ 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 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 - ( Ord, Bool, Maybe, IO, Ordering(..) - , return, otherwise, error, undefined, max, div, quot, maxBound, show - , (-), (*), (<), (>), (>=), (==), (&&), (||), (.), ($), (++) ) - -import Data.Coerce -import Unsafe.Coerce +import Prelude (Int, Ord, Bool, 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. --- --- 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 +673,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..c69d3d0d --- /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 ( 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/tests/doctests.hs b/vector/tests/doctests.hs index 6fa02698..7cf015af 100644 --- a/vector/tests/doctests.hs +++ b/vector/tests/doctests.hs @@ -21,6 +21,8 @@ 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" diff --git a/vector/vector.cabal b/vector/vector.cabal index 2d0713a8..0446a14c 100644 --- a/vector/vector.cabal +++ b/vector/vector.cabal @@ -133,9 +133,11 @@ Library 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.Mutable From 0f08f5cde98e8a17b6f4da3b005b49e087c921de Mon Sep 17 00:00:00 2001 From: Alexey Khudyakov Date: Sun, 14 Sep 2025 19:59:01 +0300 Subject: [PATCH 3/8] Lazy boxed: add Unsafe modules --- vector/src/Data/Vector.hs | 313 +-------------------- vector/src/Data/Vector/Mutable.hs | 161 +---------- vector/src/Data/Vector/Mutable/Unsafe.hs | 181 ++++++++++++ vector/src/Data/Vector/Unsafe.hs | 334 +++++++++++++++++++++++ vector/tests/doctests.hs | 2 + vector/vector.cabal | 2 + 6 files changed, 529 insertions(+), 464 deletions(-) create mode 100644 vector/src/Data/Vector/Mutable/Unsafe.hs create mode 100644 vector/src/Data/Vector/Unsafe.hs 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..11409d30 100644 --- a/vector/src/Data/Vector/Mutable.hs +++ b/vector/src/Data/Vector/Mutable.hs @@ -71,149 +71,15 @@ 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.Primitive.Array +import Data.Vector.Mutable.Unsafe 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." + -- Length information -- ------------------ @@ -787,24 +653,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/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 7cf015af..575818f1 100644 --- a/vector/tests/doctests.hs +++ b/vector/tests/doctests.hs @@ -26,6 +26,8 @@ main = mapM_ run modGroups ] , [ "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/Mutable.hs" diff --git a/vector/vector.cabal b/vector/vector.cabal index 0446a14c..d1e563c4 100644 --- a/vector/vector.cabal +++ b/vector/vector.cabal @@ -148,6 +148,8 @@ Library Data.Vector.Mutable Data.Vector + Data.Vector.Mutable.Unsafe + Data.Vector.Unsafe Hs-Source-Dirs: src From da90e336386f99925e4cce87a01ad0541a0cd8b7 Mon Sep 17 00:00:00 2001 From: Alexey Khudyakov Date: Sun, 14 Sep 2025 20:51:24 +0300 Subject: [PATCH 4/8] Strict boxed: Add Unsafe modules --- vector/src/Data/Vector/Strict.hs | 280 +--------------- vector/src/Data/Vector/Strict/Mutable.hs | 82 +---- .../src/Data/Vector/Strict/Mutable/Unsafe.hs | 105 ++++++ vector/src/Data/Vector/Strict/Unsafe.hs | 302 ++++++++++++++++++ vector/tests/doctests.hs | 2 + vector/vector.cabal | 2 + 6 files changed, 422 insertions(+), 351 deletions(-) create mode 100644 vector/src/Data/Vector/Strict/Mutable/Unsafe.hs create mode 100644 vector/src/Data/Vector/Strict/Unsafe.hs 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..803866d8 100644 --- a/vector/src/Data/Vector/Strict/Mutable.hs +++ b/vector/src/Data/Vector/Strict/Mutable.hs @@ -76,52 +76,14 @@ 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 Data.Vector.Strict.Mutable.Unsafe 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) -- Length information @@ -769,44 +731,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..057d09c1 --- /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 ( 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/tests/doctests.hs b/vector/tests/doctests.hs index 575818f1..97a44154 100644 --- a/vector/tests/doctests.hs +++ b/vector/tests/doctests.hs @@ -30,7 +30,9 @@ main = mapM_ run modGroups , "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" diff --git a/vector/vector.cabal b/vector/vector.cabal index d1e563c4..4badc54e 100644 --- a/vector/vector.cabal +++ b/vector/vector.cabal @@ -145,6 +145,8 @@ Library Data.Vector.Strict.Mutable Data.Vector.Strict + Data.Vector.Strict.Mutable.Unsafe + Data.Vector.Strict.Unsafe Data.Vector.Mutable Data.Vector From 512501579378024e653ecf70bca3445e8bff35f1 Mon Sep 17 00:00:00 2001 From: Alexey Khudyakov Date: Wed, 3 Sep 2025 15:32:00 +0300 Subject: [PATCH 5/8] Replace exported constructors with deprecated pattern --- vector/src/Data/Vector/Mutable.hs | 12 ++++++++++-- vector/src/Data/Vector/Primitive.hs | 14 +++++++++++--- vector/src/Data/Vector/Primitive/Mutable.hs | 12 +++++++++++- vector/src/Data/Vector/Storable.hs | 5 +++-- vector/src/Data/Vector/Storable/Mutable.hs | 16 +++++++++++++--- vector/src/Data/Vector/Storable/Unsafe.hs | 2 +- vector/src/Data/Vector/Strict/Mutable.hs | 11 ++++++++++- vector/src/Data/Vector/Strict/Unsafe.hs | 2 +- 8 files changed, 60 insertions(+), 14 deletions(-) diff --git a/vector/src/Data/Vector/Mutable.hs b/vector/src/Data/Vector/Mutable.hs index 11409d30..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 @@ -72,13 +74,19 @@ module Data.Vector.Mutable ( ) where import qualified Data.Vector.Generic.Mutable as G -import Data.Vector.Mutable.Unsafe +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, Bool, Ordering(..), Int, Maybe ) #include "vector.h" +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 diff --git a/vector/src/Data/Vector/Primitive.hs b/vector/src/Data/Vector/Primitive.hs index 0be32760..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,9 +164,12 @@ module Data.Vector.Primitive ( import Control.Applicative (Applicative) import qualified Data.Vector.Generic as G -import Data.Vector.Primitive.Unsafe (Vector(..),unsafeCoerceVector,unsafeCast) -import Data.Vector.Primitive.Mutable.Unsafe (MVector(..)) +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 Control.Monad.ST ( ST ) import Control.Monad.Primitive @@ -174,6 +178,10 @@ import Prelude ( 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 -- ------ diff --git a/vector/src/Data/Vector/Primitive/Mutable.hs b/vector/src/Data/Vector/Primitive/Mutable.hs index a9657951..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 @@ -71,14 +73,22 @@ module Data.Vector.Primitive.Mutable ( import qualified Data.Vector.Generic.Mutable as G import Data.Primitive ( Prim ) +import Data.Primitive.ByteArray 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 Prelude ( Ord, Bool, Int, Maybe, Ordering(..) ) #include "vector.h" + +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 -- ------------------ diff --git a/vector/src/Data/Vector/Storable.hs b/vector/src/Data/Vector/Storable.hs index bb7a173e..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,7 +170,7 @@ 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.Mutable ( MVector, pattern MVector ) import Data.Vector.Storable.Unsafe import Control.Monad.ST ( ST ) diff --git a/vector/src/Data/Vector/Storable/Mutable.hs b/vector/src/Data/Vector/Storable/Mutable.hs index f586f958..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 @@ -77,17 +79,25 @@ module Data.Vector.Storable.Mutable( ) where import qualified Data.Vector.Generic.Mutable as G -import Data.Vector.Storable.Mutable.Unsafe - +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 Control.Monad.Primitive +import Foreign.ForeignPtr (ForeignPtr) import Prelude (Int, Ord, Bool, Maybe, Ordering(..) ) #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" #-} + -- Length information -- ------------------ diff --git a/vector/src/Data/Vector/Storable/Unsafe.hs b/vector/src/Data/Vector/Storable/Unsafe.hs index c69d3d0d..f8224bfe 100644 --- a/vector/src/Data/Vector/Storable/Unsafe.hs +++ b/vector/src/Data/Vector/Storable/Unsafe.hs @@ -16,7 +16,7 @@ module Data.Vector.Storable.Unsafe ) where import qualified Data.Vector.Generic as G -import Data.Vector.Storable.Mutable ( MVector(..) ) +import Data.Vector.Storable.Mutable.Unsafe ( MVector(..) ) import Data.Vector.Storable.Internal import qualified Data.Vector.Fusion.Bundle as Bundle diff --git a/vector/src/Data/Vector/Strict/Mutable.hs b/vector/src/Data/Vector/Strict/Mutable.hs index 803866d8..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 @@ -77,13 +79,20 @@ module Data.Vector.Strict.Mutable ( ) where import qualified Data.Vector.Generic.Mutable as G +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, Bool, Int, Maybe, Ordering(..)) #include "vector.h" +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 diff --git a/vector/src/Data/Vector/Strict/Unsafe.hs b/vector/src/Data/Vector/Strict/Unsafe.hs index 057d09c1..4377dcc3 100644 --- a/vector/src/Data/Vector/Strict/Unsafe.hs +++ b/vector/src/Data/Vector/Strict/Unsafe.hs @@ -22,7 +22,7 @@ module Data.Vector.Strict.Unsafe import Data.Coerce -import Data.Vector.Strict.Mutable ( MVector(..) ) +import Data.Vector.Strict.Mutable.Unsafe ( MVector(..) ) import Data.Primitive.Array import qualified Data.Vector.Generic as G import Data.Vector.Generic ((!)) From f5903b332c6cf331a8bbf787344e0c8f697183af Mon Sep 17 00:00:00 2001 From: Alexey Khudyakov Date: Thu, 2 Oct 2025 16:18:22 +0300 Subject: [PATCH 6/8] Rename module Unboxed.Base -> Unboxed.Unsafe --- vector/src/Data/Vector/Unboxed.hs | 2 +- vector/src/Data/Vector/Unboxed/Mutable.hs | 2 +- vector/src/Data/Vector/Unboxed/{Base.hs => Unsafe.hs} | 3 +-- vector/tests/doctests.hs | 2 +- vector/vector.cabal | 2 +- 5 files changed, 5 insertions(+), 6 deletions(-) rename vector/src/Data/Vector/Unboxed/{Base.hs => Unsafe.hs} (99%) diff --git a/vector/src/Data/Vector/Unboxed.hs b/vector/src/Data/Vector/Unboxed.hs index 980c5335..09ec5ef7 100644 --- a/vector/src/Data/Vector/Unboxed.hs +++ b/vector/src/Data/Vector/Unboxed.hs @@ -226,7 +226,7 @@ module Data.Vector.Unboxed ( ) where import Control.Applicative (Applicative) -import Data.Vector.Unboxed.Base +import Data.Vector.Unboxed.Unsafe import qualified Data.Vector.Generic as G import qualified Data.Vector.Fusion.Bundle as Bundle import Data.Vector.Fusion.Util ( delayed_min ) diff --git a/vector/src/Data/Vector/Unboxed/Mutable.hs b/vector/src/Data/Vector/Unboxed/Mutable.hs index 3667af1f..02ebd735 100644 --- a/vector/src/Data/Vector/Unboxed/Mutable.hs +++ b/vector/src/Data/Vector/Unboxed/Mutable.hs @@ -68,7 +68,7 @@ module Data.Vector.Unboxed.Mutable ( PrimMonad, PrimState, RealWorld ) where -import Data.Vector.Unboxed.Base +import Data.Vector.Unboxed.Unsafe import qualified Data.Vector.Generic.Mutable as G import Data.Vector.Fusion.Util ( delayed_min ) import Control.Monad.Primitive 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/tests/doctests.hs b/vector/tests/doctests.hs index 97a44154..c943beda 100644 --- a/vector/tests/doctests.hs +++ b/vector/tests/doctests.hs @@ -44,6 +44,6 @@ main = mapM_ run modGroups ] , [ "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 4badc54e..7c697409 100644 --- a/vector/vector.cabal +++ b/vector/vector.cabal @@ -139,7 +139,7 @@ Library Data.Vector.Storable.Mutable.Unsafe Data.Vector.Storable.Unsafe - Data.Vector.Unboxed.Base + Data.Vector.Unboxed.Unsafe Data.Vector.Unboxed.Mutable Data.Vector.Unboxed From 94750e30e892976c354c78ecba10a39e13542828 Mon Sep 17 00:00:00 2001 From: Alexey Khudyakov Date: Thu, 2 Oct 2025 16:31:00 +0300 Subject: [PATCH 7/8] Prepare reexports for creation of patterns for unsafe unboxed vectors --- vector/src/Data/Vector/Unboxed.hs | 37 ++++++++++++----------- vector/src/Data/Vector/Unboxed/Mutable.hs | 23 +++++++------- 2 files changed, 31 insertions(+), 29 deletions(-) diff --git a/vector/src/Data/Vector/Unboxed.hs b/vector/src/Data/Vector/Unboxed.hs index 09ec5ef7..26945a7f 100644 --- a/vector/src/Data/Vector/Unboxed.hs +++ b/vector/src/Data/Vector/Unboxed.hs @@ -212,21 +212,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.Unsafe +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 +2176,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 +2186,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 +2208,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 +2216,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 +2240,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 +2253,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 +2286,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 +2301,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 +2340,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 02ebd735..fa28dbe4 100644 --- a/vector/src/Data/Vector/Unboxed/Mutable.hs +++ b/vector/src/Data/Vector/Unboxed/Mutable.hs @@ -68,7 +68,8 @@ module Data.Vector.Unboxed.Mutable ( PrimMonad, PrimState, RealWorld ) where -import Data.Vector.Unboxed.Unsafe +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 +672,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 +697,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 +705,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 +723,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 +736,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 +758,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 +773,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 +799,7 @@ 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, (*), ($)) From a44dfb12f9ff263c045e94801216624ae93f83b3 Mon Sep 17 00:00:00 2001 From: Alexey Khudyakov Date: Fri, 3 Oct 2025 13:26:41 +0300 Subject: [PATCH 8/8] Rework export lists for unboxed vectors We have 3 sorts of data instances: 1. Constructors that we must exports. Data instances which are used in deriving via (UnboxViaPrim etc.). When constructors aren't visible deriving won't work. They were exported before. 2. Constructors which are safe to use. Newtype vectors over underlying representation. Now they're exported from both immutable and mutable 3. Dangerous and unsafe ones: tuple and unit instances. They're exported from Unsafe module. Mutable module reexports deprecated pattern synonym. --- vector/src/Data/Vector/Unboxed.hs | 5 ++- vector/src/Data/Vector/Unboxed/Mutable.hs | 46 +++++++++++++++++++++-- 2 files changed, 47 insertions(+), 4 deletions(-) diff --git a/vector/src/Data/Vector/Unboxed.hs b/vector/src/Data/Vector/Unboxed.hs index 26945a7f..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 diff --git a/vector/src/Data/Vector/Unboxed/Mutable.hs b/vector/src/Data/Vector/Unboxed/Mutable.hs index fa28dbe4..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,7 +69,10 @@ 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.Unsafe (MVector, STVector,Unbox,IOVector) @@ -803,3 +810,36 @@ 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" #-}