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