Add move to mutable vectors
authorwasserman.louis <wasserman.louis@gmail.com>
Fri, 15 Apr 2011 03:14:34 +0000 (03:14 +0000)
committerwasserman.louis <wasserman.louis@gmail.com>
Fri, 15 Apr 2011 03:14:34 +0000 (03:14 +0000)
Data/Vector/Generic/Mutable.hs
Data/Vector/Mutable.hs
Data/Vector/Primitive/Mutable.hs
Data/Vector/Storable/Mutable.hs
Data/Vector/Unboxed/Base.hs
Data/Vector/Unboxed/Mutable.hs
internal/unbox-tuple-instances
tests/Main.hs
tests/Tests/Move.hs [new file with mode: 0644]
tests/vector-tests.cabal

index d5d5e94..161098a 100644 (file)
@@ -45,7 +45,7 @@ module Data.Vector.Generic.Mutable (
   -- * Modifying vectors
 
   -- ** Filling and copying
-  set, copy, unsafeCopy,
+  set, copy, move, unsafeCopy, unsafeMove,
 
   -- * Internal operations
   unstream, unstreamR,
@@ -122,6 +122,12 @@ class MVector v a where
                                   -> v (PrimState m) a   -- ^ source
                                   -> m ()
 
+  -- | Move the contents of a vector. The two vectors may overlap. This method
+  -- should not be called directly, use 'unsafeMove' instead.
+  basicUnsafeMove  :: PrimMonad m => v (PrimState m) a   -- ^ target
+                                  -> v (PrimState m) a   -- ^ source
+                                  -> m ()
+
   -- | Grow a vector by the given number of elements. This method should not be
   -- called directly, use 'unsafeGrow' instead.
   basicUnsafeGrow  :: PrimMonad m => v (PrimState m) a -> Int
@@ -163,6 +169,13 @@ class MVector v a where
                             basicUnsafeWrite dst i x
                             do_copy (i+1)
                 | otherwise = return ()
+  
+  {-# INLINE basicUnsafeMove #-}
+  basicUnsafeMove !dst !src
+    | basicOverlaps dst src = do
+        srcCopy <- clone src
+        basicUnsafeCopy dst srcCopy
+    | otherwise = basicUnsafeCopy dst src
 
   {-# INLINE basicUnsafeGrow #-}
   basicUnsafeGrow v by
@@ -636,6 +649,20 @@ copy dst src = BOUNDS_CHECK(check) "copy" "overlapping vectors"
                                           (length dst == length src)
              $ unsafeCopy dst src
 
+-- | Move the contents of a vector. The two vectors must have the same
+-- length.
+-- 
+-- If the vectors do not overlap, then this is equivalent to 'copy'.
+-- Otherwise, the copying is performed as if the source vector were
+-- copied to a temporary vector and then the temporary vector was copied
+-- to the target vector.
+move :: (PrimMonad m, MVector v a)
+                => v (PrimState m) a -> v (PrimState m) a -> m ()
+{-# INLINE move #-}
+move dst src = BOUNDS_CHECK(check) "move" "length mismatch"
+                                          (length dst == length src)
+             $ unsafeMove dst src
+
 -- | Copy a vector. The two vectors must have the same length and may not
 -- overlap. This is not checked.
 unsafeCopy :: (PrimMonad m, MVector v a) => v (PrimState m) a   -- ^ target
@@ -648,6 +675,20 @@ unsafeCopy dst src = UNSAFE_CHECK(check) "unsafeCopy" "length mismatch"
                                          (not (dst `overlaps` src))
                    $ (dst `seq` src `seq` basicUnsafeCopy dst src)
 
+-- | Move the contents of a vector. The two vectors must have the same
+-- length, but this is not checked.
+-- 
+-- If the vectors do not overlap, then this is equivalent to 'unsafeCopy'.
+-- Otherwise, the copying is performed as if the source vector were
+-- copied to a temporary vector and then the temporary vector was copied
+-- to the target vector.
+unsafeMove :: (PrimMonad m, MVector v a) => v (PrimState m) a   -- ^ target
+                                         -> v (PrimState m) a   -- ^ source
+                                         -> m ()
+{-# INLINE unsafeMove #-}
+unsafeMove dst src = UNSAFE_CHECK(check) "unsafeMove" "length mismatch"
+                                         (length dst == length src)
+                   $ (dst `seq` src `seq` basicUnsafeMove dst src)
 
 -- Permutations
 -- ------------
index 9b866ff..51d8e73 100644 (file)
@@ -1,4 +1,4 @@
-{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, BangPatterns #-}
 
 -- |
 -- Module      : Data.Vector.Mutable
@@ -46,12 +46,13 @@ module Data.Vector.Mutable (
   -- * Modifying vectors
 
   -- ** Filling and copying
-  set, copy, unsafeCopy,
+  set, copy, move, unsafeCopy, unsafeMove,
 
   -- * Deprecated operations
   newWith, unsafeNewWith
 ) where
 
+import           Control.Monad (when)
 import qualified Data.Vector.Generic.Mutable as G
 import           Data.Primitive.Array
 import           Control.Monad.Primitive
@@ -103,10 +104,70 @@ instance G.MVector MVector a where
 
   {-# INLINE basicUnsafeWrite #-}
   basicUnsafeWrite (MVector i n arr) j x = writeArray arr (i+j) x
+  
+  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 :: PrimMonad m => MutableArray (PrimState m) a -> Int -> Int -> Int -> m ()
+moveBackwards !arr !dstOff !srcOff !len =
+  INTERNAL_CHECK(check) "moveBackwards" "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 :: PrimMonad m => MutableArray (PrimState m) a -> Int -> Int -> Int -> m ()
+moveForwardsSmallOverlap !arr !dstOff !srcOff !len =
+  INTERNAL_CHECK(check) "moveForwardsSmallOverlap" "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 :: PrimMonad m => MutableArray (PrimState m) a -> Int -> Int -> Int -> m ()
+moveForwardsLargeOverlap !arr !dstOff !srcOff !len =
+  INTERNAL_CHECK(check) "moveForwardsLargeOverlap" "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"
 
@@ -291,6 +352,31 @@ unsafeCopy :: PrimMonad m => MVector (PrimState m) a   -- ^ target
 {-# INLINE unsafeCopy #-}
 unsafeCopy = G.unsafeCopy
 
+-- | Move the contents of a vector. The two vectors must have the same
+-- length.
+-- 
+-- If the vectors do not overlap, then this is equivalent to 'copy'.
+-- Otherwise, the copying is performed as if the source vector were
+-- copied to a temporary vector and then the temporary vector was copied
+-- to the target vector.
+move :: PrimMonad m
+                 => MVector (PrimState m) a -> MVector (PrimState m) a -> m ()
+{-# INLINE move #-}
+move = G.move
+
+-- | Move the contents of a vector. The two vectors must have the same
+-- length, but this is not checked.
+-- 
+-- If the vectors do not overlap, then this is equivalent to 'unsafeCopy'.
+-- Otherwise, the copying is performed as if the source vector were
+-- copied to a temporary vector and then the temporary vector was copied
+-- to the target vector.
+unsafeMove :: PrimMonad m => MVector (PrimState m) a   -- ^ target
+                          -> MVector (PrimState m) a   -- ^ source
+                          -> m ()
+{-# INLINE unsafeMove #-}
+unsafeMove = G.unsafeMove
+
 -- Deprecated functions
 -- --------------------
 
index fec69f6..9068cb8 100644 (file)
@@ -46,7 +46,7 @@ module Data.Vector.Primitive.Mutable (
   -- * Modifying vectors
 
   -- ** Filling and copying
-  set, copy, unsafeCopy,
+  set, copy, move, unsafeCopy, unsafeMove,
 
   -- * Deprecated operations
   newWith, unsafeNewWith
@@ -101,6 +101,12 @@ instance Prim a => G.MVector MVector a where
     = memcpyByteArray dst (i * sz) src (j * sz) (n * sz)
     where
       sz = sizeOf (undefined :: a)
+  
+  {-# INLINE basicUnsafeMove #-}
+  basicUnsafeMove (MVector i n dst) (MVector j _ src)
+    = memmoveByteArray dst (i * sz) src (j * sz) (n * sz)
+    where
+      sz = sizeOf (undefined :: a)
 
 -- Length information
 -- ------------------
@@ -288,6 +294,32 @@ unsafeCopy :: (PrimMonad m, Prim a)
 {-# INLINE unsafeCopy #-}
 unsafeCopy = G.unsafeCopy
 
+-- | Move the contents of a vector. The two vectors must have the same
+-- length.
+-- 
+-- If the vectors do not overlap, then this is equivalent to 'copy'.
+-- Otherwise, the copying is performed as if the source vector were
+-- copied to a temporary vector and then the temporary vector was copied
+-- to the target vector.
+move :: (PrimMonad m, Prim a)
+                 => MVector (PrimState m) a -> MVector (PrimState m) a -> m ()
+{-# INLINE move #-}
+move = G.move
+
+-- | Move the contents of a vector. The two vectors must have the same
+-- length, but this is not checked.
+-- 
+-- If the vectors do not overlap, then this is equivalent to 'unsafeCopy'.
+-- Otherwise, the copying is performed as if the source vector were
+-- copied to a temporary vector and then the temporary vector was copied
+-- to the target vector.
+unsafeMove :: (PrimMonad m, Prim a)
+                          => MVector (PrimState m) a   -- ^ target
+                          -> MVector (PrimState m) a   -- ^ source
+                          -> m ()
+{-# INLINE unsafeMove #-}
+unsafeMove = G.unsafeMove
+
 -- Deprecated functions
 -- --------------------
 
index c1913f7..d437a54 100644 (file)
@@ -46,7 +46,7 @@ module Data.Vector.Storable.Mutable(
   -- * Modifying vectors
 
   -- ** Filling and copying
-  set, copy, unsafeCopy,
+  set, copy, move, unsafeCopy, unsafeMove,
 
   -- * Raw pointers
   unsafeFromForeignPtr, unsafeToForeignPtr, unsafeWith,
@@ -66,7 +66,7 @@ import GHC.ForeignPtr (mallocPlainForeignPtrBytes)
 #endif
 
 import Foreign.Ptr
-import Foreign.Marshal.Array ( advancePtr, copyArray )
+import Foreign.Marshal.Array ( advancePtr, copyArray, moveArray )
 import Foreign.C.Types ( CInt )
 
 import Control.Monad.Primitive
@@ -124,6 +124,13 @@ instance Storable a => G.MVector MVector a where
     $ withForeignPtr fp $ \_ ->
       withForeignPtr fq $ \_ ->
       copyArray p q n
+  
+  {-# INLINE basicUnsafeMove #-}
+  basicUnsafeMove (MVector p n fp) (MVector q _ fq)
+    = unsafePrimToPrim
+    $ withForeignPtr fp $ \_ ->
+      withForeignPtr fq $ \_ ->
+      moveArray p q n
 
 {-# INLINE mallocVector #-}
 mallocVector :: Storable a => Int -> IO (ForeignPtr a)
@@ -325,6 +332,32 @@ unsafeCopy :: (PrimMonad m, Storable a)
 {-# INLINE unsafeCopy #-}
 unsafeCopy = G.unsafeCopy
 
+-- | Move the contents of a vector. The two vectors must have the same
+-- length.
+-- 
+-- If the vectors do not overlap, then this is equivalent to 'copy'.
+-- Otherwise, the copying is performed as if the source vector were
+-- copied to a temporary vector and then the temporary vector was copied
+-- to the target vector.
+move :: (PrimMonad m, Storable a)
+                 => MVector (PrimState m) a -> MVector (PrimState m) a -> m ()
+{-# INLINE move #-}
+move = G.move
+
+-- | Move the contents of a vector. The two vectors must have the same
+-- length, but this is not checked.
+-- 
+-- If the vectors do not overlap, then this is equivalent to 'unsafeCopy'.
+-- Otherwise, the copying is performed as if the source vector were
+-- copied to a temporary vector and then the temporary vector was copied
+-- to the target vector.
+unsafeMove :: (PrimMonad m, Storable a)
+                          => MVector (PrimState m) a   -- ^ target
+                          -> MVector (PrimState m) a   -- ^ source
+                          -> m ()
+{-# INLINE unsafeMove #-}
+unsafeMove = G.unsafeMove
+
 -- Raw pointers
 -- ------------
 
index b62406c..4eef8af 100644 (file)
@@ -155,6 +155,7 @@ instance M.MVector MVector ty where {                                   \
 ; basicClear (con v) = M.basicClear v                                   \
 ; basicSet (con v) x = M.basicSet v x                                   \
 ; basicUnsafeCopy (con v1) (con v2) = M.basicUnsafeCopy v1 v2           \
+; basicUnsafeMove (con v1) (con v2) = M.basicUnsafeMove v1 v2           \
 ; basicUnsafeGrow (con v) n = con `liftM` M.basicUnsafeGrow v n }
 
 #define primVector(ty,con,mcon)                                         \
@@ -295,6 +296,7 @@ instance M.MVector MVector Bool where
   basicClear (MV_Bool v) = M.basicClear v
   basicSet (MV_Bool v) x = M.basicSet v (fromBool x)
   basicUnsafeCopy (MV_Bool v1) (MV_Bool v2) = M.basicUnsafeCopy v1 v2
+  basicUnsafeMove (MV_Bool v1) (MV_Bool v2) = M.basicUnsafeMove v1 v2
   basicUnsafeGrow (MV_Bool v) n = MV_Bool `liftM` M.basicUnsafeGrow v n
 
 instance G.Vector Vector Bool where
@@ -343,6 +345,7 @@ instance (RealFloat a, Unbox a) => M.MVector MVector (Complex a) where
   basicClear (MV_Complex v) = M.basicClear v
   basicSet (MV_Complex v) (x :+ y) = M.basicSet v (x,y)
   basicUnsafeCopy (MV_Complex v1) (MV_Complex v2) = M.basicUnsafeCopy v1 v2
+  basicUnsafeMove (MV_Complex v1) (MV_Complex v2) = M.basicUnsafeMove v1 v2
   basicUnsafeGrow (MV_Complex v) n = MV_Complex `liftM` M.basicUnsafeGrow v n
 
 instance (RealFloat a, Unbox a) => G.Vector Vector (Complex a) where
index c959b2f..21933bc 100644 (file)
@@ -48,7 +48,7 @@ module Data.Vector.Unboxed.Mutable (
   -- * Modifying vectors
 
   -- ** Filling and copying
-  set, copy, unsafeCopy,
+  set, copy, move, unsafeCopy, unsafeMove,
 
   -- * Deprecated operations
   newWith, unsafeNewWith
@@ -251,6 +251,32 @@ unsafeCopy :: (PrimMonad m, Unbox a)
 {-# INLINE unsafeCopy #-}
 unsafeCopy = G.unsafeCopy
 
+-- | Move the contents of a vector. The two vectors must have the same
+-- length.
+-- 
+-- If the vectors do not overlap, then this is equivalent to 'copy'.
+-- Otherwise, the copying is performed as if the source vector were
+-- copied to a temporary vector and then the temporary vector was copied
+-- to the target vector.
+move :: (PrimMonad m, Unbox a)
+                 => MVector (PrimState m) a -> MVector (PrimState m) a -> m ()
+{-# INLINE move #-}
+move = G.move
+
+-- | Move the contents of a vector. The two vectors must have the same
+-- length, but this is not checked.
+-- 
+-- If the vectors do not overlap, then this is equivalent to 'unsafeCopy'.
+-- Otherwise, the copying is performed as if the source vector were
+-- copied to a temporary vector and then the temporary vector was copied
+-- to the target vector.
+unsafeMove :: (PrimMonad m, Unbox a)
+                          => MVector (PrimState m) a   -- ^ target
+                          -> MVector (PrimState m) a   -- ^ source
+                          -> m ()
+{-# INLINE unsafeMove #-}
+unsafeMove = G.unsafeMove
+
 -- Deprecated functions
 -- --------------------
 
index 0e40a7c..d733156 100644 (file)
@@ -55,6 +55,11 @@ instance (Unbox a, Unbox b) => M.MVector MVector (a, b) where
       = do
           M.basicUnsafeCopy as1 as2
           M.basicUnsafeCopy bs1 bs2
+  {-# INLINE basicUnsafeMove  #-}
+  basicUnsafeMove (MV_2 n_1 as1 bs1) (MV_2 n_2 as2 bs2)
+      = do
+          M.basicUnsafeMove as1 as2
+          M.basicUnsafeMove bs1 bs2
   {-# INLINE basicUnsafeGrow  #-}
   basicUnsafeGrow (MV_2 n_ as bs) m_
       = do
@@ -195,6 +200,12 @@ instance (Unbox a,
           M.basicUnsafeCopy as1 as2
           M.basicUnsafeCopy bs1 bs2
           M.basicUnsafeCopy cs1 cs2
+  {-# INLINE basicUnsafeMove  #-}
+  basicUnsafeMove (MV_3 n_1 as1 bs1 cs1) (MV_3 n_2 as2 bs2 cs2)
+      = do
+          M.basicUnsafeMove as1 as2
+          M.basicUnsafeMove bs1 bs2
+          M.basicUnsafeMove cs1 cs2
   {-# INLINE basicUnsafeGrow  #-}
   basicUnsafeGrow (MV_3 n_ as bs cs) m_
       = do
@@ -371,6 +382,16 @@ instance (Unbox a,
           M.basicUnsafeCopy bs1 bs2
           M.basicUnsafeCopy cs1 cs2
           M.basicUnsafeCopy ds1 ds2
+  {-# INLINE basicUnsafeMove  #-}
+  basicUnsafeMove (MV_4 n_1 as1 bs1 cs1 ds1) (MV_4 n_2 as2
+                                                       bs2
+                                                       cs2
+                                                       ds2)
+      = do
+          M.basicUnsafeMove as1 as2
+          M.basicUnsafeMove bs1 bs2
+          M.basicUnsafeMove cs1 cs2
+          M.basicUnsafeMove ds1 ds2
   {-# INLINE basicUnsafeGrow  #-}
   basicUnsafeGrow (MV_4 n_ as bs cs ds) m_
       = do
index 1f73858..21980dd 100644 (file)
@@ -2,9 +2,11 @@ module Main (main) where
 
 import qualified Tests.Vector
 import qualified Tests.Stream
+import qualified Tests.Move
 
 import Test.Framework (defaultMain)
 
 main = defaultMain $ Tests.Stream.tests
                   ++ Tests.Vector.tests
+                  ++ Tests.Move.tests
 
diff --git a/tests/Tests/Move.hs b/tests/Tests/Move.hs
new file mode 100644 (file)
index 0000000..b9a02d0
--- /dev/null
@@ -0,0 +1,34 @@
+module Tests.Move (tests) where
+
+import Test.QuickCheck
+import Test.Framework.Providers.QuickCheck2
+
+import Utilities ()
+
+import qualified Data.Vector.Generic as G
+import qualified Data.Vector.Generic.Mutable as M
+
+import qualified Data.Vector as V
+import qualified Data.Vector.Primitive as P
+import qualified Data.Vector.Storable as S
+import qualified Data.Vector.Unboxed as U
+
+basicMove :: G.Vector v a => v a -> Int -> Int -> Int -> v a
+basicMove v dstOff srcOff len 
+  | len > 0 = G.modify (\ mv -> G.copy (M.slice dstOff len mv) (G.slice srcOff len v)) v
+  | otherwise = v
+
+testMove :: (G.Vector v a, Show (v a), Eq (v a)) => v a -> Property
+testMove v = G.length v > 0 ==> (do
+  dstOff <- choose (0, G.length v - 1)
+  srcOff <- choose (0, G.length v - 1)
+  len <- choose (1, G.length v - max dstOff srcOff)
+  let expected = basicMove v dstOff srcOff len
+  let actual = G.modify (\ mv -> M.move (M.slice dstOff len mv) (M.slice srcOff len mv)) v
+  printTestCase ("Move: " ++ show (v, dstOff, srcOff, len)) (expected == actual))
+
+tests =
+    [testProperty "Data.Vector.Mutable (Move)" (testMove :: V.Vector Int -> Property),
+     testProperty "Data.Vector.Primitive.Mutable (Move)" (testMove :: P.Vector Int -> Property),
+     testProperty "Data.Vector.Unboxed.Mutable (Move)" (testMove :: U.Vector Int -> Property),
+     testProperty "Data.Vector.Storable.Mutable (Move)" (testMove :: S.Vector Int -> Property)]
\ No newline at end of file
index 2e09f56..0c4e0df 100644 (file)
@@ -27,7 +27,7 @@ Executable "vector-tests"
               TypeFamilies,
               TemplateHaskell
 
-  Build-Depends: base >= 4 && < 5, template-haskell, vector == 0.7,
+  Build-Depends: base >= 4 && < 5, template-haskell, vector == 0.6.0.1,
                  random,
                  QuickCheck >= 2, test-framework, test-framework-quickcheck2