Data/Array/Diff.hs

   1 -----------------------------------------------------------------------------
   2 -- |
   3 -- Module      :  Data.Array.Diff
   4 -- Copyright   :  (c) The University of Glasgow 2001
   5 -- License     :  BSD-style (see the file libraries/base/LICENSE)
   6 --
   7 -- Maintainer  :  libraries@haskell.org
   8 -- Stability   :  experimental
   9 -- Portability :  non-portable
  10 --
  11 -- Functional arrays with constant-time update.
  12 --
  13 -----------------------------------------------------------------------------
  14
  15 module Data.Array.Diff (
  16
  17     -- Diff arrays have immutable interface, but rely on internal
  18     -- updates in place to provide fast functional update operator
  19     -- '//'.
  20     --
  21     -- When the '//' operator is applied to a diff array, its contents
  22     -- are physically updated in place. The old array silently changes
  23     -- its representation without changing the visible behavior:
  24     -- it stores a link to the new current array along with the
  25     -- difference to be applied to get the old contents.
  26     --
  27     -- So if a diff array is used in a single-threaded style,
  28     -- i.e. after '//' application the old version is no longer used,
  29     -- 'a!i' takes O(1) time and 'a // d' takes O(length d). Accessing
  30     -- elements of older versions gradually becomes slower.
  31     --
  32     -- Updating an array which is not current makes a physical copy.
  33     -- The resulting array is unlinked from the old family. So you
  34     -- can obtain a version which is guaranteed to be current and
  35     -- thus have fast element access by 'a // []'.
  36
  37     -- Possible improvement for the future (not implemented now):
  38     -- make it possible to say "I will make an update now, but when
  39     -- I later return to the old version, I want it to mutate back
  40     -- instead of being copied".
  41
  42     -- An arbitrary MArray type living in the IO monad can be converted
  43     -- to a diff array.
  44     IOToDiffArray, -- data IOToDiffArray
  45                    --     (a :: * -> * -> *) -- internal mutable array
  46                    --     (i :: *)           -- indices
  47                    --     (e :: *)           -- elements
  48
  49     -- Two most important diff array types are fully polymorphic
  50     -- lazy boxed DiffArray:
  51     DiffArray,     -- = IOToDiffArray IOArray
  52     -- ...and strict unboxed DiffUArray, working only for elements
  53     -- of primitive types but more compact and usually faster:
  54     DiffUArray,    -- = IOToDiffArray IOUArray
  55
  56     -- Module IArray provides the interface of diff arrays. They are
  57     -- instances of class IArray.
  58     module Data.Array.IArray,
  59
  60     -- These are really internal functions, but you will need them
  61     -- to make further IArray instances of various DiffArrays (for
  62     -- either more MArray types or more unboxed element types).
  63     newDiffArray, readDiffArray, replaceDiffArray
  64     )
  65     where
  66
  67 ------------------------------------------------------------------------
  68 -- Imports.
  69
  70 import Prelude
  71
  72 import Data.Ix
  73 import Data.Array.Base
  74 import Data.Array.IArray
  75 import Data.Array.IO
  76
  77 import Foreign.Ptr        ( Ptr, FunPtr )
  78 import Foreign.StablePtr  ( StablePtr )
  79 import Data.Int           ( Int8,  Int16,  Int32,  Int64 )
  80 #ifdef __GLASGOW_HASKELL__
  81 import Data.Word          ( Word )
  82 #endif
  83 import Data.Word          ( Word8, Word16, Word32, Word64 )
  84
  85 import System.IO.Unsafe   ( unsafePerformIO )
  86 import Control.Concurrent.MVar ( MVar, newMVar, takeMVar, putMVar, readMVar )
  87
  88 ------------------------------------------------------------------------
  89 -- Diff array types.
  90
  91 -- Convert an IO array type to a diff array.
  92 newtype IOToDiffArray a i e =
  93     DiffArray {varDiffArray :: MVar (DiffArrayData a i e)}
  94
  95 -- Internal representation: either a mutable array, or a link to
  96 -- another diff array patched with a list of index+element pairs.
  97 data DiffArrayData a i e = Current (a i e)
  98                          | Diff (IOToDiffArray a i e) [(Int, e)]
  99
 100 -- Type synonyms for two most important IO array types.
 101 type DiffArray  = IOToDiffArray IOArray
 102 type DiffUArray = IOToDiffArray IOUArray
 103
 104 -- Having 'MArray a e IO' in instance context would require
 105 -- -fallow-undecidable-instances, so each instance is separate here.
 106
 107 ------------------------------------------------------------------------
 108 -- Showing DiffArrays
 109
 110 instance (Ix ix, Show ix, Show e) => Show (DiffArray ix e) where
 111   showsPrec = showsIArray
 112
 113 instance (Ix ix, Show ix) => Show (DiffUArray ix Char) where
 114   showsPrec = showsIArray
 115
 116 instance (Ix ix, Show ix) => Show (DiffUArray ix Int) where
 117   showsPrec = showsIArray
 118
 119 #ifdef __GLASGOW_HASKELL__
 120 instance (Ix ix, Show ix) => Show (DiffUArray ix Word) where
 121   showsPrec = showsIArray
 122 #endif
 123
 124 instance (Ix ix, Show ix) => Show (DiffUArray ix Float) where
 125   showsPrec = showsIArray
 126
 127 instance (Ix ix, Show ix) => Show (DiffUArray ix Double) where
 128   showsPrec = showsIArray
 129
 130 instance (Ix ix, Show ix) => Show (DiffUArray ix Int8) where
 131   showsPrec = showsIArray
 132
 133 instance (Ix ix, Show ix) => Show (DiffUArray ix Int16) where
 134   showsPrec = showsIArray
 135
 136 instance (Ix ix, Show ix) => Show (DiffUArray ix Int32) where
 137   showsPrec = showsIArray
 138
 139 instance (Ix ix, Show ix) => Show (DiffUArray ix Int64) where
 140   showsPrec = showsIArray
 141
 142 instance (Ix ix, Show ix) => Show (DiffUArray ix Word8) where
 143   showsPrec = showsIArray
 144
 145 instance (Ix ix, Show ix) => Show (DiffUArray ix Word16) where
 146   showsPrec = showsIArray
 147
 148 instance (Ix ix, Show ix) => Show (DiffUArray ix Word32) where
 149   showsPrec = showsIArray
 150
 151 instance (Ix ix, Show ix) => Show (DiffUArray ix Word64) where
 152   showsPrec = showsIArray
 153
 154 ------------------------------------------------------------------------
 155 -- Boring instances.
 156
 157 instance HasBounds a => HasBounds (IOToDiffArray a) where
 158     bounds a = unsafePerformIO $ boundsDiffArray a
 159
 160 instance IArray (IOToDiffArray IOArray) e where
 161     unsafeArray   lu ies = unsafePerformIO $ newDiffArray lu ies
 162     unsafeAt      a i    = unsafePerformIO $ a `readDiffArray` i
 163     unsafeReplace a ies  = unsafePerformIO $ a `replaceDiffArray` ies
 164
 165 instance IArray (IOToDiffArray IOUArray) Char where
 166     unsafeArray   lu ies = unsafePerformIO $ newDiffArray lu ies
 167     unsafeAt      a i    = unsafePerformIO $ a `readDiffArray` i
 168     unsafeReplace a ies  = unsafePerformIO $ a `replaceDiffArray` ies
 169
 170 instance IArray (IOToDiffArray IOUArray) Int where
 171     unsafeArray   lu ies = unsafePerformIO $ newDiffArray lu ies
 172     unsafeAt      a i    = unsafePerformIO $ a `readDiffArray` i
 173     unsafeReplace a ies  = unsafePerformIO $ a `replaceDiffArray` ies
 174
 175 #ifdef __GLASGOW_HASKELL__
 176 instance IArray (IOToDiffArray IOUArray) Word where
 177     unsafeArray   lu ies = unsafePerformIO $ newDiffArray lu ies
 178     unsafeAt      a i    = unsafePerformIO $ a `readDiffArray` i
 179     unsafeReplace a ies  = unsafePerformIO $ a `replaceDiffArray` ies
 180 #endif
 181
 182 instance IArray (IOToDiffArray IOUArray) (Ptr a) where
 183     unsafeArray   lu ies = unsafePerformIO $ newDiffArray lu ies
 184     unsafeAt      a i    = unsafePerformIO $ a `readDiffArray` i
 185     unsafeReplace a ies  = unsafePerformIO $ a `replaceDiffArray` ies
 186
 187 instance IArray (IOToDiffArray IOUArray) (FunPtr a) where
 188     unsafeArray   lu ies = unsafePerformIO $ newDiffArray lu ies
 189     unsafeAt      a i    = unsafePerformIO $ a `readDiffArray` i
 190     unsafeReplace a ies  = unsafePerformIO $ a `replaceDiffArray` ies
 191
 192 instance IArray (IOToDiffArray IOUArray) Float where
 193     unsafeArray   lu ies = unsafePerformIO $ newDiffArray lu ies
 194     unsafeAt      a i    = unsafePerformIO $ a `readDiffArray` i
 195     unsafeReplace a ies  = unsafePerformIO $ a `replaceDiffArray` ies
 196
 197 instance IArray (IOToDiffArray IOUArray) Double where
 198     unsafeArray   lu ies = unsafePerformIO $ newDiffArray lu ies
 199     unsafeAt      a i    = unsafePerformIO $ a `readDiffArray` i
 200     unsafeReplace a ies  = unsafePerformIO $ a `replaceDiffArray` ies
 201
 202 instance IArray (IOToDiffArray IOUArray) (StablePtr a) where
 203     unsafeArray   lu ies = unsafePerformIO $ newDiffArray lu ies
 204     unsafeAt      a i    = unsafePerformIO $ a `readDiffArray` i
 205     unsafeReplace a ies  = unsafePerformIO $ a `replaceDiffArray` ies
 206
 207 instance IArray (IOToDiffArray IOUArray) Int8 where
 208     unsafeArray   lu ies = unsafePerformIO $ newDiffArray lu ies
 209     unsafeAt      a i    = unsafePerformIO $ a `readDiffArray` i
 210     unsafeReplace a ies  = unsafePerformIO $ a `replaceDiffArray` ies
 211
 212 instance IArray (IOToDiffArray IOUArray) Int16 where
 213     unsafeArray   lu ies = unsafePerformIO $ newDiffArray lu ies
 214     unsafeAt      a i    = unsafePerformIO $ a `readDiffArray` i
 215     unsafeReplace a ies  = unsafePerformIO $ a `replaceDiffArray` ies
 216
 217 instance IArray (IOToDiffArray IOUArray) Int32 where
 218     unsafeArray   lu ies = unsafePerformIO $ newDiffArray lu ies
 219     unsafeAt      a i    = unsafePerformIO $ a `readDiffArray` i
 220     unsafeReplace a ies  = unsafePerformIO $ a `replaceDiffArray` ies
 221
 222 instance IArray (IOToDiffArray IOUArray) Int64 where
 223     unsafeArray   lu ies = unsafePerformIO $ newDiffArray lu ies
 224     unsafeAt      a i    = unsafePerformIO $ a `readDiffArray` i
 225     unsafeReplace a ies  = unsafePerformIO $ a `replaceDiffArray` ies
 226
 227 instance IArray (IOToDiffArray IOUArray) Word8 where
 228     unsafeArray   lu ies = unsafePerformIO $ newDiffArray lu ies
 229     unsafeAt      a i    = unsafePerformIO $ a `readDiffArray` i
 230     unsafeReplace a ies  = unsafePerformIO $ a `replaceDiffArray` ies
 231
 232 instance IArray (IOToDiffArray IOUArray) Word16 where
 233     unsafeArray   lu ies = unsafePerformIO $ newDiffArray lu ies
 234     unsafeAt      a i    = unsafePerformIO $ a `readDiffArray` i
 235     unsafeReplace a ies  = unsafePerformIO $ a `replaceDiffArray` ies
 236
 237 instance IArray (IOToDiffArray IOUArray) Word32 where
 238     unsafeArray   lu ies = unsafePerformIO $ newDiffArray lu ies
 239     unsafeAt      a i    = unsafePerformIO $ a `readDiffArray` i
 240     unsafeReplace a ies  = unsafePerformIO $ a `replaceDiffArray` ies
 241
 242 instance IArray (IOToDiffArray IOUArray) Word64 where
 243     unsafeArray   lu ies = unsafePerformIO $ newDiffArray lu ies
 244     unsafeAt      a i    = unsafePerformIO $ a `readDiffArray` i
 245     unsafeReplace a ies  = unsafePerformIO $ a `replaceDiffArray` ies
 246
 247
 248
 249 ------------------------------------------------------------------------
 250 -- The important stuff.
 251
 252 newDiffArray :: (MArray a e IO, Ix i)
 253              => (i,i)
 254              -> [(Int, e)]
 255              -> IO (IOToDiffArray a i e)
 256 newDiffArray (l,u) ies = do
 257     a <- newArray_ (l,u)
 258     sequence_ [unsafeWrite a i e | (i, e) <- ies]
 259     var <- newMVar (Current a)
 260     return (DiffArray var)
 261
 262 readDiffArray :: (MArray a e IO, Ix i)
 263               => IOToDiffArray a i e
 264               -> Int
 265               -> IO e
 266 a `readDiffArray` i = do
 267     d <- readMVar (varDiffArray a)
 268     case d of
 269         Current a'  -> unsafeRead a' i
 270         Diff a' ies -> maybe (readDiffArray a' i) return (lookup i ies)
 271
 272 replaceDiffArray :: (MArray a e IO, Ix i)
 273                 => IOToDiffArray a i e
 274                 -> [(Int, e)]
 275                 -> IO (IOToDiffArray a i e)
 276 a `replaceDiffArray` ies = do
 277     d <- takeMVar (varDiffArray a)
 278     case d of
 279         Current a' -> case ies of
 280             [] -> do
 281                 -- We don't do the copy when there is nothing to change
 282                 -- and this is the current version. But see below.
 283                 putMVar (varDiffArray a) d
 284                 return a
 285             _:_ -> do
 286                 diff <- sequence [do e <- unsafeRead a' i; return (i, e)
 287                                   | (i, _) <- ies]
 288                 sequence_ [unsafeWrite a' i e | (i, e) <- ies]
 289                 var' <- newMVar (Current a')
 290                 putMVar (varDiffArray a) (Diff (DiffArray var') diff)
 291                 return (DiffArray var')
 292         Diff _ _ -> do
 293             -- We still do the copy when there is nothing to change
 294             -- but this is not the current version. So you can use
 295             -- 'a // []' to make sure that the resulting array has
 296             -- fast element access.
 297             putMVar (varDiffArray a) d
 298             a' <- thawDiffArray a
 299                 -- thawDiffArray gives a fresh array which we can
 300                 -- safely mutate.
 301             sequence_ [unsafeWrite a' i e | (i, e) <- ies]
 302             var' <- newMVar (Current a')
 303             return (DiffArray var')
 304
 305 boundsDiffArray :: (HasBounds a, Ix ix)
 306                 => IOToDiffArray a ix e
 307                 -> IO (ix,ix)
 308 boundsDiffArray a = do
 309     d <- readMVar (varDiffArray a)
 310     case d of
 311         Current a' -> return (bounds a')
 312         Diff a' _  -> boundsDiffArray a'
 313
 314 freezeDiffArray :: (MArray a e IO, Ix ix)
 315                 => a ix e
 316                 -> IO (IOToDiffArray a ix e)
 317 freezeDiffArray a = case bounds a of
 318   (l,u) -> do
 319     a' <- newArray_ (l,u)
 320     sequence_ [unsafeRead a i >>= unsafeWrite a' i | i <- [0 .. rangeSize (l,u) - 1]]
 321     var <- newMVar (Current a')
 322     return (DiffArray var)
 323
 324 {-# RULES
 325 "freeze/DiffArray" freeze = freezeDiffArray
 326     #-}
 327
 328 -- unsafeFreezeDiffArray is really unsafe. Better don't use the old
 329 -- array at all after freezing. The contents of the source array will
 330 -- be changed when '//' is applied to the resulting array.
 331
 332 unsafeFreezeDiffArray :: (MArray a e IO, Ix ix)
 333                       => a ix e
 334                       -> IO (IOToDiffArray a ix e)
 335 unsafeFreezeDiffArray a = do
 336     var <- newMVar (Current a)
 337     return (DiffArray var)
 338
 339 {-# RULES
 340 "unsafeFreeze/DiffArray" unsafeFreeze = unsafeFreezeDiffArray
 341     #-}
 342
 343 thawDiffArray :: (MArray a e IO, Ix ix)
 344               => IOToDiffArray a ix e
 345               -> IO (a ix e)
 346 thawDiffArray a = do
 347     d <- readMVar (varDiffArray a)
 348     case d of
 349         Current a' -> case bounds a' of
 350           (l,u) -> do
 351             a'' <- newArray_ (l,u)
 352             sequence_ [unsafeRead a' i >>= unsafeWrite a'' i | i <- [0 .. rangeSize (l,u) - 1]]
 353             return a''
 354         Diff a' ies -> do
 355             a'' <- thawDiffArray a'
 356             sequence_ [unsafeWrite a'' i e | (i, e) <- ies]
 357             return a''
 358
 359 {-# RULES
 360 "thaw/DiffArray" thaw = thawDiffArray
 361     #-}
 362
 363 -- unsafeThawDiffArray is really unsafe. Better don't use the old
 364 -- array at all after thawing. The contents of the resulting array
 365 -- will be changed when '//' is applied to the source array.
 366
 367 unsafeThawDiffArray :: (MArray a e IO, Ix ix)
 368                     => IOToDiffArray a ix e
 369                     -> IO (a ix e)
 370 unsafeThawDiffArray a = do
 371     d <- readMVar (varDiffArray a)
 372     case d of
 373         Current a'  -> return a'
 374         Diff a' ies -> do
 375             a'' <- unsafeThawDiffArray a'
 376             sequence_ [unsafeWrite a'' i e | (i, e) <- ies]
 377             return a''
 378
 379 {-# RULES
 380 "unsafeThaw/DiffArray" unsafeThaw = unsafeThawDiffArray
 381     #-}