GHC/IO/Buffer.hs

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