X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=Data%2FArray%2FDiff.hs;fp=Data%2FArray%2FDiff.hs;h=2ef109fd5d5ad9b4e29acba641cbbe8516a28190;hb=23f43c48018638acbbf533447e74e08bf9fd789a;hp=0000000000000000000000000000000000000000;hpb=90f46a8830d97c24acecefbfb2a87b70588aa7e8;p=ghc-base.git diff --git a/Data/Array/Diff.hs b/Data/Array/Diff.hs new file mode 100644 index 0000000..2ef109f --- /dev/null +++ b/Data/Array/Diff.hs @@ -0,0 +1,327 @@ +----------------------------------------------------------------------------- +-- +-- Module : Data.Array.Diff +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/core/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable +-- +-- $Id: Diff.hs,v 1.1 2001/07/04 10:48:39 simonmar Exp $ +-- +-- Functional arrays with constant-time update. +-- +----------------------------------------------------------------------------- + +module Data.Array.Diff ( + + -- Diff arrays have immutable interface, but rely on internal + -- updates in place to provide fast functional update operator + -- '//'. + -- + -- When the '//' operator is applied to a diff array, its contents + -- are physically updated in place. The old array silently changes + -- its representation without changing the visible behavior: + -- it stores a link to the new current array along with the + -- difference to be applied to get the old contents. + -- + -- So if a diff array is used in a single-threaded style, + -- i.e. after '//' application the old version is no longer used, + -- 'a!i' takes O(1) time and 'a // d' takes O(length d). Accessing + -- elements of older versions gradually becomes slower. + -- + -- Updating an array which is not current makes a physical copy. + -- The resulting array is unlinked from the old family. So you + -- can obtain a version which is guaranteed to be current and + -- thus have fast element access by 'a // []'. + + -- Possible improvement for the future (not implemented now): + -- make it possible to say "I will make an update now, but when + -- I later return to the old version, I want it to mutate back + -- instead of being copied". + + -- An arbitrary MArray type living in the IO monad can be converted + -- to a diff array. + IOToDiffArray, -- data IOToDiffArray + -- (a :: * -> * -> *) -- internal mutable array + -- (i :: *) -- indices + -- (e :: *) -- elements + + -- Two most important diff array types are fully polymorphic + -- lazy boxed DiffArray: + DiffArray, -- = IOToDiffArray IOArray + -- ...and strict unboxed DiffUArray, working only for elements + -- of primitive types but more compact and usually faster: + DiffUArray, -- = IOToDiffArray IOUArray + + -- Module IArray provides the interface of diff arrays. They are + -- instances of class IArray. + module Data.Array.IArray, + + -- These are really internal functions, but you will need them + -- to make further IArray instances of various DiffArrays (for + -- either more MArray types or more unboxed element types). + newDiffArray, readDiffArray, replaceDiffArray + ) + where + +------------------------------------------------------------------------ +-- Imports. + +import Prelude + +import Data.Ix +import Data.Array.Base +import Data.Array.IArray +import Data.Array.IO + +import Foreign.Ptr ( Ptr, FunPtr ) +import Foreign.StablePtr ( StablePtr ) +import Data.Int ( Int8, Int16, Int32, Int64 ) +import Data.Word ( Word, Word8, Word16, Word32, Word64) + +import System.IO.Unsafe ( unsafePerformIO ) +import Control.Concurrent ( MVar, newMVar, takeMVar, putMVar, readMVar ) + +------------------------------------------------------------------------ +-- Diff array types. + +-- Convert an IO array type to a diff array. +newtype IOToDiffArray a i e = + DiffArray {varDiffArray :: MVar (DiffArrayData a i e)} + +-- Internal representation: either a mutable array, or a link to +-- another diff array patched with a list of index+element pairs. +data DiffArrayData a i e = Current (a i e) + | Diff (IOToDiffArray a i e) [(Int, e)] + +-- Type synonyms for two most important IO array types. +type DiffArray = IOToDiffArray IOArray +type DiffUArray = IOToDiffArray IOUArray + +-- Having 'MArray a e IO' in instance context would require +-- -fallow-undecidable-instances, so each instance is separate here. + +------------------------------------------------------------------------ +-- Boring instances. + +instance HasBounds a => HasBounds (IOToDiffArray a) where + bounds a = unsafePerformIO $ boundsDiffArray a + +instance IArray (IOToDiffArray IOArray) e where + unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies + unsafeAt a i = unsafePerformIO $ a `readDiffArray` i + unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray` ies + +instance IArray (IOToDiffArray IOUArray) Char where + unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies + unsafeAt a i = unsafePerformIO $ a `readDiffArray` i + unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray` ies + +instance IArray (IOToDiffArray IOUArray) Int where + unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies + unsafeAt a i = unsafePerformIO $ a `readDiffArray` i + unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray` ies + +instance IArray (IOToDiffArray IOUArray) Word where + unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies + unsafeAt a i = unsafePerformIO $ a `readDiffArray` i + unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray` ies + +instance IArray (IOToDiffArray IOUArray) (Ptr a) where + unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies + unsafeAt a i = unsafePerformIO $ a `readDiffArray` i + unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray` ies + +instance IArray (IOToDiffArray IOUArray) (FunPtr a) where + unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies + unsafeAt a i = unsafePerformIO $ a `readDiffArray` i + unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray` ies + +instance IArray (IOToDiffArray IOUArray) Float where + unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies + unsafeAt a i = unsafePerformIO $ a `readDiffArray` i + unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray` ies + +instance IArray (IOToDiffArray IOUArray) Double where + unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies + unsafeAt a i = unsafePerformIO $ a `readDiffArray` i + unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray` ies + +instance IArray (IOToDiffArray IOUArray) (StablePtr a) where + unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies + unsafeAt a i = unsafePerformIO $ a `readDiffArray` i + unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray` ies + +instance IArray (IOToDiffArray IOUArray) Int8 where + unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies + unsafeAt a i = unsafePerformIO $ a `readDiffArray` i + unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray` ies + +instance IArray (IOToDiffArray IOUArray) Int16 where + unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies + unsafeAt a i = unsafePerformIO $ a `readDiffArray` i + unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray` ies + +instance IArray (IOToDiffArray IOUArray) Int32 where + unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies + unsafeAt a i = unsafePerformIO $ a `readDiffArray` i + unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray` ies + +instance IArray (IOToDiffArray IOUArray) Int64 where + unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies + unsafeAt a i = unsafePerformIO $ a `readDiffArray` i + unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray` ies + +instance IArray (IOToDiffArray IOUArray) Word8 where + unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies + unsafeAt a i = unsafePerformIO $ a `readDiffArray` i + unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray` ies + +instance IArray (IOToDiffArray IOUArray) Word16 where + unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies + unsafeAt a i = unsafePerformIO $ a `readDiffArray` i + unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray` ies + +instance IArray (IOToDiffArray IOUArray) Word32 where + unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies + unsafeAt a i = unsafePerformIO $ a `readDiffArray` i + unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray` ies + +instance IArray (IOToDiffArray IOUArray) Word64 where + unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies + unsafeAt a i = unsafePerformIO $ a `readDiffArray` i + unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray` ies + +------------------------------------------------------------------------ +-- The important stuff. + +newDiffArray :: (MArray a e IO, Ix i) + => (i,i) + -> [(Int, e)] + -> IO (IOToDiffArray a i e) +newDiffArray (l,u) ies = do + a <- newArray_ (l,u) + sequence_ [unsafeWrite a i e | (i, e) <- ies] + var <- newMVar (Current a) + return (DiffArray var) + +readDiffArray :: (MArray a e IO, Ix i) + => IOToDiffArray a i e + -> Int + -> IO e +a `readDiffArray` i = do + d <- readMVar (varDiffArray a) + case d of + Current a' -> unsafeRead a' i + Diff a' ies -> maybe (readDiffArray a' i) return (lookup i ies) + +replaceDiffArray :: (MArray a e IO, Ix i) + => IOToDiffArray a i e + -> [(Int, e)] + -> IO (IOToDiffArray a i e) +a `replaceDiffArray` ies = do + d <- takeMVar (varDiffArray a) + case d of + Current a' -> case ies of + [] -> do + -- We don't do the copy when there is nothing to change + -- and this is the current version. But see below. + putMVar (varDiffArray a) d + return a + _:_ -> do + diff <- sequence [do e <- unsafeRead a' i; return (i, e) + | (i, _) <- ies] + sequence_ [unsafeWrite a' i e | (i, e) <- ies] + var' <- newMVar (Current a') + putMVar (varDiffArray a) (Diff (DiffArray var') diff) + return (DiffArray var') + Diff _ _ -> do + -- We still do the copy when there is nothing to change + -- but this is not the current version. So you can use + -- 'a // []' to make sure that the resulting array has + -- fast element access. + putMVar (varDiffArray a) d + a' <- thawDiffArray a + -- thawDiffArray gives a fresh array which we can + -- safely mutate. + sequence_ [unsafeWrite a' i e | (i, e) <- ies] + var' <- newMVar (Current a') + return (DiffArray var') + +boundsDiffArray :: (HasBounds a, Ix ix) + => IOToDiffArray a ix e + -> IO (ix,ix) +boundsDiffArray a = do + d <- readMVar (varDiffArray a) + case d of + Current a' -> return (bounds a') + Diff a' _ -> boundsDiffArray a' + +freezeDiffArray :: (MArray a e IO, Ix ix) + => a ix e + -> IO (IOToDiffArray a ix e) +freezeDiffArray a | (l,u) <- bounds a = do + a' <- newArray_ (l,u) + sequence_ [unsafeRead a i >>= unsafeWrite a' i | i <- [0 .. rangeSize (l,u) - 1]] + var <- newMVar (Current a') + return (DiffArray var) + +{-# RULES +"freeze/DiffArray" freeze = freezeDiffArray + #-} + +-- unsafeFreezeDiffArray is really unsafe. Better don't use the old +-- array at all after freezing. The contents of the source array will +-- be changed when '//' is applied to the resulting array. + +unsafeFreezeDiffArray :: (MArray a e IO, Ix ix) + => a ix e + -> IO (IOToDiffArray a ix e) +unsafeFreezeDiffArray a = do + var <- newMVar (Current a) + return (DiffArray var) + +{-# RULES +"unsafeFreeze/DiffArray" unsafeFreeze = unsafeFreezeDiffArray + #-} + +thawDiffArray :: (MArray a e IO, Ix ix) + => IOToDiffArray a ix e + -> IO (a ix e) +thawDiffArray a = do + d <- readMVar (varDiffArray a) + case d of + Current a' | (l,u) <- bounds a' -> do + a'' <- newArray_ (l,u) + sequence_ [unsafeRead a' i >>= unsafeWrite a'' i | i <- [0 .. rangeSize (l,u) - 1]] + return a'' + Diff a' ies -> do + a'' <- thawDiffArray a' + sequence_ [unsafeWrite a'' i e | (i, e) <- ies] + return a'' + +{-# RULES +"thaw/DiffArray" thaw = thawDiffArray + #-} + +-- unsafeThawDiffArray is really unsafe. Better don't use the old +-- array at all after thawing. The contents of the resulting array +-- will be changed when '//' is applied to the source array. + +unsafeThawDiffArray :: (MArray a e IO, Ix ix) + => IOToDiffArray a ix e + -> IO (a ix e) +unsafeThawDiffArray a = do + d <- readMVar (varDiffArray a) + case d of + Current a' -> return a' + Diff a' ies -> do + a'' <- unsafeThawDiffArray a' + sequence_ [unsafeWrite a'' i e | (i, e) <- ies] + return a'' + +{-# RULES +"unsafeThaw/DiffArray" unsafeThaw = unsafeThawDiffArray + #-}