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