compiler/utils/StringBuffer.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 % (c) The University of Glasgow, 1997-2006
   4 %
   5
   6 Buffers for scanning string input stored in external arrays.
   7
   8 \begin{code}
   9 {-# OPTIONS_GHC -O -funbox-strict-fields #-}
  10 -- We always optimise this, otherwise performance of a non-optimised
  11 -- compiler is severely affected
  12
  13 module StringBuffer
  14        (
  15         StringBuffer(..),
  16         -- non-abstract for vs\/HaskellService
  17
  18          -- * Creation\/destruction
  19         hGetStringBuffer,
  20         hGetStringBufferBlock,
  21         appendStringBuffers,
  22         stringToStringBuffer,
  23
  24         -- * Inspection
  25         nextChar,
  26         currentChar,
  27         prevChar,
  28         atEnd,
  29
  30         -- * Moving and comparison
  31         stepOn,
  32         offsetBytes,
  33         byteDiff,
  34
  35         -- * Conversion
  36         lexemeToString,
  37         lexemeToFastString,
  38
  39          -- * Parsing integers
  40         parseUnsignedInteger,
  41        ) where
  42
  43 #include "HsVersions.h"
  44
  45 import Encoding
  46 import FastString hiding ( buf )
  47 import FastTypes
  48 import FastFunctions
  49
  50 import Foreign
  51 import System.IO                ( hGetBuf, hFileSize,IOMode(ReadMode), hClose
  52                                 , Handle, hTell )
  53
  54 import GHC.Exts
  55
  56 import System.IO                ( openBinaryFile )
  57
  58 -- -----------------------------------------------------------------------------
  59 -- The StringBuffer type
  60
  61 -- |A StringBuffer is an internal pointer to a sized chunk of bytes.
  62 -- The bytes are intended to be *immutable*.  There are pure
  63 -- operations to read the contents of a StringBuffer.
  64 --
  65 -- A StringBuffer may have a finalizer, depending on how it was
  66 -- obtained.
  67 --
  68 data StringBuffer
  69  = StringBuffer {
  70      buf :: {-# UNPACK #-} !(ForeignPtr Word8),
  71      len :: {-# UNPACK #-} !Int,        -- length
  72      cur :: {-# UNPACK #-} !Int         -- current pos
  73   }
  74   -- The buffer is assumed to be UTF-8 encoded, and furthermore
  75   -- we add three '\0' bytes to the end as sentinels so that the
  76   -- decoder doesn't have to check for overflow at every single byte
  77   -- of a multibyte sequence.
  78
  79 instance Show StringBuffer where
  80         showsPrec _ s = showString "<stringbuffer("
  81                       . shows (len s) . showString "," . shows (cur s)
  82                       . showString ")>"
  83
  84 -- -----------------------------------------------------------------------------
  85 -- Creation / Destruction
  86
  87 hGetStringBuffer :: FilePath -> IO StringBuffer
  88 hGetStringBuffer fname = do
  89    h <- openBinaryFile fname ReadMode
  90    size_i <- hFileSize h
  91    let size = fromIntegral size_i
  92    buf <- mallocForeignPtrArray (size+3)
  93    withForeignPtr buf $ \ptr -> do
  94      r <- if size == 0 then return 0 else hGetBuf h ptr size
  95      hClose h
  96      if (r /= size)
  97         then ioError (userError "short read of file")
  98         else newUTF8StringBuffer buf ptr size
  99
 100 hGetStringBufferBlock :: Handle -> Int -> IO StringBuffer
 101 hGetStringBufferBlock handle wanted
 102     = do size_i <- hFileSize handle
 103          offset_i <- hTell handle
 104          let size = min wanted (fromIntegral $ size_i-offset_i)
 105          buf <- mallocForeignPtrArray (size+3)
 106          withForeignPtr buf $ \ptr ->
 107              do r <- if size == 0 then return 0 else hGetBuf handle ptr size
 108                 if r /= size
 109                    then ioError (userError $ "short read of file: "++show(r,size,size_i,handle))
 110                    else newUTF8StringBuffer buf ptr size
 111
 112 newUTF8StringBuffer :: ForeignPtr Word8 -> Ptr Word8 -> Int -> IO StringBuffer
 113 newUTF8StringBuffer buf ptr size = do
 114   pokeArray (ptr `plusPtr` size :: Ptr Word8) [0,0,0]
 115   -- sentinels for UTF-8 decoding
 116   let
 117       sb0 = StringBuffer buf size 0
 118       (first_char, sb1) = nextChar sb0
 119         -- skip the byte-order mark if there is one (see #1744)
 120         -- This is better than treating #FEFF as whitespace,
 121         -- because that would mess up layout.  We don't have a concept
 122         -- of zero-width whitespace in Haskell: all whitespace codepoints
 123         -- have a width of one column.
 124   return (if first_char == '\xfeff' then sb1 else sb0)
 125
 126 appendStringBuffers :: StringBuffer -> StringBuffer -> IO StringBuffer
 127 appendStringBuffers sb1 sb2
 128     = do newBuf <- mallocForeignPtrArray (size+3)
 129          withForeignPtr newBuf $ \ptr ->
 130           withForeignPtr (buf sb1) $ \sb1Ptr ->
 131            withForeignPtr (buf sb2) $ \sb2Ptr ->
 132              do copyArray ptr (sb1Ptr `advancePtr` cur sb1) sb1_len
 133                 copyArray (ptr `advancePtr` sb1_len) (sb2Ptr `advancePtr` cur sb2) sb2_len
 134                 pokeArray (ptr `advancePtr` size) [0,0,0]
 135                 return (StringBuffer newBuf size 0)
 136     where sb1_len = calcLen sb1
 137           sb2_len = calcLen sb2
 138           calcLen sb = len sb - cur sb
 139           size =  sb1_len + sb2_len
 140
 141 stringToStringBuffer :: String -> StringBuffer
 142 stringToStringBuffer str =
 143  unsafePerformIO $ do
 144   let size = utf8EncodedLength str
 145   buf <- mallocForeignPtrArray (size+3)
 146   withForeignPtr buf $ \ptr -> do
 147     utf8EncodeString ptr str
 148     pokeArray (ptr `plusPtr` size :: Ptr Word8) [0,0,0]
 149     -- sentinels for UTF-8 decoding
 150   return (StringBuffer buf size 0)
 151
 152 -- -----------------------------------------------------------------------------
 153 -- Grab a character
 154
 155 -- Getting our fingers dirty a little here, but this is performance-critical
 156 {-# INLINE nextChar #-}
 157 nextChar :: StringBuffer -> (Char,StringBuffer)
 158 nextChar (StringBuffer buf len (I# cur#)) =
 159   inlinePerformIO $ do
 160     withForeignPtr buf $ \(Ptr a#) -> do
 161         case utf8DecodeChar# (a# `plusAddr#` cur#) of
 162           (# c#, b# #) ->
 163              let cur' = I# (b# `minusAddr#` a#) in
 164              return (C# c#, StringBuffer buf len cur')
 165
 166 currentChar :: StringBuffer -> Char
 167 currentChar = fst . nextChar
 168
 169 prevChar :: StringBuffer -> Char -> Char
 170 prevChar (StringBuffer _   _   0)   deflt = deflt
 171 prevChar (StringBuffer buf _   cur) _     =
 172   inlinePerformIO $ do
 173     withForeignPtr buf $ \p -> do
 174       p' <- utf8PrevChar (p `plusPtr` cur)
 175       return (fst (utf8DecodeChar p'))
 176
 177 -- -----------------------------------------------------------------------------
 178 -- Moving
 179
 180 stepOn :: StringBuffer -> StringBuffer
 181 stepOn s = snd (nextChar s)
 182
 183 offsetBytes :: Int -> StringBuffer -> StringBuffer
 184 offsetBytes i s = s { cur = cur s + i }
 185
 186 byteDiff :: StringBuffer -> StringBuffer -> Int
 187 byteDiff s1 s2 = cur s2 - cur s1
 188
 189 atEnd :: StringBuffer -> Bool
 190 atEnd (StringBuffer _ l c) = l == c
 191
 192 -- -----------------------------------------------------------------------------
 193 -- Conversion
 194
 195 lexemeToString :: StringBuffer -> Int {-bytes-} -> String
 196 lexemeToString _ 0 = ""
 197 lexemeToString (StringBuffer buf _ cur) bytes =
 198   inlinePerformIO $
 199     withForeignPtr buf $ \ptr ->
 200       utf8DecodeString (ptr `plusPtr` cur) bytes
 201
 202 lexemeToFastString :: StringBuffer -> Int {-bytes-} -> FastString
 203 lexemeToFastString _ 0 = nilFS
 204 lexemeToFastString (StringBuffer buf _ cur) len =
 205    inlinePerformIO $
 206      withForeignPtr buf $ \ptr ->
 207        return $! mkFastStringBytes (ptr `plusPtr` cur) len
 208
 209 -- -----------------------------------------------------------------------------
 210 -- Parsing integer strings in various bases
 211 {-
 212 byteOff :: StringBuffer -> Int -> Char
 213 byteOff (StringBuffer buf _ cur) i =
 214   inlinePerformIO $ withForeignPtr buf $ \ptr -> do
 215 --    return $! cBox (indexWord8OffFastPtrAsFastChar
 216 --                         (pUnbox ptr) (iUnbox (cur+i)))
 217 --or
 218 --    w <- peek (ptr `plusPtr` (cur+i))
 219 --    return (unsafeChr (fromIntegral (w::Word8)))
 220 -}
 221 -- | XXX assumes ASCII digits only (by using byteOff)
 222 parseUnsignedInteger :: StringBuffer -> Int -> Integer -> (Char->Int) -> Integer
 223 parseUnsignedInteger (StringBuffer buf _ cur) len radix char_to_int
 224   = inlinePerformIO $ withForeignPtr buf $ \ptr -> return $! let
 225     --LOL, in implementations where the indexing needs slow unsafePerformIO,
 226     --this is less (not more) efficient than using the IO monad explicitly
 227     --here.
 228     !ptr' = pUnbox ptr
 229     byteOff i = cBox (indexWord8OffFastPtrAsFastChar ptr' (iUnbox (cur + i)))
 230     go i x | i == len  = x
 231            | otherwise = case byteOff i of
 232                char -> go (i + 1) (x * radix + toInteger (char_to_int char))
 233   in go 0 0
 234
 235 \end{code}