GHC/IO/Buffer.hs

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