compiler/utils/FastString.lhs

   1 %
   2 % (c) The University of Glasgow, 1997-2006
   3 %
   4 \begin{code}
   5 {-
   6 FastString:     A compact, hash-consed, representation of character strings.
   7                 Comparison is O(1), and you can get a Unique from them.
   8                 Generated by the FSLIT macro
   9                 Turn into SDoc with Outputable.ftext
  10
  11 LitString:      Just a wrapper for the Addr# of a C string (Ptr CChar).
  12                 Practically no operations
  13                 Outputing them is fast
  14                 Generated by the SLIT macro
  15                 Turn into SDoc with Outputable.ptext
  16
  17 Use LitString unless you want the facilities of FastString
  18 -}
  19 module FastString
  20        (
  21         -- * FastStrings
  22         FastString(..),     -- not abstract, for now.
  23
  24         -- ** Construction
  25         mkFastString,
  26         mkFastStringBytes,
  27         mkFastStringByteList,
  28         mkFastStringForeignPtr,
  29         mkFastString#,
  30         mkZFastString,
  31         mkZFastStringBytes,
  32
  33         -- ** Deconstruction
  34         unpackFS,           -- :: FastString -> String
  35         bytesFS,            -- :: FastString -> [Word8]
  36
  37         -- ** Encoding
  38         isZEncoded,
  39         zEncodeFS,
  40
  41         -- ** Operations
  42         uniqueOfFS,
  43         lengthFS,
  44         nullFS,
  45         appendFS,
  46         headFS,
  47         tailFS,
  48         concatFS,
  49         consFS,
  50         nilFS,
  51
  52         -- ** Outputing
  53         hPutFS,
  54
  55         -- ** Internal
  56         getFastStringTable,
  57         hasZEncoding,
  58
  59         -- * LitStrings
  60         LitString,
  61         mkLitString#,
  62         strLength
  63        ) where
  64
  65 -- This #define suppresses the "import FastString" that
  66 -- HsVersions otherwise produces
  67 #define COMPILING_FAST_STRING
  68 #include "HsVersions.h"
  69
  70 import Encoding
  71
  72 import Foreign
  73 import Foreign.C
  74 import GHC.Exts
  75 import System.IO.Unsafe ( unsafePerformIO )
  76 import Control.Monad.ST ( stToIO )
  77 import Data.IORef       ( IORef, newIORef, readIORef, writeIORef )
  78 import System.IO        ( hPutBuf )
  79 import Data.Maybe       ( isJust )
  80
  81 import GHC.Arr          ( STArray(..), newSTArray )
  82 import GHC.IOBase       ( IO(..) )
  83 import GHC.Ptr          ( Ptr(..) )
  84
  85 #define hASH_TBL_SIZE  4091
  86
  87
  88 {-|
  89 A 'FastString' is an array of bytes, hashed to support fast O(1)
  90 comparison.  It is also associated with a character encoding, so that
  91 we know how to convert a 'FastString' to the local encoding, or to the
  92 Z-encoding used by the compiler internally.
  93
  94 'FastString's support a memoized conversion to the Z-encoding via zEncodeFS.
  95 -}
  96
  97 data FastString = FastString {
  98       uniq    :: {-# UNPACK #-} !Int,       -- unique id
  99       n_bytes :: {-# UNPACK #-} !Int,       -- number of bytes
 100       n_chars :: {-# UNPACK #-} !Int,     -- number of chars
 101       buf     :: {-# UNPACK #-} !(ForeignPtr Word8),
 102       enc     :: FSEncoding
 103   }
 104
 105 data FSEncoding
 106   = ZEncoded
 107         -- including strings that don't need any encoding
 108   | UTF8Encoded {-# UNPACK #-} !(IORef (Maybe FastString))
 109         -- A UTF-8 string with a memoized Z-encoding
 110
 111 instance Eq FastString where
 112   f1 == f2  =  uniq f1 == uniq f2
 113
 114 instance Ord FastString where
 115         -- Compares lexicographically, not by unique
 116     a <= b = case cmpFS a b of { LT -> True;  EQ -> True;  GT -> False }
 117     a <  b = case cmpFS a b of { LT -> True;  EQ -> False; GT -> False }
 118     a >= b = case cmpFS a b of { LT -> False; EQ -> True;  GT -> True  }
 119     a >  b = case cmpFS a b of { LT -> False; EQ -> False; GT -> True  }
 120     max x y | x >= y    =  x
 121             | otherwise =  y
 122     min x y | x <= y    =  x
 123             | otherwise =  y
 124     compare a b = cmpFS a b
 125
 126 instance Show FastString where
 127    show fs = show (unpackFS fs)
 128
 129 cmpFS :: FastString -> FastString -> Ordering
 130 cmpFS (FastString u1 l1 _ buf1 _) (FastString u2 l2 _ buf2 _) =
 131   if u1 == u2 then EQ else
 132   case unsafeMemcmp buf1 buf2 (min l1 l2) `compare` 0 of
 133      LT -> LT
 134      EQ -> compare l1 l2
 135      GT -> GT
 136
 137 unsafeMemcmp :: ForeignPtr a -> ForeignPtr b -> Int -> Int
 138 unsafeMemcmp buf1 buf2 l =
 139       inlinePerformIO $
 140         withForeignPtr buf1 $ \p1 ->
 141         withForeignPtr buf2 $ \p2 ->
 142           memcmp p1 p2 l
 143
 144 #ifndef __HADDOCK__
 145 foreign import ccall unsafe "ghc_memcmp"
 146   memcmp :: Ptr a -> Ptr b -> Int -> IO Int
 147 #endif
 148
 149 -- -----------------------------------------------------------------------------
 150 -- Construction
 151
 152 {-
 153 Internally, the compiler will maintain a fast string symbol
 154 table, providing sharing and fast comparison. Creation of
 155 new @FastString@s then covertly does a lookup, re-using the
 156 @FastString@ if there was a hit.
 157 -}
 158
 159 data FastStringTable =
 160  FastStringTable
 161     {-# UNPACK #-} !Int
 162     (MutableArray# RealWorld [FastString])
 163
 164 {-# NOINLINE string_table #-}
 165 string_table :: IORef FastStringTable
 166 string_table =
 167  unsafePerformIO $ do
 168    (STArray _ _ arr#) <- stToIO (newSTArray (0::Int,hASH_TBL_SIZE) [])
 169    newIORef (FastStringTable 0 arr#)
 170
 171 lookupTbl :: FastStringTable -> Int -> IO [FastString]
 172 lookupTbl (FastStringTable _ arr#) (I# i#) =
 173   IO $ \ s# -> readArray# arr# i# s#
 174
 175 updTbl :: IORef FastStringTable -> FastStringTable -> Int -> [FastString] -> IO ()
 176 updTbl fs_table_var (FastStringTable uid arr#) (I# i#) ls = do
 177   (IO $ \ s# -> case writeArray# arr# i# ls s# of { s2# -> (# s2#, () #) })
 178   writeIORef fs_table_var (FastStringTable (uid+1) arr#)
 179
 180 mkFastString# :: Addr# -> FastString
 181 mkFastString# a# = mkFastStringBytes ptr (strLength ptr)
 182   where ptr = Ptr a#
 183
 184 mkFastStringBytes :: Ptr Word8 -> Int -> FastString
 185 mkFastStringBytes ptr len = unsafePerformIO $ do
 186   ft@(FastStringTable uid tbl#) <- readIORef string_table
 187   let
 188    h = hashStr ptr len
 189    add_it ls = do
 190         fs <- copyNewFastString uid ptr len
 191         updTbl string_table ft h (fs:ls)
 192         {- _trace ("new: " ++ show f_str)   $ -}
 193         return fs
 194   --
 195   lookup_result <- lookupTbl ft h
 196   case lookup_result of
 197     [] -> add_it []
 198     ls -> do
 199        b <- bucket_match ls len ptr
 200        case b of
 201          Nothing -> add_it ls
 202          Just v  -> {- _trace ("re-use: "++show v) $ -} return v
 203
 204 mkZFastStringBytes :: Ptr Word8 -> Int -> FastString
 205 mkZFastStringBytes ptr len = unsafePerformIO $ do
 206   ft@(FastStringTable uid tbl#) <- readIORef string_table
 207   let
 208    h = hashStr ptr len
 209    add_it ls = do
 210         fs <- copyNewZFastString uid ptr len
 211         updTbl string_table ft h (fs:ls)
 212         {- _trace ("new: " ++ show f_str)   $ -}
 213         return fs
 214   --
 215   lookup_result <- lookupTbl ft h
 216   case lookup_result of
 217     [] -> add_it []
 218     ls -> do
 219        b <- bucket_match ls len ptr
 220        case b of
 221          Nothing -> add_it ls
 222          Just v  -> {- _trace ("re-use: "++show v) $ -} return v
 223
 224 -- | Create a 'FastString' from an existing 'ForeignPtr'; the difference
 225 -- between this and 'mkFastStringBytes' is that we don't have to copy
 226 -- the bytes if the string is new to the table.
 227 mkFastStringForeignPtr :: Ptr Word8 -> ForeignPtr Word8 -> Int -> IO FastString
 228 mkFastStringForeignPtr ptr fp len = do
 229   ft@(FastStringTable uid tbl#) <- readIORef string_table
 230 --  _trace ("hashed: "++show (I# h)) $
 231   let
 232     h = hashStr ptr len
 233     add_it ls = do
 234         fs <- mkNewFastString uid ptr fp len
 235         updTbl string_table ft h (fs:ls)
 236         {- _trace ("new: " ++ show f_str)   $ -}
 237         return fs
 238   --
 239   lookup_result <- lookupTbl ft h
 240   case lookup_result of
 241     [] -> add_it []
 242     ls -> do
 243        b <- bucket_match ls len ptr
 244        case b of
 245          Nothing -> add_it ls
 246          Just v  -> {- _trace ("re-use: "++show v) $ -} return v
 247
 248 mkZFastStringForeignPtr :: Ptr Word8 -> ForeignPtr Word8 -> Int -> IO FastString
 249 mkZFastStringForeignPtr ptr fp len = do
 250   ft@(FastStringTable uid tbl#) <- readIORef string_table
 251 --  _trace ("hashed: "++show (I# h)) $
 252   let
 253     h = hashStr ptr len
 254     add_it ls = do
 255         fs <- mkNewZFastString uid ptr fp len
 256         updTbl string_table ft h (fs:ls)
 257         {- _trace ("new: " ++ show f_str)   $ -}
 258         return fs
 259   --
 260   lookup_result <- lookupTbl ft h
 261   case lookup_result of
 262     [] -> add_it []
 263     ls -> do
 264        b <- bucket_match ls len ptr
 265        case b of
 266          Nothing -> add_it ls
 267          Just v  -> {- _trace ("re-use: "++show v) $ -} return v
 268
 269
 270 -- | Creates a UTF-8 encoded 'FastString' from a 'String'
 271 mkFastString :: String -> FastString
 272 mkFastString str =
 273   inlinePerformIO $ do
 274     let l = utf8EncodedLength str
 275     buf <- mallocForeignPtrBytes l
 276     withForeignPtr buf $ \ptr -> do
 277       utf8EncodeString ptr str
 278       mkFastStringForeignPtr ptr buf l
 279
 280 -- | Creates a 'FastString' from a UTF-8 encoded @[Word8]@
 281 mkFastStringByteList :: [Word8] -> FastString
 282 mkFastStringByteList str =
 283   inlinePerformIO $ do
 284     let l = Prelude.length str
 285     buf <- mallocForeignPtrBytes l
 286     withForeignPtr buf $ \ptr -> do
 287       pokeArray (castPtr ptr) str
 288       mkFastStringForeignPtr ptr buf l
 289
 290 -- | Creates a Z-encoded 'FastString' from a 'String'
 291 mkZFastString :: String -> FastString
 292 mkZFastString str =
 293   inlinePerformIO $ do
 294     let l = Prelude.length str
 295     buf <- mallocForeignPtrBytes l
 296     withForeignPtr buf $ \ptr -> do
 297       pokeCAString (castPtr ptr) str
 298       mkZFastStringForeignPtr ptr buf l
 299
 300 bucket_match [] _ _ = return Nothing
 301 bucket_match (v@(FastString _ l _ buf _):ls) len ptr
 302       | len == l  =  do
 303          b <- cmpStringPrefix ptr buf len
 304          if b then return (Just v)
 305               else bucket_match ls len ptr
 306       | otherwise =
 307          bucket_match ls len ptr
 308
 309 mkNewFastString uid ptr fp len = do
 310   ref <- newIORef Nothing
 311   n_chars <- countUTF8Chars ptr len
 312   return (FastString uid len n_chars fp (UTF8Encoded ref))
 313
 314 mkNewZFastString uid ptr fp len = do
 315   return (FastString uid len len fp ZEncoded)
 316
 317
 318 copyNewFastString uid ptr len = do
 319   fp <- copyBytesToForeignPtr ptr len
 320   ref <- newIORef Nothing
 321   n_chars <- countUTF8Chars ptr len
 322   return (FastString uid len n_chars fp (UTF8Encoded ref))
 323
 324 copyNewZFastString uid ptr len = do
 325   fp <- copyBytesToForeignPtr ptr len
 326   return (FastString uid len len fp ZEncoded)
 327
 328
 329 copyBytesToForeignPtr ptr len = do
 330   fp <- mallocForeignPtrBytes len
 331   withForeignPtr fp $ \ptr' -> copyBytes ptr' ptr len
 332   return fp
 333
 334 cmpStringPrefix :: Ptr Word8 -> ForeignPtr Word8 -> Int -> IO Bool
 335 cmpStringPrefix ptr fp len =
 336   withForeignPtr fp $ \ptr' -> do
 337     r <- memcmp ptr ptr' len
 338     return (r == 0)
 339
 340
 341 hashStr  :: Ptr Word8 -> Int -> Int
 342  -- use the Addr to produce a hash value between 0 & m (inclusive)
 343 hashStr (Ptr a#) (I# len#) = loop 0# 0#
 344    where
 345     loop h n | n ==# len# = I# h
 346              | otherwise  = loop h2 (n +# 1#)
 347           where c = ord# (indexCharOffAddr# a# n)
 348                 h2 = (c +# (h *# 128#)) `remInt#` hASH_TBL_SIZE#
 349
 350 -- -----------------------------------------------------------------------------
 351 -- Operations
 352
 353 -- | Returns the length of the 'FastString' in characters
 354 lengthFS :: FastString -> Int
 355 lengthFS f = n_chars f
 356
 357 -- | Returns 'True' if the 'FastString' is Z-encoded
 358 isZEncoded :: FastString -> Bool
 359 isZEncoded fs | ZEncoded <- enc fs = True
 360                 | otherwise          = False
 361
 362 -- | Returns 'True' if this 'FastString' is not Z-encoded but already has
 363 -- a Z-encoding cached (used in producing stats).
 364 hasZEncoding :: FastString -> Bool
 365 hasZEncoding fs@(FastString uid n_bytes _ fp enc) =
 366   case enc of
 367     ZEncoded -> False
 368     UTF8Encoded ref ->
 369       inlinePerformIO $ do
 370         m <- readIORef ref
 371         return (isJust m)
 372
 373 -- | Returns 'True' if the 'FastString' is empty
 374 nullFS :: FastString -> Bool
 375 nullFS f  =  n_bytes f == 0
 376
 377 -- | unpacks and decodes the FastString
 378 unpackFS :: FastString -> String
 379 unpackFS (FastString _ n_bytes _ buf enc) =
 380   inlinePerformIO $ withForeignPtr buf $ \ptr ->
 381     case enc of
 382         ZEncoded      -> peekCAStringLen (castPtr ptr,n_bytes)
 383         UTF8Encoded _ -> utf8DecodeString ptr n_bytes
 384
 385 bytesFS :: FastString -> [Word8]
 386 bytesFS (FastString _ n_bytes _ buf enc) =
 387   inlinePerformIO $ withForeignPtr buf $ \ptr ->
 388     peekArray n_bytes ptr
 389
 390 -- | returns a Z-encoded version of a 'FastString'.  This might be the
 391 -- original, if it was already Z-encoded.  The first time this
 392 -- function is applied to a particular 'FastString', the results are
 393 -- memoized.
 394 --
 395 zEncodeFS :: FastString -> FastString
 396 zEncodeFS fs@(FastString uid n_bytes _ fp enc) =
 397   case enc of
 398     ZEncoded -> fs
 399     UTF8Encoded ref ->
 400       inlinePerformIO $ do
 401         m <- readIORef ref
 402         case m of
 403           Just fs -> return fs
 404           Nothing -> do
 405             let efs = mkZFastString (zEncodeString (unpackFS fs))
 406             writeIORef ref (Just efs)
 407             return efs
 408
 409 appendFS :: FastString -> FastString -> FastString
 410 appendFS fs1 fs2 = mkFastString (unpackFS fs1 ++ unpackFS fs2)
 411
 412 concatFS :: [FastString] -> FastString
 413 concatFS ls = mkFastString (Prelude.concat (map unpackFS ls)) -- ToDo: do better
 414
 415 headFS :: FastString -> Char
 416 headFS (FastString _ n_bytes _ buf enc) =
 417   inlinePerformIO $ withForeignPtr buf $ \ptr -> do
 418     case enc of
 419       ZEncoded -> do
 420          w <- peek (castPtr ptr)
 421          return (castCCharToChar w)
 422       UTF8Encoded _ ->
 423          return (fst (utf8DecodeChar ptr))
 424
 425 tailFS :: FastString -> FastString
 426 tailFS (FastString _ n_bytes _ buf enc) =
 427   inlinePerformIO $ withForeignPtr buf $ \ptr -> do
 428     case enc of
 429       ZEncoded -> do
 430         return $! mkZFastStringBytes (ptr `plusPtr` 1) (n_bytes - 1)
 431       UTF8Encoded _ -> do
 432          let (_,ptr') = utf8DecodeChar ptr
 433          let off = ptr' `minusPtr` ptr
 434          return $! mkFastStringBytes (ptr `plusPtr` off) (n_bytes - off)
 435
 436 consFS :: Char -> FastString -> FastString
 437 consFS c fs = mkFastString (c : unpackFS fs)
 438
 439 uniqueOfFS :: FastString -> Int#
 440 uniqueOfFS (FastString (I# u#) _ _ _ _) = u#
 441
 442 nilFS = mkFastString ""
 443
 444 -- -----------------------------------------------------------------------------
 445 -- Stats
 446
 447 getFastStringTable :: IO [[FastString]]
 448 getFastStringTable = do
 449   tbl <- readIORef string_table
 450   buckets <- mapM (lookupTbl tbl) [0 .. hASH_TBL_SIZE]
 451   return buckets
 452
 453 -- -----------------------------------------------------------------------------
 454 -- Outputting 'FastString's
 455
 456 -- |Outputs a 'FastString' with /no decoding at all/, that is, you
 457 -- get the actual bytes in the 'FastString' written to the 'Handle'.
 458 hPutFS handle (FastString _ len _ fp _)
 459   | len == 0  = return ()
 460   | otherwise = do withForeignPtr fp $ \ptr -> hPutBuf handle ptr len
 461
 462 -- ToDo: we'll probably want an hPutFSLocal, or something, to output
 463 -- in the current locale's encoding (for error messages and suchlike).
 464
 465 -- -----------------------------------------------------------------------------
 466 -- LitStrings, here for convenience only.
 467
 468 type LitString = Ptr ()
 469
 470 mkLitString# :: Addr# -> LitString
 471 mkLitString# a# = Ptr a#
 472
 473 foreign import ccall unsafe "ghc_strlen"
 474   strLength :: Ptr () -> Int
 475
 476 -- -----------------------------------------------------------------------------
 477 -- under the carpet
 478
 479 -- Just like unsafePerformIO, but we inline it.
 480 {-# INLINE inlinePerformIO #-}
 481 inlinePerformIO :: IO a -> a
 482 inlinePerformIO (IO m) = case m realWorld# of (# _, r #)   -> r
 483
 484 -- NB. does *not* add a '\0'-terminator.
 485 pokeCAString :: Ptr CChar -> String -> IO ()
 486 pokeCAString ptr str =
 487   let
 488         go [] n     = return ()
 489         go (c:cs) n = do pokeElemOff ptr n (castCharToCChar c); go cs (n+1)
 490   in
 491   go str 0
 492
 493 #if __GLASGOW_HASKELL__ <= 602
 494 peekCAStringLen = peekCStringLen
 495 #endif
 496 \end{code}