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