GHC/IO/Buffer.hs

   1 {-# OPTIONS_GHC  -XNoImplicitPrelude -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_UTF32
  81
  82 -- #define CHARBUF_UTF16
  83 --
  84 -- NB. it won't work to just change this to CHARBUF_UTF16.  Some of
  85 -- the code to make this work is there, and it has been tested with
  86 -- the Iconv codec, but there are some pieces that are known to be
  87 -- broken.  In particular, the built-in codecs
  88 -- e.g. GHC.IO.Encoding.UTF{8,16,32} need to use isFullCharBuffer or
  89 -- similar in place of the ow >= os comparisions.
  90
  91 -- ---------------------------------------------------------------------------
  92 -- Raw blocks of data
  93
  94 type RawBuffer e = ForeignPtr e
  95
  96 readWord8Buf :: RawBuffer Word8 -> Int -> IO Word8
  97 readWord8Buf arr ix = withForeignPtr arr $ \p -> peekByteOff p ix
  98
  99 writeWord8Buf :: RawBuffer Word8 -> Int -> Word8 -> IO ()
 100 writeWord8Buf arr ix w = withForeignPtr arr $ \p -> pokeByteOff p ix w
 101
 102 #ifdef CHARBUF_UTF16
 103 type CharBufElem = Word16
 104 #else
 105 type CharBufElem = Char
 106 #endif
 107
 108 type RawCharBuffer = RawBuffer CharBufElem
 109
 110 peekCharBuf :: RawCharBuffer -> Int -> IO Char
 111 peekCharBuf arr ix = withForeignPtr arr $ \p -> do
 112                         (c,_) <- readCharBufPtr p ix
 113                         return c
 114
 115 {-# INLINE readCharBuf #-}
 116 readCharBuf :: RawCharBuffer -> Int -> IO (Char, Int)
 117 readCharBuf arr ix = withForeignPtr arr $ \p -> readCharBufPtr p ix
 118
 119 {-# INLINE writeCharBuf #-}
 120 writeCharBuf :: RawCharBuffer -> Int -> Char -> IO Int
 121 writeCharBuf arr ix c = withForeignPtr arr $ \p -> writeCharBufPtr p ix c
 122
 123 {-# INLINE readCharBufPtr #-}
 124 readCharBufPtr :: Ptr CharBufElem -> Int -> IO (Char, Int)
 125 #ifdef CHARBUF_UTF16
 126 readCharBufPtr p ix = do
 127   c1 <- peekElemOff p ix
 128   if (c1 < 0xd800 || c1 > 0xdbff)
 129      then return (chr (fromIntegral c1), ix+1)
 130      else do c2 <- peekElemOff p (ix+1)
 131              return (unsafeChr ((fromIntegral c1 - 0xd800)*0x400 +
 132                                 (fromIntegral c2 - 0xdc00) + 0x10000), ix+2)
 133 #else
 134 readCharBufPtr p ix = do c <- peekElemOff (castPtr p) ix; return (c, ix+1)
 135 #endif
 136
 137 {-# INLINE writeCharBufPtr #-}
 138 writeCharBufPtr :: Ptr CharBufElem -> Int -> Char -> IO Int
 139 #ifdef CHARBUF_UTF16
 140 writeCharBufPtr p ix ch
 141   | c < 0x10000 = do pokeElemOff p ix (fromIntegral c)
 142                      return (ix+1)
 143   | otherwise   = do let c' = c - 0x10000
 144                      pokeElemOff p ix (fromIntegral (c' `div` 0x400 + 0xd800))
 145                      pokeElemOff p (ix+1) (fromIntegral (c' `mod` 0x400 + 0xdc00))
 146                      return (ix+2)
 147   where
 148     c = ord ch
 149 #else
 150 writeCharBufPtr p ix ch = do pokeElemOff (castPtr p) ix ch; return (ix+1)
 151 #endif
 152
 153 charSize :: Int
 154 #ifdef CHARBUF_UTF16
 155 charSize = 2
 156 #else
 157 charSize = 4
 158 #endif
 159
 160 -- ---------------------------------------------------------------------------
 161 -- Buffers
 162
 163 -- | A mutable array of bytes that can be passed to foreign functions.
 164 --
 165 -- The buffer is represented by a record, where the record contains
 166 -- the raw buffer and the start/end points of the filled portion.  The
 167 -- buffer contents itself is mutable, but the rest of the record is
 168 -- immutable.  This is a slightly odd mix, but it turns out to be
 169 -- quite practical: by making all the buffer metadata immutable, we
 170 -- can have operations on buffer metadata outside of the IO monad.
 171 --
 172 -- The "live" elements of the buffer are those between the 'bufL' and
 173 -- 'bufR' offsets.  In an empty buffer, 'bufL' is equal to 'bufR', but
 174 -- they might not be zero: for exmaple, the buffer might correspond to
 175 -- a memory-mapped file and in which case 'bufL' will point to the
 176 -- next location to be written, which is not necessarily the beginning
 177 -- of the file.
 178 data Buffer e
 179   = Buffer {
 180         bufRaw   :: !(RawBuffer e),
 181         bufState :: BufferState,
 182         bufSize  :: !Int,          -- in elements, not bytes
 183         bufL     :: !Int,          -- offset of first item in the buffer
 184         bufR     :: !Int           -- offset of last item + 1
 185   }
 186
 187 #ifdef CHARBUF_UTF16
 188 type CharBuffer = Buffer Word16
 189 #else
 190 type CharBuffer = Buffer Char
 191 #endif
 192
 193 data BufferState = ReadBuffer | WriteBuffer deriving (Eq)
 194
 195 withBuffer :: Buffer e -> (Ptr e -> IO a) -> IO a
 196 withBuffer Buffer{ bufRaw=raw } f = withForeignPtr (castForeignPtr raw) f
 197
 198 withRawBuffer :: RawBuffer e -> (Ptr e -> IO a) -> IO a
 199 withRawBuffer raw f = withForeignPtr (castForeignPtr raw) f
 200
 201 isEmptyBuffer :: Buffer e -> Bool
 202 isEmptyBuffer Buffer{ bufL=l, bufR=r } = l == r
 203
 204 isFullBuffer :: Buffer e -> Bool
 205 isFullBuffer Buffer{ bufR=w, bufSize=s } = s == w
 206
 207 -- if a Char buffer does not have room for a surrogate pair, it is "full"
 208 isFullCharBuffer :: Buffer e -> Bool
 209 #ifdef CHARBUF_UTF16
 210 isFullCharBuffer buf = bufferAvailable buf < 2
 211 #else
 212 isFullCharBuffer = isFullBuffer
 213 #endif
 214
 215 isWriteBuffer :: Buffer e -> Bool
 216 isWriteBuffer buf = case bufState buf of
 217                         WriteBuffer -> True
 218                         ReadBuffer  -> False
 219
 220 bufferElems :: Buffer e -> Int
 221 bufferElems Buffer{ bufR=w, bufL=r } = w - r
 222
 223 bufferAvailable :: Buffer e -> Int
 224 bufferAvailable Buffer{ bufR=w, bufSize=s } = s - w
 225
 226 bufferRemove :: Int -> Buffer e -> Buffer e
 227 bufferRemove i buf@Buffer{ bufL=r } = bufferAdjustL (r+i) buf
 228
 229 bufferAdjustL :: Int -> Buffer e -> Buffer e
 230 bufferAdjustL l buf@Buffer{ bufR=w }
 231   | l == w    = buf{ bufL=0, bufR=0 }
 232   | otherwise = buf{ bufL=l, bufR=w }
 233
 234 bufferAdd :: Int -> Buffer e -> Buffer e
 235 bufferAdd i buf@Buffer{ bufR=w } = buf{ bufR=w+i }
 236
 237 emptyBuffer :: RawBuffer e -> Int -> BufferState -> Buffer e
 238 emptyBuffer raw sz state =
 239   Buffer{ bufRaw=raw, bufState=state, bufR=0, bufL=0, bufSize=sz }
 240
 241 newByteBuffer :: Int -> BufferState -> IO (Buffer Word8)
 242 newByteBuffer c st = newBuffer c c st
 243
 244 newCharBuffer :: Int -> BufferState -> IO CharBuffer
 245 newCharBuffer c st = newBuffer (c * charSize) c st
 246
 247 newBuffer :: Int -> Int -> BufferState -> IO (Buffer e)
 248 newBuffer bytes sz state = do
 249   fp <- mallocForeignPtrBytes bytes
 250   return (emptyBuffer fp sz state)
 251
 252 -- | slides the contents of the buffer to the beginning
 253 slideContents :: Buffer Word8 -> IO (Buffer Word8)
 254 slideContents buf@Buffer{ bufL=l, bufR=r, bufRaw=raw } = do
 255   let elems = r - l
 256   withRawBuffer raw $ \p ->
 257       do _ <- memcpy p (p `plusPtr` l) (fromIntegral elems)
 258          return ()
 259   return buf{ bufL=0, bufR=elems }
 260
 261 foreign import ccall unsafe "memcpy"
 262    memcpy :: Ptr a -> Ptr a -> CSize -> IO (Ptr ())
 263
 264 summaryBuffer :: Buffer a -> String
 265 summaryBuffer buf = "buf" ++ show (bufSize buf) ++ "(" ++ show (bufL buf) ++ "-" ++ show (bufR buf) ++ ")"
 266
 267 -- INVARIANTS on Buffers:
 268 --   * r <= w
 269 --   * if r == w, and the buffer is for reading, then r == 0 && w == 0
 270 --   * a write buffer is never full.  If an operation
 271 --     fills up the buffer, it will always flush it before
 272 --     returning.
 273 --   * a read buffer may be full as a result of hLookAhead.  In normal
 274 --     operation, a read buffer always has at least one character of space.
 275
 276 checkBuffer :: Buffer a -> IO ()
 277 checkBuffer buf@Buffer{ bufState = state, bufL=r, bufR=w, bufSize=size } = do
 278      check buf (
 279         size > 0
 280         && r <= w
 281         && w <= size
 282         && ( r /= w || state == WriteBuffer || (r == 0 && w == 0) )
 283         && ( state /= WriteBuffer || w < size ) -- write buffer is never full
 284       )
 285
 286 check :: Buffer a -> Bool -> IO ()
 287 check _   True  = return ()
 288 check buf False = error ("buffer invariant violation: " ++ summaryBuffer buf)