Skip to content

Commit 0925bc2

Browse files
ShimuuarShimuuar
committed
Primitive: add Unsafe modules
They contain publicly accessible definitions of vector data types and unsafe operations on structure.
1 parent 8430e8e commit 0925bc2

File tree

6 files changed

+315
-254
lines changed

6 files changed

+315
-254
lines changed

‎vector/src/Data/Vector/Primitive.hs‎

Lines changed: 6 additions & 149 deletions
Original file line numberDiff line numberDiff line change
@@ -163,144 +163,16 @@ module Data.Vector.Primitive (
163163

164164
import Control.Applicative (Applicative)
165165
import qualified Data.Vector.Generic as G
166-
import Data.Vector.Primitive.Mutable ( MVector(..) )
167-
import Data.Vector.Internal.Check
168-
import qualified Data.Vector.Fusion.Bundle as Bundle
169-
import Data.Primitive.ByteArray
170-
import Data.Primitive ( Prim, sizeOf )
166+
import Data.Vector.Primitive.Unsafe (Vector(..),unsafeCoerceVector,unsafeCast)
167+
import Data.Vector.Primitive.Mutable.Unsafe (MVector(..))
168+
import Data.Primitive ( Prim )
171169

172-
import Control.DeepSeq ( NFData(rnf), NFData1(liftRnf))
173-
174-
import Control.Monad ( liftM )
175170
import Control.Monad.ST ( ST )
176171
import Control.Monad.Primitive
177172

178173
import Prelude
179-
( Eq, Ord, Num, Enum, Monoid, Traversable, Monad, Read, Show, Bool, Ordering(..), Int, Maybe, Either
180-
, compare, mempty, mappend, mconcat, showsPrec, return, otherwise, seq, error, undefined
181-
, (+), (*), (<), (<=), (>), (>=), (==), (/=), ($!) )
182-
183-
import Data.Data ( Data(..) )
184-
import Text.Read ( Read(..), readListPrecDefault )
185-
import Data.Semigroup ( Semigroup(..) )
186-
187-
import Data.Coerce
188-
import Unsafe.Coerce
189-
import qualified GHC.Exts as Exts
190-
191-
type role Vector nominal
192-
193-
-- | /O(1)/ Unsafely coerce an immutable vector from one element type to another,
194-
-- representationally equal type. The operation just changes the type of the
195-
-- underlying pointer and does not modify the elements.
196-
--
197-
-- This is marginally safer than 'unsafeCast', since this function imposes an
198-
-- extra 'Coercible' constraint. The constraint guarantees that the element types
199-
-- are representationally equal. It however cannot guarantee
200-
-- that their respective 'Prim' instances are compatible.
201-
unsafeCoerceVector :: Coercible a b => Vector a -> Vector b
202-
unsafeCoerceVector = unsafeCoerce
203-
204-
-- | Unboxed vectors of primitive types.
205-
data Vector a = Vector {-# UNPACK #-} !Int -- ^ offset
206-
{-# UNPACK #-} !Int -- ^ length
207-
{-# UNPACK #-} !ByteArray -- ^ underlying byte array
208-
209-
instance NFData (Vector a) where
210-
rnf (Vector _ _ _) = ()
211-
212-
-- | @since 0.12.1.0
213-
instance NFData1 Vector where
214-
liftRnf _ (Vector _ _ _) = ()
215-
216-
instance (Show a, Prim a) => Show (Vector a) where
217-
showsPrec = G.showsPrec
218-
219-
instance (Read a, Prim a) => Read (Vector a) where
220-
readPrec = G.readPrec
221-
readListPrec = readListPrecDefault
222-
223-
instance (Data a, Prim a) => Data (Vector a) where
224-
gfoldl = G.gfoldl
225-
toConstr _ = G.mkVecConstr "Data.Vector.Primitive.Vector"
226-
gunfold = G.gunfold
227-
dataTypeOf _ = G.mkVecType "Data.Vector.Primitive.Vector"
228-
dataCast1 = G.dataCast
229-
230-
231-
type instance G.Mutable Vector = MVector
232-
233-
instance Prim a => G.Vector Vector a where
234-
{-# INLINE basicUnsafeFreeze #-}
235-
basicUnsafeFreeze (MVector i n marr)
236-
= Vector i n `liftM` unsafeFreezeByteArray marr
237-
238-
{-# INLINE basicUnsafeThaw #-}
239-
basicUnsafeThaw (Vector i n arr)
240-
= MVector i n `liftM` unsafeThawByteArray arr
241-
242-
{-# INLINE basicLength #-}
243-
basicLength (Vector _ n _) = n
244-
245-
{-# INLINE basicUnsafeSlice #-}
246-
basicUnsafeSlice j n (Vector i _ arr) = Vector (i+j) n arr
247-
248-
{-# INLINE basicUnsafeIndexM #-}
249-
basicUnsafeIndexM (Vector i _ arr) j = return $! indexByteArray arr (i+j)
250-
251-
{-# INLINE basicUnsafeCopy #-}
252-
basicUnsafeCopy (MVector i n dst) (Vector j _ src)
253-
= copyByteArray dst (i*sz) src (j*sz) (n*sz)
254-
where
255-
sz = sizeOf (undefined :: a)
256-
257-
{-# INLINE elemseq #-}
258-
elemseq _ = seq
259-
260-
-- See http://trac.haskell.org/vector/ticket/12
261-
instance (Prim a, Eq a) => Eq (Vector a) where
262-
{-# INLINE (==) #-}
263-
xs == ys = Bundle.eq (G.stream xs) (G.stream ys)
264-
265-
-- See http://trac.haskell.org/vector/ticket/12
266-
instance (Prim a, Ord a) => Ord (Vector a) where
267-
{-# INLINE compare #-}
268-
compare xs ys = Bundle.cmp (G.stream xs) (G.stream ys)
269-
270-
{-# INLINE (<) #-}
271-
xs < ys = Bundle.cmp (G.stream xs) (G.stream ys) == LT
272-
273-
{-# INLINE (<=) #-}
274-
xs <= ys = Bundle.cmp (G.stream xs) (G.stream ys) /= GT
275-
276-
{-# INLINE (>) #-}
277-
xs > ys = Bundle.cmp (G.stream xs) (G.stream ys) == GT
278-
279-
{-# INLINE (>=) #-}
280-
xs >= ys = Bundle.cmp (G.stream xs) (G.stream ys) /= LT
281-
282-
instance Prim a => Semigroup (Vector a) where
283-
{-# INLINE (<>) #-}
284-
(<>) = (++)
285-
286-
{-# INLINE sconcat #-}
287-
sconcat = G.concatNE
288-
289-
instance Prim a => Monoid (Vector a) where
290-
{-# INLINE mempty #-}
291-
mempty = empty
292-
293-
{-# INLINE mappend #-}
294-
mappend = (<>)
295-
296-
{-# INLINE mconcat #-}
297-
mconcat = concat
298-
299-
instance Prim a => Exts.IsList (Vector a) where
300-
type Item (Vector a) = a
301-
fromList = fromList
302-
fromListN = fromListN
303-
toList = toList
174+
( Eq, Ord, Num, Enum, Monoid, Traversable, Monad, Bool, Ordering(..), Int, Maybe, Either
175+
, (==))
304176

305177

306178
-- Length
@@ -1968,21 +1840,6 @@ iforA_ :: (Applicative f, Prim a)
19681840
iforA_ = G.iforA_
19691841

19701842

1971-
-- Conversions - Unsafe casts
1972-
-- --------------------------
1973-
1974-
-- | /O(1)/ Unsafely cast a vector from one element type to another.
1975-
-- This operation just changes the type of the vector and does not
1976-
-- modify the elements.
1977-
--
1978-
-- This function will throw an error if elements are of mismatching sizes.
1979-
--
1980-
-- | @since 0.13.0.0
1981-
unsafeCast :: forall a b. (HasCallStack, Prim a, Prim b) => Vector a -> Vector b
1982-
{-# INLINE unsafeCast #-}
1983-
unsafeCast (Vector o n ba)
1984-
| sizeOf (undefined :: a) == sizeOf (undefined :: b) = Vector o n ba
1985-
| otherwise = error "Element size mismatch"
19861843

19871844
-- Conversions - Mutable vectors
19881845
-- -----------------------------
@@ -2046,4 +1903,4 @@ copy :: (Prim a, PrimMonad m) => MVector (PrimState m) a -> Vector a -> m ()
20461903
copy = G.copy
20471904

20481905
-- $setup
2049-
-- >>> import Prelude (($), min, even, max, succ, id, Ord(..))
1906+
-- >>> import Prelude (($), min, even, max, succ, id, Ord(..), Num(..), undefined)

‎vector/src/Data/Vector/Primitive/Mutable.hs‎

Lines changed: 6 additions & 104 deletions
Original file line numberDiff line numberDiff line change
@@ -70,100 +70,15 @@ module Data.Vector.Primitive.Mutable (
7070
) where
7171

7272
import qualified Data.Vector.Generic.Mutable as G
73-
import Data.Primitive.ByteArray
74-
import Data.Primitive ( Prim, sizeOf )
75-
import Data.Vector.Internal.Check
76-
import Data.Word ( Word8 )
73+
import Data.Primitive ( Prim )
74+
import Data.Vector.Primitive.Mutable.Unsafe
75+
(MVector,IOVector,STVector,unsafeCoerceMVector,unsafeCast)
7776
import Control.Monad.Primitive
78-
import Control.Monad ( liftM )
7977

80-
import Control.DeepSeq ( NFData(rnf), NFData1(liftRnf))
81-
82-
import Prelude
83-
( Ord, Bool, Int, Maybe, Ordering(..)
84-
, otherwise, error, undefined, div, show, maxBound
85-
, (+), (*), (<), (>), (>=), (==), (&&), (||), ($), (++) )
86-
87-
import Data.Coerce
88-
import Unsafe.Coerce
78+
import Prelude ( Ord, Bool, Int, Maybe, Ordering(..) )
8979

9080
#include "vector.h"
9181

92-
type role MVector nominal nominal
93-
94-
-- | /O(1)/ Unsafely coerce a mutable vector from one element type to another,
95-
-- representationally equal type. The operation just changes the type of the
96-
-- underlying pointer and does not modify the elements.
97-
--
98-
-- Note that this function is unsafe. The @Coercible@ constraint guarantees
99-
-- that the element types are representationally equal. It however cannot
100-
-- guarantee that their respective 'Prim' instances are compatible.
101-
unsafeCoerceMVector :: Coercible a b => MVector s a -> MVector s b
102-
unsafeCoerceMVector = unsafeCoerce
103-
104-
-- | Mutable vectors of primitive types.
105-
data MVector s a = MVector {-# UNPACK #-} !Int -- ^ offset
106-
{-# UNPACK #-} !Int -- ^ length
107-
{-# UNPACK #-} !(MutableByteArray s) -- ^ underlying mutable byte array
108-
109-
type IOVector = MVector RealWorld
110-
type STVector s = MVector s
111-
112-
instance NFData (MVector s a) where
113-
rnf (MVector _ _ _) = ()
114-
115-
instance NFData1 (MVector s) where
116-
liftRnf _ (MVector _ _ _) = ()
117-
118-
instance Prim a => G.MVector MVector a where
119-
basicLength (MVector _ n _) = n
120-
basicUnsafeSlice j m (MVector i _ arr)
121-
= MVector (i+j) m arr
122-
123-
{-# INLINE basicOverlaps #-}
124-
basicOverlaps (MVector i m arr1) (MVector j n arr2)
125-
= sameMutableByteArray arr1 arr2
126-
&& (between i j (j+n) || between j i (i+m))
127-
where
128-
between x y z = x >= y && x < z
129-
130-
{-# INLINE basicUnsafeNew #-}
131-
basicUnsafeNew n
132-
| n < 0 = error $ "Primitive.basicUnsafeNew: negative length: " ++ show n
133-
| n > mx = error $ "Primitive.basicUnsafeNew: length too large: " ++ show n
134-
| otherwise = MVector 0 n `liftM` newByteArray (n * size)
135-
where
136-
size = sizeOf (undefined :: a)
137-
mx = maxBound `div` size :: Int
138-
139-
{-# INLINE basicInitialize #-}
140-
basicInitialize (MVector off n v) =
141-
setByteArray v (off * size) (n * size) (0 :: Word8)
142-
where
143-
size = sizeOf (undefined :: a)
144-
145-
146-
{-# INLINE basicUnsafeRead #-}
147-
basicUnsafeRead (MVector i _ arr) j = readByteArray arr (i+j)
148-
149-
{-# INLINE basicUnsafeWrite #-}
150-
basicUnsafeWrite (MVector i _ arr) j x = writeByteArray arr (i+j) x
151-
152-
{-# INLINE basicUnsafeCopy #-}
153-
basicUnsafeCopy (MVector i n dst) (MVector j _ src)
154-
= copyMutableByteArray dst (i*sz) src (j*sz) (n*sz)
155-
where
156-
sz = sizeOf (undefined :: a)
157-
158-
{-# INLINE basicUnsafeMove #-}
159-
basicUnsafeMove (MVector i n dst) (MVector j _ src)
160-
= moveByteArray dst (i*sz) src (j*sz) (n * sz)
161-
where
162-
sz = sizeOf (undefined :: a)
163-
164-
{-# INLINE basicSet #-}
165-
basicSet (MVector i n arr) x = setByteArray arr i n x
166-
16782
-- Length information
16883
-- ------------------
16984

@@ -745,18 +660,5 @@ ifoldrM' :: (PrimMonad m, Prim a) => (Int -> a -> b -> m b) -> b -> MVector (Pri
745660
{-# INLINE ifoldrM' #-}
746661
ifoldrM' = G.ifoldrM'
747662

748-
-- Unsafe conversions
749-
-- ------------------
750-
751-
-- | /O(1)/ Unsafely cast a vector from one element type to another.
752-
-- This operation just changes the type of the vector and does not
753-
-- modify the elements.
754-
--
755-
-- This function will throw an error if elements are of mismatching sizes.
756-
--
757-
-- | @since 0.13.0.0
758-
unsafeCast :: forall a b s. (HasCallStack, Prim a, Prim b) => MVector s a -> MVector s b
759-
{-# INLINE unsafeCast #-}
760-
unsafeCast (MVector o n ba)
761-
| sizeOf (undefined :: a) == sizeOf (undefined :: b) = MVector o n ba
762-
| otherwise = error "Element size mismatch"
663+
-- $setup
664+
-- >>> import Prelude (($), Num(..))

0 commit comments

Comments
 (0)