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