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   let l = if l1 <= l2 then l1 else l2 in
 133   inlinePerformIO $
 134     withForeignPtr buf1 $ \p1 ->
 135     withForeignPtr buf2 $ \p2 -> do
 136       res <- memcmp p1 p2 l
 137       case () of
 138        _ | res <  0  -> return LT
 139          | res == 0  -> if l1 == l2 then return EQ
 140                                     else if l1 < l2 then return LT
 141                                                     else return GT
 142          | otherwise -> return GT
 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 string_table :: IORef FastStringTable
 165 string_table =
 166  unsafePerformIO $ do
 167    (STArray _ _ arr#) <- stToIO (newSTArray (0::Int,hASH_TBL_SIZE) [])
 168    newIORef (FastStringTable 0 arr#)
 169
 170 lookupTbl :: FastStringTable -> Int -> IO [FastString]
 171 lookupTbl (FastStringTable _ arr#) (I# i#) =
 172   IO $ \ s# -> readArray# arr# i# s#
 173
 174 updTbl :: IORef FastStringTable -> FastStringTable -> Int -> [FastString] -> IO ()
 175 updTbl fs_table_var (FastStringTable uid arr#) (I# i#) ls = do
 176   (IO $ \ s# -> case writeArray# arr# i# ls s# of { s2# -> (# s2#, () #) })
 177   writeIORef fs_table_var (FastStringTable (uid+1) arr#)
 178
 179 mkFastString# :: Addr# -> FastString
 180 mkFastString# a# = mkFastStringBytes ptr (strLength ptr)
 181   where ptr = Ptr a#
 182
 183 mkFastStringBytes :: Ptr Word8 -> Int -> FastString
 184 mkFastStringBytes ptr len = unsafePerformIO $ do
 185   ft@(FastStringTable uid tbl#) <- readIORef string_table
 186   let
 187    h = hashStr ptr len
 188    add_it ls = do
 189         fs <- copyNewFastString uid ptr len
 190         updTbl string_table ft h (fs:ls)
 191         {- _trace ("new: " ++ show f_str)   $ -}
 192         return fs
 193   --
 194   lookup_result <- lookupTbl ft h
 195   case lookup_result of
 196     [] -> add_it []
 197     ls -> do
 198        b <- bucket_match ls len ptr
 199        case b of
 200          Nothing -> add_it ls
 201          Just v  -> {- _trace ("re-use: "++show v) $ -} return v
 202
 203 mkZFastStringBytes :: Ptr Word8 -> Int -> FastString
 204 mkZFastStringBytes ptr len = unsafePerformIO $ do
 205   ft@(FastStringTable uid tbl#) <- readIORef string_table
 206   let
 207    h = hashStr ptr len
 208    add_it ls = do
 209         fs <- copyNewZFastString uid ptr len
 210         updTbl string_table ft h (fs:ls)
 211         {- _trace ("new: " ++ show f_str)   $ -}
 212         return fs
 213   --
 214   lookup_result <- lookupTbl ft h
 215   case lookup_result of
 216     [] -> add_it []
 217     ls -> do
 218        b <- bucket_match ls len ptr
 219        case b of
 220          Nothing -> add_it ls
 221          Just v  -> {- _trace ("re-use: "++show v) $ -} return v
 222
 223 -- | Create a 'FastString' from an existing 'ForeignPtr'; the difference
 224 -- between this and 'mkFastStringBytes' is that we don't have to copy
 225 -- the bytes if the string is new to the table.
 226 mkFastStringForeignPtr :: Ptr Word8 -> ForeignPtr Word8 -> Int -> IO FastString
 227 mkFastStringForeignPtr ptr fp len = do
 228   ft@(FastStringTable uid tbl#) <- readIORef string_table
 229 --  _trace ("hashed: "++show (I# h)) $
 230   let
 231     h = hashStr ptr len
 232     add_it ls = do
 233         fs <- mkNewFastString uid ptr fp len
 234         updTbl string_table ft h (fs:ls)
 235         {- _trace ("new: " ++ show f_str)   $ -}
 236         return fs
 237   --
 238   lookup_result <- lookupTbl ft h
 239   case lookup_result of
 240     [] -> add_it []
 241     ls -> do
 242        b <- bucket_match ls len ptr
 243        case b of
 244          Nothing -> add_it ls
 245          Just v  -> {- _trace ("re-use: "++show v) $ -} return v
 246
 247 mkZFastStringForeignPtr :: Ptr Word8 -> ForeignPtr Word8 -> Int -> IO FastString
 248 mkZFastStringForeignPtr ptr fp len = do
 249   ft@(FastStringTable uid tbl#) <- readIORef string_table
 250 --  _trace ("hashed: "++show (I# h)) $
 251   let
 252     h = hashStr ptr len
 253     add_it ls = do
 254         fs <- mkNewZFastString uid ptr fp len
 255         updTbl string_table ft h (fs:ls)
 256         {- _trace ("new: " ++ show f_str)   $ -}
 257         return fs
 258   --
 259   lookup_result <- lookupTbl ft h
 260   case lookup_result of
 261     [] -> add_it []
 262     ls -> do
 263        b <- bucket_match ls len ptr
 264        case b of
 265          Nothing -> add_it ls
 266          Just v  -> {- _trace ("re-use: "++show v) $ -} return v
 267
 268
 269 -- | Creates a UTF-8 encoded 'FastString' from a 'String'
 270 mkFastString :: String -> FastString
 271 mkFastString str =
 272   inlinePerformIO $ do
 273     let l = utf8EncodedLength str
 274     buf <- mallocForeignPtrBytes l
 275     withForeignPtr buf $ \ptr -> do
 276       utf8EncodeString ptr str
 277       mkFastStringForeignPtr ptr buf l
 278
 279 -- | Creates a 'FastString' from a UTF-8 encoded @[Word8]@
 280 mkFastStringByteList :: [Word8] -> FastString
 281 mkFastStringByteList str =
 282   inlinePerformIO $ do
 283     let l = Prelude.length str
 284     buf <- mallocForeignPtrBytes l
 285     withForeignPtr buf $ \ptr -> do
 286       pokeArray (castPtr ptr) str
 287       mkFastStringForeignPtr ptr buf l
 288
 289 -- | Creates a Z-encoded 'FastString' from a 'String'
 290 mkZFastString :: String -> FastString
 291 mkZFastString str =
 292   inlinePerformIO $ do
 293     let l = Prelude.length str
 294     buf <- mallocForeignPtrBytes l
 295     withForeignPtr buf $ \ptr -> do
 296       pokeCAString (castPtr ptr) str
 297       mkZFastStringForeignPtr ptr buf l
 298
 299 bucket_match [] _ _ = return Nothing
 300 bucket_match (v@(FastString _ l _ buf _):ls) len ptr
 301       | len == l  =  do
 302          b <- cmpStringPrefix ptr buf len
 303          if b then return (Just v)
 304               else bucket_match ls len ptr
 305       | otherwise =
 306          bucket_match ls len ptr
 307
 308 mkNewFastString uid ptr fp len = do
 309   ref <- newIORef Nothing
 310   n_chars <- countUTF8Chars ptr len
 311   return (FastString uid len n_chars fp (UTF8Encoded ref))
 312
 313 mkNewZFastString uid ptr fp len = do
 314   return (FastString uid len len fp ZEncoded)
 315
 316
 317 copyNewFastString uid ptr len = do
 318   fp <- copyBytesToForeignPtr ptr len
 319   ref <- newIORef Nothing
 320   n_chars <- countUTF8Chars ptr len
 321   return (FastString uid len n_chars fp (UTF8Encoded ref))
 322
 323 copyNewZFastString uid ptr len = do
 324   fp <- copyBytesToForeignPtr ptr len
 325   return (FastString uid len len fp ZEncoded)
 326
 327
 328 copyBytesToForeignPtr ptr len = do
 329   fp <- mallocForeignPtrBytes len
 330   withForeignPtr fp $ \ptr' -> copyBytes ptr' ptr len
 331   return fp
 332
 333 cmpStringPrefix :: Ptr Word8 -> ForeignPtr Word8 -> Int -> IO Bool
 334 cmpStringPrefix ptr fp len =
 335   withForeignPtr fp $ \ptr' -> do
 336     r <- memcmp ptr ptr' len
 337     return (r == 0)
 338
 339
 340 hashStr  :: Ptr Word8 -> Int -> Int
 341  -- use the Addr to produce a hash value between 0 & m (inclusive)
 342 hashStr (Ptr a#) (I# len#) = loop 0# 0#
 343    where
 344     loop h n | n ==# len# = I# h
 345              | otherwise  = loop h2 (n +# 1#)
 346           where c = ord# (indexCharOffAddr# a# n)
 347                 h2 = (c +# (h *# 128#)) `remInt#` hASH_TBL_SIZE#
 348
 349 -- -----------------------------------------------------------------------------
 350 -- Operations
 351
 352 -- | Returns the length of the 'FastString' in characters
 353 lengthFS :: FastString -> Int
 354 lengthFS f = n_chars f
 355
 356 -- | Returns 'True' if the 'FastString' is Z-encoded
 357 isZEncoded :: FastString -> Bool
 358 isZEncoded fs | ZEncoded <- enc fs = True
 359                 | otherwise          = False
 360
 361 -- | Returns 'True' if this 'FastString' is not Z-encoded but already has
 362 -- a Z-encoding cached (used in producing stats).
 363 hasZEncoding :: FastString -> Bool
 364 hasZEncoding fs@(FastString uid n_bytes _ fp enc) =
 365   case enc of
 366     ZEncoded -> False
 367     UTF8Encoded ref ->
 368       inlinePerformIO $ do
 369         m <- readIORef ref
 370         return (isJust m)
 371
 372 -- | Returns 'True' if the 'FastString' is empty
 373 nullFS :: FastString -> Bool
 374 nullFS f  =  n_bytes f == 0
 375
 376 -- | unpacks and decodes the FastString
 377 unpackFS :: FastString -> String
 378 unpackFS (FastString _ n_bytes _ buf enc) =
 379   inlinePerformIO $ withForeignPtr buf $ \ptr ->
 380     case enc of
 381         ZEncoded      -> peekCAStringLen (castPtr ptr,n_bytes)
 382         UTF8Encoded _ -> utf8DecodeString ptr n_bytes
 383
 384 bytesFS :: FastString -> [Word8]
 385 bytesFS (FastString _ n_bytes _ buf enc) =
 386   inlinePerformIO $ withForeignPtr buf $ \ptr ->
 387     peekArray n_bytes ptr
 388
 389 -- | returns a Z-encoded version of a 'FastString'.  This might be the
 390 -- original, if it was already Z-encoded.  The first time this
 391 -- function is applied to a particular 'FastString', the results are
 392 -- memoized.
 393 --
 394 zEncodeFS :: FastString -> FastString
 395 zEncodeFS fs@(FastString uid n_bytes _ fp enc) =
 396   case enc of
 397     ZEncoded -> fs
 398     UTF8Encoded ref ->
 399       inlinePerformIO $ do
 400         m <- readIORef ref
 401         case m of
 402           Just fs -> return fs
 403           Nothing -> do
 404             let efs = mkZFastString (zEncodeString (unpackFS fs))
 405             writeIORef ref (Just efs)
 406             return efs
 407
 408 appendFS :: FastString -> FastString -> FastString
 409 appendFS fs1 fs2 = mkFastString (unpackFS fs1 ++ unpackFS fs2)
 410
 411 concatFS :: [FastString] -> FastString
 412 concatFS ls = mkFastString (Prelude.concat (map unpackFS ls)) -- ToDo: do better
 413
 414 headFS :: FastString -> Char
 415 headFS (FastString _ n_bytes _ buf enc) =
 416   inlinePerformIO $ withForeignPtr buf $ \ptr -> do
 417     case enc of
 418       ZEncoded -> do
 419          w <- peek (castPtr ptr)
 420          return (castCCharToChar w)
 421       UTF8Encoded _ ->
 422          return (fst (utf8DecodeChar ptr))
 423
 424 tailFS :: FastString -> FastString
 425 tailFS (FastString _ n_bytes _ buf enc) =
 426   inlinePerformIO $ withForeignPtr buf $ \ptr -> do
 427     case enc of
 428       ZEncoded -> do
 429         return $! mkZFastStringBytes (ptr `plusPtr` 1) (n_bytes - 1)
 430       UTF8Encoded _ -> do
 431          let (_,ptr') = utf8DecodeChar ptr
 432          let off = ptr' `minusPtr` ptr
 433          return $! mkFastStringBytes (ptr `plusPtr` off) (n_bytes - off)
 434
 435 consFS :: Char -> FastString -> FastString
 436 consFS c fs = mkFastString (c : unpackFS fs)
 437
 438 uniqueOfFS :: FastString -> Int#
 439 uniqueOfFS (FastString (I# u#) _ _ _ _) = u#
 440
 441 nilFS = mkFastString ""
 442
 443 -- -----------------------------------------------------------------------------
 444 -- Stats
 445
 446 getFastStringTable :: IO [[FastString]]
 447 getFastStringTable = do
 448   tbl <- readIORef string_table
 449   buckets <- mapM (lookupTbl tbl) [0 .. hASH_TBL_SIZE]
 450   return buckets
 451
 452 -- -----------------------------------------------------------------------------
 453 -- Outputting 'FastString's
 454
 455 -- |Outputs a 'FastString' with /no decoding at all/, that is, you
 456 -- get the actual bytes in the 'FastString' written to the 'Handle'.
 457 hPutFS handle (FastString _ len _ fp _)
 458   | len == 0  = return ()
 459   | otherwise = do withForeignPtr fp $ \ptr -> hPutBuf handle ptr len
 460
 461 -- ToDo: we'll probably want an hPutFSLocal, or something, to output
 462 -- in the current locale's encoding (for error messages and suchlike).
 463
 464 -- -----------------------------------------------------------------------------
 465 -- LitStrings, here for convenience only.
 466
 467 type LitString = Ptr ()
 468
 469 mkLitString# :: Addr# -> LitString
 470 mkLitString# a# = Ptr a#
 471
 472 foreign import ccall unsafe "ghc_strlen"
 473   strLength :: Ptr () -> Int
 474
 475 -- -----------------------------------------------------------------------------
 476 -- under the carpet
 477
 478 -- Just like unsafePerformIO, but we inline it.
 479 {-# INLINE inlinePerformIO #-}
 480 inlinePerformIO :: IO a -> a
 481 inlinePerformIO (IO m) = case m realWorld# of (# _, r #)   -> r
 482
 483 -- NB. does *not* add a '\0'-terminator.
 484 pokeCAString :: Ptr CChar -> String -> IO ()
 485 pokeCAString ptr str =
 486   let
 487         go [] n     = return ()
 488         go (c:cs) n = do pokeElemOff ptr n (castCharToCChar c); go cs (n+1)
 489   in
 490   go str 0
 491
 492 #if __GLASGOW_HASKELL__ < 600
 493
 494 mallocForeignPtrBytes :: Int -> IO (ForeignPtr a)
 495 mallocForeignPtrBytes n = do
 496   r <- mallocBytes n
 497   newForeignPtr r (finalizerFree r)
 498
 499 foreign import ccall unsafe "stdlib.h free"
 500   finalizerFree :: Ptr a -> IO ()
 501
 502 peekCAStringLen = peekCStringLen
 503
 504 #elif __GLASGOW_HASKELL__ <= 602
 505
 506 peekCAStringLen = peekCStringLen
 507
 508 #endif
 509 \end{code}