Data/Array/IO.hs

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