Data/Array/IO.hs

   1 {-# OPTIONS -#include "HsBase.h" #-}
   2 -----------------------------------------------------------------------------
   3 -- |
   4 -- Module      :  Data.Array.IO
   5 -- Copyright   :  (c) The University of Glasgow 2001
   6 -- License     :  BSD-style (see the file libraries/base/LICENSE)
   7 --
   8 -- Maintainer  :  libraries@haskell.org
   9 -- Stability   :  experimental
  10 -- Portability :  non-portable
  11 --
  12 -- Mutable boxed and unboxed arrays in the IO monad.
  13 --
  14 -----------------------------------------------------------------------------
  15
  16 module Data.Array.IO (
  17    -- * @IO@ arrays with boxed elements
  18    IOArray,             -- instance of: Eq, Typeable
  19
  20    -- * @IO@ arrays with unboxed elements
  21    IOUArray,            -- instance of: Eq, Typeable
  22    castIOUArray,        -- :: IOUArray i a -> IO (IOUArray i b)
  23
  24    -- * Overloaded mutable array interface
  25    module Data.Array.MArray,
  26
  27    -- * Doing I\/O with @IOUArray@s
  28    hGetArray,           -- :: Handle -> IOUArray Int Word8 -> Int -> IO Int
  29    hPutArray,           -- :: Handle -> IOUArray Int Word8 -> Int -> IO ()
  30  ) where
  31
  32 import Prelude
  33
  34 import Data.Array               ( Array )
  35 import Data.Array.MArray
  36 import Data.Int
  37 import Data.Word
  38 import Data.Dynamic
  39
  40 import Foreign.C
  41 import Foreign.Ptr              ( Ptr, FunPtr )
  42 import Foreign.StablePtr        ( StablePtr )
  43
  44 #ifdef __GLASGOW_HASKELL__
  45 -- GHC only to the end of file
  46
  47 import Data.Array.Base
  48 import GHC.Arr          ( STArray, freezeSTArray, unsafeFreezeSTArray,
  49                           thawSTArray, unsafeThawSTArray )
  50
  51 import GHC.ST           ( ST(..) )
  52
  53 import GHC.IOBase
  54 import GHC.Handle
  55 import GHC.Conc
  56
  57 import GHC.Base
  58
  59 -----------------------------------------------------------------------------
  60 -- | Mutable, boxed, non-strict arrays in the 'IO' monad.  The type
  61 -- arguments are as follows:
  62 --
  63 --  * @i@: the index type of the array (should be an instance of @Ix@)
  64 --
  65 --  * @e@: the element type of the array.
  66 --
  67 newtype IOArray i e = IOArray (STArray RealWorld i e) deriving Eq
  68
  69 iOArrayTc :: TyCon
  70 iOArrayTc = mkTyCon "IOArray"
  71
  72 instance (Typeable a, Typeable b) => Typeable (IOArray a b) where
  73   typeOf a = mkAppTy iOArrayTc [typeOf ((undefined :: IOArray a b -> a) a),
  74                                 typeOf ((undefined :: IOArray a b -> b) a)]
  75
  76 instance HasBounds IOArray where
  77     {-# INLINE bounds #-}
  78     bounds (IOArray marr) = bounds marr
  79
  80 instance MArray IOArray e IO where
  81     {-# INLINE newArray #-}
  82     newArray lu init = stToIO $ do
  83         marr <- newArray lu init; return (IOArray marr)
  84     {-# INLINE newArray_ #-}
  85     newArray_ lu = stToIO $ do
  86         marr <- newArray_ lu; return (IOArray marr)
  87     {-# INLINE unsafeRead #-}
  88     unsafeRead (IOArray marr) i = stToIO (unsafeRead marr i)
  89     {-# INLINE unsafeWrite #-}
  90     unsafeWrite (IOArray marr) i e = stToIO (unsafeWrite marr i e)
  91
  92 -----------------------------------------------------------------------------
  93 -- Flat unboxed mutable arrays (IO monad)
  94
  95 -- | Mutable, unboxed, strict arrays in the 'IO' monad.  The type
  96 -- arguments are as follows:
  97 --
  98 --  * @i@: the index type of the array (should be an instance of @Ix@)
  99 --
 100 --  * @e@: the element type of the array.  Only certain element types
 101 --    are supported: see 'MArray' for a list of instances.
 102 --
 103 newtype IOUArray i e = IOUArray (STUArray RealWorld i e) deriving Eq
 104
 105 iOUArrayTc :: TyCon
 106 iOUArrayTc = mkTyCon "IOUArray"
 107
 108 instance (Typeable a, Typeable b) => Typeable (IOUArray a b) where
 109   typeOf a = mkAppTy iOUArrayTc [typeOf ((undefined :: IOUArray a b -> a) a),
 110                                  typeOf ((undefined :: IOUArray a b -> b) a)]
 111
 112 instance HasBounds IOUArray where
 113     {-# INLINE bounds #-}
 114     bounds (IOUArray marr) = bounds marr
 115
 116 instance MArray IOUArray Bool IO where
 117     {-# INLINE newArray #-}
 118     newArray lu init = stToIO $ do
 119         marr <- newArray lu init; return (IOUArray marr)
 120     {-# INLINE newArray_ #-}
 121     newArray_ lu = stToIO $ do
 122         marr <- newArray_ lu; return (IOUArray marr)
 123     {-# INLINE unsafeRead #-}
 124     unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
 125     {-# INLINE unsafeWrite #-}
 126     unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
 127
 128 instance MArray IOUArray Char IO where
 129     {-# INLINE newArray #-}
 130     newArray lu init = stToIO $ do
 131         marr <- newArray lu init; return (IOUArray marr)
 132     {-# INLINE newArray_ #-}
 133     newArray_ lu = stToIO $ do
 134         marr <- newArray_ lu; return (IOUArray marr)
 135     {-# INLINE unsafeRead #-}
 136     unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
 137     {-# INLINE unsafeWrite #-}
 138     unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
 139
 140 instance MArray IOUArray Int IO where
 141     {-# INLINE newArray #-}
 142     newArray lu init = stToIO $ do
 143         marr <- newArray lu init; return (IOUArray marr)
 144     {-# INLINE newArray_ #-}
 145     newArray_ lu = stToIO $ do
 146         marr <- newArray_ lu; return (IOUArray marr)
 147     {-# INLINE unsafeRead #-}
 148     unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
 149     {-# INLINE unsafeWrite #-}
 150     unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
 151
 152 instance MArray IOUArray Word IO where
 153     {-# INLINE newArray #-}
 154     newArray lu init = stToIO $ do
 155         marr <- newArray lu init; return (IOUArray marr)
 156     {-# INLINE newArray_ #-}
 157     newArray_ lu = stToIO $ do
 158         marr <- newArray_ lu; return (IOUArray marr)
 159     {-# INLINE unsafeRead #-}
 160     unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
 161     {-# INLINE unsafeWrite #-}
 162     unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
 163
 164 instance MArray IOUArray (Ptr a) IO where
 165     {-# INLINE newArray #-}
 166     newArray lu init = stToIO $ do
 167         marr <- newArray lu init; return (IOUArray marr)
 168     {-# INLINE newArray_ #-}
 169     newArray_ lu = stToIO $ do
 170         marr <- newArray_ lu; return (IOUArray marr)
 171     {-# INLINE unsafeRead #-}
 172     unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
 173     {-# INLINE unsafeWrite #-}
 174     unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
 175
 176 instance MArray IOUArray (FunPtr a) IO where
 177     {-# INLINE newArray #-}
 178     newArray lu init = stToIO $ do
 179         marr <- newArray lu init; return (IOUArray marr)
 180     {-# INLINE newArray_ #-}
 181     newArray_ lu = stToIO $ do
 182         marr <- newArray_ lu; return (IOUArray marr)
 183     {-# INLINE unsafeRead #-}
 184     unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
 185     {-# INLINE unsafeWrite #-}
 186     unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
 187
 188 instance MArray IOUArray Float IO where
 189     {-# INLINE newArray #-}
 190     newArray lu init = stToIO $ do
 191         marr <- newArray lu init; return (IOUArray marr)
 192     {-# INLINE newArray_ #-}
 193     newArray_ lu = stToIO $ do
 194         marr <- newArray_ lu; return (IOUArray marr)
 195     {-# INLINE unsafeRead #-}
 196     unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
 197     {-# INLINE unsafeWrite #-}
 198     unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
 199
 200 instance MArray IOUArray Double IO where
 201     {-# INLINE newArray #-}
 202     newArray lu init = stToIO $ do
 203         marr <- newArray lu init; return (IOUArray marr)
 204     {-# INLINE newArray_ #-}
 205     newArray_ lu = stToIO $ do
 206         marr <- newArray_ lu; return (IOUArray marr)
 207     {-# INLINE unsafeRead #-}
 208     unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
 209     {-# INLINE unsafeWrite #-}
 210     unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
 211
 212 instance MArray IOUArray (StablePtr a) IO where
 213     {-# INLINE newArray #-}
 214     newArray lu init = stToIO $ do
 215         marr <- newArray lu init; return (IOUArray marr)
 216     {-# INLINE newArray_ #-}
 217     newArray_ lu = stToIO $ do
 218         marr <- newArray_ lu; return (IOUArray marr)
 219     {-# INLINE unsafeRead #-}
 220     unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
 221     {-# INLINE unsafeWrite #-}
 222     unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
 223
 224 instance MArray IOUArray Int8 IO where
 225     {-# INLINE newArray #-}
 226     newArray lu init = stToIO $ do
 227         marr <- newArray lu init; return (IOUArray marr)
 228     {-# INLINE newArray_ #-}
 229     newArray_ lu = stToIO $ do
 230         marr <- newArray_ lu; return (IOUArray marr)
 231     {-# INLINE unsafeRead #-}
 232     unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
 233     {-# INLINE unsafeWrite #-}
 234     unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
 235
 236 instance MArray IOUArray Int16 IO where
 237     {-# INLINE newArray #-}
 238     newArray lu init = stToIO $ do
 239         marr <- newArray lu init; return (IOUArray marr)
 240     {-# INLINE newArray_ #-}
 241     newArray_ lu = stToIO $ do
 242         marr <- newArray_ lu; return (IOUArray marr)
 243     {-# INLINE unsafeRead #-}
 244     unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
 245     {-# INLINE unsafeWrite #-}
 246     unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
 247
 248 instance MArray IOUArray Int32 IO where
 249     {-# INLINE newArray #-}
 250     newArray lu init = stToIO $ do
 251         marr <- newArray lu init; return (IOUArray marr)
 252     {-# INLINE newArray_ #-}
 253     newArray_ lu = stToIO $ do
 254         marr <- newArray_ lu; return (IOUArray marr)
 255     {-# INLINE unsafeRead #-}
 256     unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
 257     {-# INLINE unsafeWrite #-}
 258     unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
 259
 260 instance MArray IOUArray Int64 IO where
 261     {-# INLINE newArray #-}
 262     newArray lu init = stToIO $ do
 263         marr <- newArray lu init; return (IOUArray marr)
 264     {-# INLINE newArray_ #-}
 265     newArray_ lu = stToIO $ do
 266         marr <- newArray_ lu; return (IOUArray marr)
 267     {-# INLINE unsafeRead #-}
 268     unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
 269     {-# INLINE unsafeWrite #-}
 270     unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
 271
 272 instance MArray IOUArray Word8 IO where
 273     {-# INLINE newArray #-}
 274     newArray lu init = stToIO $ do
 275         marr <- newArray lu init; return (IOUArray marr)
 276     {-# INLINE newArray_ #-}
 277     newArray_ lu = stToIO $ do
 278         marr <- newArray_ lu; return (IOUArray marr)
 279     {-# INLINE unsafeRead #-}
 280     unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
 281     {-# INLINE unsafeWrite #-}
 282     unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
 283
 284 instance MArray IOUArray Word16 IO where
 285     {-# INLINE newArray #-}
 286     newArray lu init = stToIO $ do
 287         marr <- newArray lu init; return (IOUArray marr)
 288     {-# INLINE newArray_ #-}
 289     newArray_ lu = stToIO $ do
 290         marr <- newArray_ lu; return (IOUArray marr)
 291     {-# INLINE unsafeRead #-}
 292     unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
 293     {-# INLINE unsafeWrite #-}
 294     unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
 295
 296 instance MArray IOUArray Word32 IO where
 297     {-# INLINE newArray #-}
 298     newArray lu init = stToIO $ do
 299         marr <- newArray lu init; return (IOUArray marr)
 300     {-# INLINE newArray_ #-}
 301     newArray_ lu = stToIO $ do
 302         marr <- newArray_ lu; return (IOUArray marr)
 303     {-# INLINE unsafeRead #-}
 304     unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
 305     {-# INLINE unsafeWrite #-}
 306     unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
 307
 308 instance MArray IOUArray Word64 IO where
 309     {-# INLINE newArray #-}
 310     newArray lu init = stToIO $ do
 311         marr <- newArray lu init; return (IOUArray marr)
 312     {-# INLINE newArray_ #-}
 313     newArray_ lu = stToIO $ do
 314         marr <- newArray_ lu; return (IOUArray marr)
 315     {-# INLINE unsafeRead #-}
 316     unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
 317     {-# INLINE unsafeWrite #-}
 318     unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
 319
 320 -----------------------------------------------------------------------------
 321 -- Freezing
 322
 323 freezeIOArray :: Ix ix => IOArray ix e -> IO (Array ix e)
 324 freezeIOArray (IOArray marr) = stToIO (freezeSTArray marr)
 325
 326 freezeIOUArray :: Ix ix => IOUArray ix e -> IO (UArray ix e)
 327 freezeIOUArray (IOUArray marr) = stToIO (freezeSTUArray marr)
 328
 329 {-# RULES
 330 "freeze/IOArray"  freeze = freezeIOArray
 331 "freeze/IOUArray" freeze = freezeIOUArray
 332     #-}
 333
 334 {-# INLINE unsafeFreezeIOArray #-}
 335 unsafeFreezeIOArray :: Ix ix => IOArray ix e -> IO (Array ix e)
 336 unsafeFreezeIOArray (IOArray marr) = stToIO (unsafeFreezeSTArray marr)
 337
 338 {-# INLINE unsafeFreezeIOUArray #-}
 339 unsafeFreezeIOUArray :: Ix ix => IOUArray ix e -> IO (UArray ix e)
 340 unsafeFreezeIOUArray (IOUArray marr) = stToIO (unsafeFreezeSTUArray marr)
 341
 342 {-# RULES
 343 "unsafeFreeze/IOArray"  unsafeFreeze = unsafeFreezeIOArray
 344 "unsafeFreeze/IOUArray" unsafeFreeze = unsafeFreezeIOUArray
 345     #-}
 346
 347 -----------------------------------------------------------------------------
 348 -- Thawing
 349
 350 thawIOArray :: Ix ix => Array ix e -> IO (IOArray ix e)
 351 thawIOArray arr = stToIO $ do
 352     marr <- thawSTArray arr
 353     return (IOArray marr)
 354
 355 thawIOUArray :: Ix ix => UArray ix e -> IO (IOUArray ix e)
 356 thawIOUArray arr = stToIO $ do
 357     marr <- thawSTUArray arr
 358     return (IOUArray marr)
 359
 360 {-# RULES
 361 "thaw/IOArray"  thaw = thawIOArray
 362 "thaw/IOUArray" thaw = thawIOUArray
 363     #-}
 364
 365 {-# INLINE unsafeThawIOArray #-}
 366 unsafeThawIOArray :: Ix ix => Array ix e -> IO (IOArray ix e)
 367 unsafeThawIOArray arr = stToIO $ do
 368     marr <- unsafeThawSTArray arr
 369     return (IOArray marr)
 370
 371 {-# INLINE unsafeThawIOUArray #-}
 372 unsafeThawIOUArray :: Ix ix => UArray ix e -> IO (IOUArray ix e)
 373 unsafeThawIOUArray arr = stToIO $ do
 374     marr <- unsafeThawSTUArray arr
 375     return (IOUArray marr)
 376
 377 {-# RULES
 378 "unsafeThaw/IOArray"  unsafeThaw = unsafeThawIOArray
 379 "unsafeThaw/IOUArray" unsafeThaw = unsafeThawIOUArray
 380     #-}
 381
 382 castSTUArray :: STUArray s ix a -> ST s (STUArray s ix b)
 383 castSTUArray (STUArray l u marr#) = return (STUArray l u marr#)
 384
 385 -- | Casts an 'IOUArray' with one element type into one with a
 386 -- different element type.  All the elements of the resulting array
 387 -- are undefined (unless you know what you\'re doing...).
 388 castIOUArray :: IOUArray ix a -> IO (IOUArray ix b)
 389 castIOUArray (IOUArray marr) = stToIO $ do
 390     marr' <- castSTUArray marr
 391     return (IOUArray marr')
 392
 393 -- ---------------------------------------------------------------------------
 394 -- hGetArray
 395
 396 -- | Reads a number of 'Word8's from the specified 'Handle' directly
 397 -- into an array.
 398 hGetArray
 399         :: Handle               -- ^ Handle to read from
 400         -> IOUArray Int Word8   -- ^ Array in which to place the values
 401         -> Int                  -- ^ Number of 'Word8's to read
 402         -> IO Int
 403                 -- ^ Returns: the number of 'Word8's actually
 404                 -- read, which might be smaller than the number requested
 405                 -- if the end of file was reached.
 406
 407 hGetArray handle (IOUArray (STUArray l u ptr)) count
 408   | count <= 0 || count > rangeSize (l,u)
 409   = illegalBufferSize handle "hGetArray" count
 410   | otherwise = do
 411       wantReadableHandle "hGetArray" handle $
 412         \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> do
 413         buf@Buffer{ bufBuf=raw, bufWPtr=w, bufRPtr=r } <- readIORef ref
 414         if bufferEmpty buf
 415            then readChunk fd is_stream ptr 0 count
 416            else do
 417                 let avail = w - r
 418                 copied <- if (count >= avail)
 419                             then do
 420                                 memcpy_ba_baoff ptr raw r (fromIntegral avail)
 421                                 writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }
 422                                 return avail
 423                             else do
 424                                 memcpy_ba_baoff ptr raw r (fromIntegral count)
 425                                 writeIORef ref buf{ bufRPtr = r + count }
 426                                 return count
 427
 428                 let remaining = count - copied
 429                 if remaining > 0
 430                    then do rest <- readChunk fd is_stream ptr copied remaining
 431                            return (rest + count)
 432                    else return count
 433
 434 readChunk :: FD -> Bool -> RawBuffer -> Int -> Int -> IO Int
 435 readChunk fd is_stream ptr init_off bytes = loop init_off bytes
 436  where
 437   loop :: Int -> Int -> IO Int
 438   loop off bytes | bytes <= 0 = return (off - init_off)
 439   loop off bytes = do
 440     r' <- throwErrnoIfMinus1RetryMayBlock "readChunk"
 441             (read_off_ba (fromIntegral fd) is_stream ptr
 442                 (fromIntegral off) (fromIntegral bytes))
 443             (threadWaitRead fd)
 444     let r = fromIntegral r'
 445     if r == 0
 446         then return (off - init_off)
 447         else loop (off + r) (bytes - r)
 448
 449 -- ---------------------------------------------------------------------------
 450 -- hPutArray
 451
 452 -- | Writes an array of 'Word8' to the specified 'Handle'.
 453 hPutArray
 454         :: Handle                       -- ^ Handle to write to
 455         -> IOUArray Int Word8           -- ^ Array to write from
 456         -> Int                          -- ^ Number of 'Word8's to write
 457         -> IO ()
 458
 459 hPutArray handle (IOUArray (STUArray l u raw)) count
 460   | count <= 0 || count > rangeSize (l,u)
 461   = illegalBufferSize handle "hPutArray" count
 462   | otherwise
 463    = do wantWritableHandle "hPutArray" handle $
 464           \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=stream } -> do
 465
 466           old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size }
 467             <- readIORef ref
 468
 469           -- enough room in handle buffer?
 470           if (size - w > count)
 471                 -- There's enough room in the buffer:
 472                 -- just copy the data in and update bufWPtr.
 473             then do memcpy_baoff_ba old_raw w raw (fromIntegral count)
 474                     writeIORef ref old_buf{ bufWPtr = w + count }
 475                     return ()
 476
 477                 -- else, we have to flush
 478             else do flushed_buf <- flushWriteBuffer fd stream old_buf
 479                     writeIORef ref flushed_buf
 480                     let this_buf =
 481                             Buffer{ bufBuf=raw, bufState=WriteBuffer,
 482                                     bufRPtr=0, bufWPtr=count, bufSize=count }
 483                     flushWriteBuffer fd stream this_buf
 484                     return ()
 485
 486 -- ---------------------------------------------------------------------------
 487 -- Internal Utils
 488
 489 foreign import ccall unsafe "__hscore_memcpy_dst_off"
 490    memcpy_baoff_ba :: RawBuffer -> Int -> RawBuffer -> CSize -> IO (Ptr ())
 491 foreign import ccall unsafe "__hscore_memcpy_src_off"
 492    memcpy_ba_baoff :: RawBuffer -> RawBuffer -> Int -> CSize -> IO (Ptr ())
 493
 494 illegalBufferSize :: Handle -> String -> Int -> IO a
 495 illegalBufferSize handle fn sz =
 496         ioException (IOError (Just handle)
 497                             InvalidArgument  fn
 498                             ("illegal buffer size " ++ showsPrec 9 (sz::Int) [])
 499                             Nothing)
 500
 501 #endif /* __GLASGOW_HASKELL__ */