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