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)