GHC/IO/Buffer.hs

   1 {-# OPTIONS_GHC -fno-implicit-prelude -funbox-strict-fields #-}
   2 {-# OPTIONS_HADDOCK hide #-}
   3 -----------------------------------------------------------------------------
   4 -- |
   5 -- Module      :  GHC.IO.Buffer
   6 -- Copyright   :  (c) The University of Glasgow 2008
   7 -- License     :  see libraries/base/LICENSE
   8 --
   9 -- Maintainer  :  cvs-ghc@haskell.org
  10 -- Stability   :  internal
  11 -- Portability :  non-portable (GHC Extensions)
  12 --
  13 -- Buffers used in the IO system
  14 --
  15 -----------------------------------------------------------------------------
  16
  17 module GHC.IO.Buffer (
  18     -- * Buffers of any element
  19     Buffer(..), BufferState(..), CharBuffer, CharBufElem,
  20
  21     -- ** Creation
  22     newByteBuffer,
  23     newCharBuffer,
  24     newBuffer,
  25     emptyBuffer,
  26
  27     -- ** Insertion/removal
  28     bufferRemove,
  29     bufferAdd,
  30     slideContents,
  31     bufferAdjustL,
  32
  33     -- ** Inspecting
  34     isEmptyBuffer,
  35     isFullBuffer,
  36     isFullCharBuffer,
  37     isWriteBuffer,
  38     bufferElems,
  39     bufferAvailable,
  40     summaryBuffer,
  41
  42     -- ** Operating on the raw buffer as a Ptr
  43     withBuffer,
  44     withRawBuffer,
  45
  46     -- ** Assertions
  47     checkBuffer,
  48
  49     -- * Raw buffers
  50     RawBuffer,
  51     readWord8Buf,
  52     writeWord8Buf,
  53     RawCharBuffer,
  54     peekCharBuf,
  55     readCharBuf,
  56     writeCharBuf,
  57     readCharBufPtr,
  58     writeCharBufPtr,
  59     charSize,
  60  ) where
  61
  62 import GHC.Base
  63 -- import GHC.IO
  64 import GHC.Num
  65 import GHC.Ptr
  66 import GHC.Word
  67 import GHC.Show
  68 import GHC.Real
  69 import Foreign.C.Types
  70 import Foreign.ForeignPtr
  71 import Foreign.Storable
  72
  73 -- Char buffers use either UTF-16 or UTF-32, with the endianness matching
  74 -- the endianness of the host.
  75 --
  76 -- Invariants:
  77 --   * a Char buffer consists of *valid* UTF-16 or UTF-32
  78 --   * only whole characters: no partial surrogate pairs
  79
  80 -- #define CHARBUF_UTF16
  81 #define CHARBUF_UTF32
  82
  83 -- ---------------------------------------------------------------------------
  84 -- Raw blocks of data
  85
  86 type RawBuffer e = ForeignPtr e
  87
  88 readWord8Buf :: RawBuffer Word8 -> Int -> IO Word8
  89 readWord8Buf arr ix = withForeignPtr arr $ \p -> peekByteOff p ix
  90
  91 writeWord8Buf :: RawBuffer Word8 -> Int -> Word8 -> IO ()
  92 writeWord8Buf arr ix w = withForeignPtr arr $ \p -> pokeByteOff p ix w
  93
  94 #ifdef CHARBUF_UTF16
  95 type CharBufElem = Word16
  96 #else
  97 type CharBufElem = Char
  98 #endif
  99
 100 type RawCharBuffer = RawBuffer CharBufElem
 101
 102 peekCharBuf :: RawCharBuffer -> Int -> IO Char
 103 peekCharBuf arr ix = withForeignPtr arr $ \p -> do
 104                         (c,_) <- readCharBufPtr p ix
 105                         return c
 106
 107 {-# INLINE readCharBuf #-}
 108 readCharBuf :: RawCharBuffer -> Int -> IO (Char, Int)
 109 readCharBuf arr ix = withForeignPtr arr $ \p -> readCharBufPtr p ix
 110
 111 {-# INLINE writeCharBuf #-}
 112 writeCharBuf :: RawCharBuffer -> Int -> Char -> IO Int
 113 writeCharBuf arr ix c = withForeignPtr arr $ \p -> writeCharBufPtr p ix c
 114
 115 {-# INLINE readCharBufPtr #-}
 116 readCharBufPtr :: Ptr CharBufElem -> Int -> IO (Char, Int)
 117 #ifdef CHARBUF_UTF16
 118 readCharBufPtr p ix = do
 119   c1 <- peekElemOff p ix
 120   if (c1 < 0xd800 || c1 > 0xdbff)
 121      then return (chr (fromIntegral c1), ix+1)
 122      else do c2 <- peekElemOff p (ix+1)
 123              return (unsafeChr ((fromIntegral c1 - 0xd800)*0x400 +
 124                                 (fromIntegral c2 - 0xdc00) + 0x10000), ix+2)
 125 #else
 126 readCharBufPtr p ix = do c <- peekElemOff (castPtr p) ix; return (c, ix+1)
 127 #endif
 128
 129 {-# INLINE writeCharBufPtr #-}
 130 writeCharBufPtr :: Ptr CharBufElem -> Int -> Char -> IO Int
 131 #ifdef CHARBUF_UTF16
 132 writeCharBufPtr p ix ch
 133   | c < 0x10000 = do pokeElemOff p ix (fromIntegral c)
 134                      return (ix+1)
 135   | otherwise   = do let c' = c - 0x10000
 136                      pokeElemOff p ix (fromIntegral (c' `div` 0x400 + 0xd800))
 137                      pokeElemOff p (ix+1) (fromIntegral (c' `mod` 0x400 + 0xdc00))
 138                      return (ix+2)
 139   where
 140     c = ord ch
 141 #else
 142 writeCharBufPtr p ix ch = do pokeElemOff (castPtr p) ix ch; return (ix+1)
 143 #endif
 144
 145 charSize :: Int
 146 #ifdef CHARBUF_UTF16
 147 charSize = 2
 148 #else
 149 charSize = 4
 150 #endif
 151
 152 -- ---------------------------------------------------------------------------
 153 -- Buffers
 154
 155 -- The buffer is represented by a mutable variable containing a
 156 -- record, where the record contains the raw buffer and the start/end
 157 -- points of the filled portion.  We use a mutable variable so that
 158 -- the common operation of writing (or reading) some data from (to)
 159 -- the buffer doesn't need to modify, and hence copy, the handle
 160 -- itself, it just updates the buffer.
 161
 162 -- There will be some allocation involved in a simple hPutChar in
 163 -- order to create the new Buffer structure (below), but this is
 164 -- relatively small, and this only has to be done once per write
 165 -- operation.
 166
 167 -- | A mutable array of bytes that can be passed to foreign functions.
 168 data Buffer e
 169   = Buffer {
 170         bufRaw   :: !(RawBuffer e),
 171         bufState :: BufferState,
 172         bufSize  :: !Int,          -- in elements, not bytes
 173         bufL     :: !Int,          -- offset of first item in the buffer
 174         bufR     :: !Int           -- offset of last item + 1
 175   }
 176
 177 #ifdef CHARBUF_UTF16
 178 type CharBuffer = Buffer Word16
 179 #else
 180 type CharBuffer = Buffer Char
 181 #endif
 182
 183 data BufferState = ReadBuffer | WriteBuffer deriving (Eq)
 184
 185 withBuffer :: Buffer e -> (Ptr e -> IO a) -> IO a
 186 withBuffer Buffer{ bufRaw=raw } f = withForeignPtr (castForeignPtr raw) f
 187
 188 withRawBuffer :: RawBuffer e -> (Ptr e -> IO a) -> IO a
 189 withRawBuffer raw f = withForeignPtr (castForeignPtr raw) f
 190
 191 isEmptyBuffer :: Buffer e -> Bool
 192 isEmptyBuffer Buffer{ bufR=w } = w == 0
 193
 194 isFullBuffer :: Buffer e -> Bool
 195 isFullBuffer Buffer{ bufR=w, bufSize=s } = s == w
 196
 197 -- if a Char buffer does not have room for a surrogate pair, it is "full"
 198 isFullCharBuffer :: Buffer e -> Bool
 199 #ifdef CHARBUF_UTF16
 200 isFullCharBuffer buf = bufferAvailable buf < 2
 201 #else
 202 isFullCharBuffer = isFullBuffer
 203 #endif
 204
 205 isWriteBuffer :: Buffer e -> Bool
 206 isWriteBuffer buf = case bufState buf of
 207                         WriteBuffer -> True
 208                         ReadBuffer  -> False
 209
 210 bufferElems :: Buffer e -> Int
 211 bufferElems Buffer{ bufR=w, bufL=r } = w - r
 212
 213 bufferAvailable :: Buffer e -> Int
 214 bufferAvailable Buffer{ bufR=w, bufSize=s } = s - w
 215
 216 bufferRemove :: Int -> Buffer e -> Buffer e
 217 bufferRemove i buf@Buffer{ bufL=r } = bufferAdjustL (r+i) buf
 218
 219 bufferAdjustL :: Int -> Buffer e -> Buffer e
 220 bufferAdjustL l buf@Buffer{ bufR=w }
 221   | l == w    = buf{ bufL=0, bufR=0 }
 222   | otherwise = buf{ bufL=l, bufR=w }
 223
 224 bufferAdd :: Int -> Buffer e -> Buffer e
 225 bufferAdd i buf@Buffer{ bufR=w } = buf{ bufR=w+i }
 226
 227 emptyBuffer :: RawBuffer e -> Int -> BufferState -> Buffer e
 228 emptyBuffer raw sz state =
 229   Buffer{ bufRaw=raw, bufState=state, bufR=0, bufL=0, bufSize=sz }
 230
 231 newByteBuffer :: Int -> BufferState -> IO (Buffer Word8)
 232 newByteBuffer c st = newBuffer c c st
 233
 234 newCharBuffer :: Int -> BufferState -> IO CharBuffer
 235 newCharBuffer c st = newBuffer (c * charSize) c st
 236
 237 newBuffer :: Int -> Int -> BufferState -> IO (Buffer e)
 238 newBuffer bytes sz state = do
 239   fp <- mallocForeignPtrBytes bytes
 240   return (emptyBuffer fp sz state)
 241
 242 -- | slides the contents of the buffer to the beginning
 243 slideContents :: Buffer Word8 -> IO (Buffer Word8)
 244 slideContents buf@Buffer{ bufL=l, bufR=r, bufRaw=raw } = do
 245   let elems = r - l
 246   withRawBuffer raw $ \p -> memcpy p (p `plusPtr` l) (fromIntegral elems)
 247   return buf{ bufL=0, bufR=elems }
 248
 249 foreign import ccall unsafe "memcpy"
 250    memcpy :: Ptr a -> Ptr a -> CSize -> IO (Ptr ())
 251
 252 summaryBuffer :: Buffer a -> String
 253 summaryBuffer buf = "buf" ++ show (bufSize buf) ++ "(" ++ show (bufL buf) ++ "-" ++ show (bufR buf) ++ ")"
 254
 255 -- INVARIANTS on Buffers:
 256 --   * r <= w
 257 --   * if r == w, then r == 0 && w == 0
 258 --   * if state == WriteBuffer, then r == 0
 259 --   * a write buffer is never full.  If an operation
 260 --     fills up the buffer, it will always flush it before
 261 --     returning.
 262 --   * a read buffer may be full as a result of hLookAhead.  In normal
 263 --     operation, a read buffer always has at least one character of space.
 264
 265 checkBuffer :: Buffer a -> IO ()
 266 checkBuffer buf@Buffer{ bufState = state, bufL=r, bufR=w, bufSize=size } = do
 267      check buf (
 268         size > 0
 269         && r <= w
 270         && w <= size
 271         && ( r /= w || (r == 0 && w == 0) )
 272         && ( state /= WriteBuffer || r == 0 )
 273         && ( state /= WriteBuffer || w < size ) -- write buffer is never full
 274       )
 275
 276 check :: Buffer a -> Bool -> IO ()
 277 check _   True  = return ()
 278 check buf False = error ("buffer invariant violation: " ++ summaryBuffer buf)