Skip to content

Commit 3530f8f

Browse files
ShimuuarShimuuar
committed
Represent strict boxed vector as newtype over lazy one
This is done over @Bodigrim's suggestion. This allowed to drop quite bit of code
1 parent c623db7 commit 3530f8f

File tree

2 files changed

+39
-146
lines changed

2 files changed

+39
-146
lines changed

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

Lines changed: 18 additions & 29 deletions
Original file line numberDiff line numberDiff line change
@@ -5,7 +5,8 @@
55
{-# LANGUAGE MultiParamTypeClasses #-}
66
{-# LANGUAGE RankNTypes #-}
77
{-# LANGUAGE TypeFamilies #-}
8-
8+
{-# LANGUAGE TypeApplications #-}
9+
{-# LANGUAGE ScopedTypeVariables #-}
910
-- |
1011
-- Module : Data.Vector.Strict
1112
-- Copyright : (c) Roman Leshchinskiy 2008-2010
@@ -171,10 +172,12 @@ module Data.Vector.Strict (
171172
freeze, thaw, copy, unsafeFreeze, unsafeThaw, unsafeCopy
172173
) where
173174

175+
import Data.Coerce
174176
import Data.Vector.Strict.Mutable ( MVector(..) )
175177
import Data.Primitive.Array
176178
import qualified Data.Vector.Fusion.Bundle as Bundle
177179
import qualified Data.Vector.Generic as G
180+
import qualified Data.Vector as V
178181

179182
import Control.DeepSeq ( NFData(rnf)
180183
#if MIN_VERSION_deepseq(1,4,3)
@@ -196,7 +199,7 @@ import Data.Function ( fix )
196199
import Prelude
197200
( Eq, Ord, Num, Enum, Monoid, Functor, Monad, Show, Bool, Ordering(..), Int, Maybe, Either
198201
, compare, mempty, mappend, mconcat, return, showsPrec, fmap, otherwise, id, flip, const
199-
, (>>=), (+), (-), (<), (<=), (>), (>=), (==), (/=), (&&), (.), ($), seq )
202+
, (>>=), (+), (-), (<), (<=), (>), (>=), (==), (/=), (&&), (.), ($), seq ,undefined)
200203

201204
import Data.Functor.Classes (Eq1 (..), Ord1 (..), Read1 (..), Show1 (..))
202205
import Data.Typeable ( Typeable )
@@ -211,10 +214,8 @@ import qualified Data.Traversable as Traversable
211214
import qualified GHC.Exts as Exts (IsList(..))
212215

213216

214-
-- | Boxed vectors, supporting efficient slicing.
215-
data Vector a = Vector {-# UNPACK #-} !Int
216-
{-# UNPACK #-} !Int
217-
{-# UNPACK #-} !(Array a)
217+
-- | Strict boxed vectors, supporting efficient slicing.
218+
newtype Vector a = Vector (V.Vector a)
218219
deriving ( Typeable )
219220

220221
liftRnfV :: (a -> ()) -> Vector a -> ()
@@ -261,26 +262,17 @@ type instance G.Mutable Vector = MVector
261262

262263
instance G.Vector Vector a where
263264
{-# INLINE basicUnsafeFreeze #-}
264-
basicUnsafeFreeze (MVector i n marr)
265-
= Vector i n `liftM` unsafeFreezeArray marr
266-
265+
basicUnsafeFreeze = coerce (G.basicUnsafeFreeze @V.Vector @a)
267266
{-# INLINE basicUnsafeThaw #-}
268-
basicUnsafeThaw (Vector i n arr)
269-
= MVector i n `liftM` unsafeThawArray arr
270-
267+
basicUnsafeThaw = coerce (G.basicUnsafeThaw @V.Vector @a)
271268
{-# INLINE basicLength #-}
272-
basicLength (Vector _ n _) = n
273-
269+
basicLength = coerce (G.basicLength @V.Vector @a)
274270
{-# INLINE basicUnsafeSlice #-}
275-
basicUnsafeSlice j n (Vector i _ arr) = Vector (i+j) n arr
276-
271+
basicUnsafeSlice = coerce (G.basicUnsafeSlice @V.Vector @a)
277272
{-# INLINE basicUnsafeIndexM #-}
278-
basicUnsafeIndexM (Vector i _ arr) j = indexArrayM arr (i+j)
279-
273+
basicUnsafeIndexM = coerce (G.basicUnsafeIndexM @V.Vector @a)
280274
{-# INLINE basicUnsafeCopy #-}
281-
basicUnsafeCopy (MVector i n dst) (Vector j _ src)
282-
= copyArray dst i src j n
283-
275+
basicUnsafeCopy = coerce (G.basicUnsafeCopy @V.Vector @a)
284276
{-# INLINE elemseq #-}
285277
elemseq _ = seq
286278

@@ -2527,7 +2519,7 @@ fromListN = G.fromListN
25272519
-- @since 0.13.2.0
25282520
fromArray :: Array a -> Vector a
25292521
{-# INLINE fromArray #-}
2530-
fromArray arr = liftRnfV (`seq` ()) vec `seq` vec
2522+
fromArray arr = liftRnf (`seq` ()) vec `seq` vec
25312523
where
25322524
vec = lazyFromArray arr
25332525

@@ -2537,17 +2529,14 @@ fromArray arr = liftRnfV (`seq` ()) vec `seq` vec
25372529
-- @since NEXT
25382530
lazyFromArray :: Array a -> Vector a
25392531
{-# INLINE lazyFromArray #-}
2540-
lazyFromArray arr = Vector 0 (sizeofArray arr) arr
2541-
2532+
lazyFromArray = Vector . V.fromArray
25422533

25432534
-- | /O(n)/ Convert a vector to an array.
25442535
--
25452536
-- @since 0.13.2.0
25462537
toArray :: Vector a -> Array a
25472538
{-# INLINE toArray #-}
2548-
toArray (Vector offset len arr)
2549-
| offset == 0 && len == sizeofArray arr = arr
2550-
| otherwise = cloneArray arr offset len
2539+
toArray (Vector v) = V.toArray v
25512540

25522541
-- | /O(1)/ Extract the underlying `Array`, offset where vector starts and the
25532542
-- total number of elements in the vector. Below property always holds:
@@ -2558,7 +2547,7 @@ toArray (Vector offset len arr)
25582547
-- @since 0.13.2.0
25592548
toArraySlice :: Vector a -> (Array a, Int, Int)
25602549
{-# INLINE toArraySlice #-}
2561-
toArraySlice (Vector offset len arr) = (arr, offset, len)
2550+
toArraySlice (Vector v) = V.toArraySlice v
25622551

25632552

25642553
-- | /O(n)/ Convert an array slice to a vector and reduce each element to WHNF.
@@ -2595,7 +2584,7 @@ unsafeLazyFromArraySlice ::
25952584
-> Int -- ^ Length
25962585
-> Vector a
25972586
{-# INLINE unsafeLazyFromArraySlice #-}
2598-
unsafeLazyFromArraySlice arr offset len = Vector offset len arr
2587+
unsafeLazyFromArraySlice arr o l = Vector (V.unsafeFromArraySlice arr o l)
25992588

26002589

26012590
-- Conversions - Mutable vectors

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

Lines changed: 21 additions & 117 deletions
Original file line numberDiff line numberDiff line change
@@ -5,6 +5,8 @@
55
{-# LANGUAGE MultiParamTypeClasses #-}
66
{-# LANGUAGE RoleAnnotations #-}
77
{-# LANGUAGE TypeFamilies #-}
8+
{-# LANGUAGE TypeApplications #-}
9+
{-# LANGUAGE ScopedTypeVariables #-}
810
-- |
911
-- Module : Data.Vector.Strict.Mutable
1012
-- Copyright : (c) Roman Leshchinskiy 2008-2010
@@ -72,16 +74,15 @@ module Data.Vector.Strict.Mutable (
7274
PrimMonad, PrimState, RealWorld
7375
) where
7476

75-
import Control.Monad (when)
77+
import Data.Coerce
7678
import qualified Data.Vector.Generic.Mutable as G
77-
import Data.Vector.Internal.Check
79+
import qualified Data.Vector.Mutable as MV
7880
import Data.Primitive.Array
7981
import Control.Monad.Primitive
8082

8183
import Prelude
82-
( Ord, Monad(..), Bool, Ordering(..), Int, Maybe
83-
, compare, return, otherwise, error
84-
, (+), (-), (*), (<), (>), (>=), (&&), (||), ($), (>>), (<$>) )
84+
( Ord, Monad(..), Bool, Int, Maybe
85+
, return, ($), (<$>) )
8586

8687
import Data.Typeable ( Typeable )
8788

@@ -90,134 +91,39 @@ import Data.Typeable ( Typeable )
9091
type role MVector nominal representational
9192

9293
-- | Mutable boxed vectors keyed on the monad they live in ('IO' or @'ST' s@).
93-
data MVector s a = MVector { _offset :: {-# UNPACK #-} !Int
94-
-- ^ Offset in underlying array
95-
, _size :: {-# UNPACK #-} !Int
96-
-- ^ Size of slice
97-
, _array :: {-# UNPACK #-} !(MutableArray s a)
98-
-- ^ Underlying array
99-
}
94+
newtype MVector s a = MVector (MV.MVector s a)
10095
deriving ( Typeable )
10196

10297
type IOVector = MVector RealWorld
10398
type STVector s = MVector s
10499

105-
-- NOTE: This seems unsafe, see http://trac.haskell.org/vector/ticket/54
106-
{-
107-
instance NFData a => NFData (MVector s a) where
108-
rnf (MVector i n arr) = unsafeInlineST $ force i
109-
where
110-
force !ix | ix < n = do x <- readArray arr ix
111-
rnf x `seq` force (ix+1)
112-
| otherwise = return ()
113-
-}
114-
115100
instance G.MVector MVector a where
116101
{-# INLINE basicLength #-}
117-
basicLength (MVector _ n _) = n
118-
102+
basicLength = coerce (G.basicLength @MV.MVector @a)
119103
{-# INLINE basicUnsafeSlice #-}
120-
basicUnsafeSlice j m (MVector i _ arr) = MVector (i+j) m arr
121-
104+
basicUnsafeSlice = coerce (G.basicUnsafeSlice @MV.MVector @a)
122105
{-# INLINE basicOverlaps #-}
123-
basicOverlaps (MVector i m arr1) (MVector j n arr2)
124-
= sameMutableArray arr1 arr2
125-
&& (between i j (j+n) || between j i (i+m))
126-
where
127-
between x y z = x >= y && x < z
128-
106+
basicOverlaps = coerce (G.basicOverlaps @MV.MVector @a)
129107
{-# INLINE basicUnsafeNew #-}
130-
basicUnsafeNew n
131-
= do
132-
arr <- newArray n uninitialised
133-
return (MVector 0 n arr)
134-
108+
basicUnsafeNew = coerce (G.basicUnsafeNew @MV.MVector @a)
135109
{-# INLINE basicInitialize #-}
136110
-- initialization is unnecessary for boxed vectors
137111
basicInitialize _ = return ()
138-
139112
{-# INLINE basicUnsafeReplicate #-}
140-
basicUnsafeReplicate n !x
141-
= do
142-
arr <- newArray n x
143-
return (MVector 0 n arr)
144-
113+
basicUnsafeReplicate n !x = coerce (G.basicUnsafeReplicate @MV.MVector @a) n x
145114
{-# INLINE basicUnsafeRead #-}
146-
basicUnsafeRead (MVector i _ arr) j = readArray arr (i+j)
147-
115+
basicUnsafeRead = coerce (G.basicUnsafeRead @MV.MVector @a)
148116
{-# INLINE basicUnsafeWrite #-}
149-
basicUnsafeWrite (MVector i _ arr) j !x = writeArray arr (i+j) x
117+
basicUnsafeWrite vec j !x = (coerce (G.basicUnsafeWrite @MV.MVector @a)) vec j x
150118

151119
{-# INLINE basicUnsafeCopy #-}
152-
basicUnsafeCopy (MVector i n dst) (MVector j _ src)
153-
= copyMutableArray dst i src j n
154-
155-
basicUnsafeMove dst@(MVector iDst n arrDst) src@(MVector iSrc _ arrSrc)
156-
= case n of
157-
0 -> return ()
158-
1 -> readArray arrSrc iSrc >>= writeArray arrDst iDst
159-
2 -> do
160-
x <- readArray arrSrc iSrc
161-
y <- readArray arrSrc (iSrc + 1)
162-
writeArray arrDst iDst x
163-
writeArray arrDst (iDst + 1) y
164-
_
165-
| overlaps dst src
166-
-> case compare iDst iSrc of
167-
LT -> moveBackwards arrDst iDst iSrc n
168-
EQ -> return ()
169-
GT | (iDst - iSrc) * 2 < n
170-
-> moveForwardsLargeOverlap arrDst iDst iSrc n
171-
| otherwise
172-
-> moveForwardsSmallOverlap arrDst iDst iSrc n
173-
| otherwise -> G.basicUnsafeCopy dst src
120+
basicUnsafeCopy = coerce (G.basicUnsafeCopy @MV.MVector @a)
174121

122+
{-# INLINE basicUnsafeMove #-}
123+
basicUnsafeMove = coerce (G.basicUnsafeMove @MV.MVector @a)
175124
{-# INLINE basicClear #-}
176-
basicClear v = G.set v uninitialised
177-
178-
179-
{-# INLINE moveBackwards #-}
180-
moveBackwards :: PrimMonad m => MutableArray (PrimState m) a -> Int -> Int -> Int -> m ()
181-
moveBackwards !arr !dstOff !srcOff !len =
182-
check Internal "not a backwards move" (dstOff < srcOff)
183-
$ loopM len $ \ i -> readArray arr (srcOff + i) >>= writeArray arr (dstOff + i)
184-
185-
{-# INLINE moveForwardsSmallOverlap #-}
186-
-- Performs a move when dstOff > srcOff, optimized for when the overlap of the intervals is small.
187-
moveForwardsSmallOverlap :: PrimMonad m => MutableArray (PrimState m) a -> Int -> Int -> Int -> m ()
188-
moveForwardsSmallOverlap !arr !dstOff !srcOff !len =
189-
check Internal "not a forward move" (dstOff > srcOff)
190-
$ do
191-
tmp <- newArray overlap uninitialised
192-
loopM overlap $ \ i -> readArray arr (dstOff + i) >>= writeArray tmp i
193-
loopM nonOverlap $ \ i -> readArray arr (srcOff + i) >>= writeArray arr (dstOff + i)
194-
loopM overlap $ \ i -> readArray tmp i >>= writeArray arr (dstOff + nonOverlap + i)
195-
where nonOverlap = dstOff - srcOff; overlap = len - nonOverlap
196-
197-
-- Performs a move when dstOff > srcOff, optimized for when the overlap of the intervals is large.
198-
moveForwardsLargeOverlap :: PrimMonad m => MutableArray (PrimState m) a -> Int -> Int -> Int -> m ()
199-
moveForwardsLargeOverlap !arr !dstOff !srcOff !len =
200-
check Internal "not a forward move" (dstOff > srcOff)
201-
$ do
202-
queue <- newArray nonOverlap uninitialised
203-
loopM nonOverlap $ \ i -> readArray arr (srcOff + i) >>= writeArray queue i
204-
let mov !i !qTop = when (i < dstOff + len) $ do
205-
x <- readArray arr i
206-
y <- readArray queue qTop
207-
writeArray arr i y
208-
writeArray queue qTop x
209-
mov (i+1) (if qTop + 1 >= nonOverlap then 0 else qTop + 1)
210-
mov dstOff 0
211-
where nonOverlap = dstOff - srcOff
212-
213-
{-# INLINE loopM #-}
214-
loopM :: Monad m => Int -> (Int -> m a) -> m ()
215-
loopM !n k = let
216-
go i = when (i < n) (k i >> go (i+1))
217-
in go 0
218-
219-
uninitialised :: a
220-
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."
125+
basicClear = coerce (G.basicClear @MV.MVector @a)
126+
221127

222128
-- Length information
223129
-- ------------------
@@ -811,18 +717,16 @@ ifoldrM' = G.ifoldrM'
811717
fromMutableArray :: PrimMonad m => MutableArray (PrimState m) a -> m (MVector (PrimState m) a)
812718
{-# INLINE fromMutableArray #-}
813719
fromMutableArray marr = stToPrim $ do
814-
mvec <- MVector 0 size <$> cloneMutableArray marr 0 size
720+
mvec <- MVector <$> MV.fromMutableArray marr
815721
foldM' (\_ !_ -> return ()) () mvec
816722
return mvec
817-
where
818-
size = sizeofMutableArray marr
819723

820724
-- | /O(n)/ Make a copy of a mutable vector into a new mutable array.
821725
--
822726
-- @since 0.13.2.0
823727
toMutableArray :: PrimMonad m => MVector (PrimState m) a -> m (MutableArray (PrimState m) a)
824728
{-# INLINE toMutableArray #-}
825-
toMutableArray (MVector offset size marr) = cloneMutableArray marr offset size
729+
toMutableArray (MVector v) = MV.toMutableArray v
826730

827731
-- $setup
828732
-- >>> import Prelude (Integer)

0 commit comments

Comments
 (0)