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 fsLit
   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 sLit
  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 #if defined(__GLASGOW_HASKELL__)
  30         mkFastString#,
  31 #endif
  32         mkZFastString,
  33         mkZFastStringBytes,
  34
  35         -- ** Deconstruction
  36         unpackFS,           -- :: FastString -> String
  37         bytesFS,            -- :: FastString -> [Word8]
  38
  39         -- ** Encoding
  40         isZEncoded,
  41         zEncodeFS,
  42
  43         -- ** Operations
  44         uniqueOfFS,
  45         lengthFS,
  46         nullFS,
  47         appendFS,
  48         headFS,
  49         tailFS,
  50         concatFS,
  51         consFS,
  52         nilFS,
  53
  54         -- ** Outputing
  55         hPutFS,
  56
  57         -- ** Internal
  58         getFastStringTable,
  59         hasZEncoding,
  60
  61         -- * LitStrings
  62         LitString,
  63 #if defined(__GLASGOW_HASKELL__)
  64         mkLitString#,
  65 #endif
  66         mkLitString,
  67         unpackLitString,
  68         strLength,
  69
  70         ptrStrLength,
  71
  72         sLit,
  73         fsLit,
  74        ) where
  75
  76 #include "HsVersions.h"
  77
  78 import Encoding
  79 import FastTypes
  80 import FastFunctions
  81 import Panic
  82
  83 import Foreign
  84 import Foreign.C
  85 import GHC.Exts
  86 import System.IO
  87 import System.IO.Unsafe ( unsafePerformIO )
  88 import Data.IORef       ( IORef, newIORef, readIORef, writeIORef )
  89 import Data.Maybe       ( isJust )
  90 import Data.Char        ( ord )
  91
  92 import GHC.IOBase       ( IO(..) )
  93 import GHC.Ptr          ( Ptr(..) )
  94 #if defined(__GLASGOW_HASKELL__)
  95 import GHC.Base         ( unpackCString# )
  96 #endif
  97
  98 #define hASH_TBL_SIZE          4091
  99 #define hASH_TBL_SIZE_UNBOXED  4091#
 100
 101
 102 {-|
 103 A 'FastString' is an array of bytes, hashed to support fast O(1)
 104 comparison.  It is also associated with a character encoding, so that
 105 we know how to convert a 'FastString' to the local encoding, or to the
 106 Z-encoding used by the compiler internally.
 107
 108 'FastString's support a memoized conversion to the Z-encoding via zEncodeFS.
 109 -}
 110
 111 data FastString = FastString {
 112       uniq    :: {-# UNPACK #-} !Int, -- unique id
 113       n_bytes :: {-# UNPACK #-} !Int, -- number of bytes
 114       n_chars :: {-# UNPACK #-} !Int, -- number of chars
 115       buf     :: {-# UNPACK #-} !(ForeignPtr Word8),
 116       enc     :: FSEncoding
 117   }
 118
 119 data FSEncoding
 120     -- including strings that don't need any encoding
 121   = ZEncoded
 122     -- A UTF-8 string with a memoized Z-encoding
 123   | UTF8Encoded {-# UNPACK #-} !(IORef (Maybe FastString))
 124
 125 instance Eq FastString where
 126   f1 == f2  =  uniq f1 == uniq f2
 127
 128 instance Ord FastString where
 129     -- Compares lexicographically, not by unique
 130     a <= b = case cmpFS a b of { LT -> True;  EQ -> True;  GT -> False }
 131     a <  b = case cmpFS a b of { LT -> True;  EQ -> False; GT -> False }
 132     a >= b = case cmpFS a b of { LT -> False; EQ -> True;  GT -> True  }
 133     a >  b = case cmpFS a b of { LT -> False; EQ -> False; GT -> True  }
 134     max x y | x >= y    =  x
 135             | otherwise =  y
 136     min x y | x <= y    =  x
 137             | otherwise =  y
 138     compare a b = cmpFS a b
 139
 140 instance Show FastString where
 141    show fs = show (unpackFS fs)
 142
 143 cmpFS :: FastString -> FastString -> Ordering
 144 cmpFS (FastString u1 l1 _ buf1 _) (FastString u2 l2 _ buf2 _) =
 145   if u1 == u2 then EQ else
 146   case unsafeMemcmp buf1 buf2 (min l1 l2) `compare` 0 of
 147      LT -> LT
 148      EQ -> compare l1 l2
 149      GT -> GT
 150
 151 unsafeMemcmp :: ForeignPtr a -> ForeignPtr b -> Int -> Int
 152 unsafeMemcmp buf1 buf2 l =
 153       inlinePerformIO $
 154         withForeignPtr buf1 $ \p1 ->
 155         withForeignPtr buf2 $ \p2 ->
 156           memcmp p1 p2 l
 157
 158 #ifndef __HADDOCK__
 159 foreign import ccall unsafe "ghc_memcmp"
 160   memcmp :: Ptr a -> Ptr b -> Int -> IO Int
 161 #endif
 162
 163 -- -----------------------------------------------------------------------------
 164 -- Construction
 165
 166 {-
 167 Internally, the compiler will maintain a fast string symbol
 168 table, providing sharing and fast comparison. Creation of
 169 new @FastString@s then covertly does a lookup, re-using the
 170 @FastString@ if there was a hit.
 171 -}
 172
 173 data FastStringTable =
 174  FastStringTable
 175     {-# UNPACK #-} !Int
 176     (MutableArray# RealWorld [FastString])
 177
 178 {-# NOINLINE string_table #-}
 179 string_table :: IORef FastStringTable
 180 string_table =
 181  unsafePerformIO $ do
 182    tab <- IO $ \s1# -> case newArray# hASH_TBL_SIZE_UNBOXED [] s1# of
 183                            (# s2#, arr# #) ->
 184                                (# s2#, FastStringTable 0 arr# #)
 185    newIORef tab
 186
 187 lookupTbl :: FastStringTable -> Int -> IO [FastString]
 188 lookupTbl (FastStringTable _ arr#) (I# i#) =
 189   IO $ \ s# -> readArray# arr# i# s#
 190
 191 updTbl :: IORef FastStringTable -> FastStringTable -> Int -> [FastString] -> IO ()
 192 updTbl fs_table_var (FastStringTable uid arr#) (I# i#) ls = do
 193   (IO $ \ s# -> case writeArray# arr# i# ls s# of { s2# -> (# s2#, () #) })
 194   writeIORef fs_table_var (FastStringTable (uid+1) arr#)
 195
 196 mkFastString# :: Addr# -> FastString
 197 mkFastString# a# = mkFastStringBytes ptr (ptrStrLength ptr)
 198   where ptr = Ptr a#
 199
 200 mkFastStringBytes :: Ptr Word8 -> Int -> FastString
 201 mkFastStringBytes ptr len = unsafePerformIO $ do
 202   ft@(FastStringTable uid _) <- readIORef string_table
 203   let
 204    h = hashStr ptr len
 205    add_it ls = do
 206         fs <- copyNewFastString uid ptr len
 207         updTbl string_table ft h (fs:ls)
 208         {- _trace ("new: " ++ show f_str)   $ -}
 209         return fs
 210   --
 211   lookup_result <- lookupTbl ft h
 212   case lookup_result of
 213     [] -> add_it []
 214     ls -> do
 215        b <- bucket_match ls len ptr
 216        case b of
 217          Nothing -> add_it ls
 218          Just v  -> {- _trace ("re-use: "++show v) $ -} return v
 219
 220 mkZFastStringBytes :: Ptr Word8 -> Int -> FastString
 221 mkZFastStringBytes ptr len = unsafePerformIO $ do
 222   ft@(FastStringTable uid _) <- readIORef string_table
 223   let
 224    h = hashStr ptr len
 225    add_it ls = do
 226         fs <- copyNewZFastString uid ptr len
 227         updTbl string_table ft h (fs:ls)
 228         {- _trace ("new: " ++ show f_str)   $ -}
 229         return fs
 230   --
 231   lookup_result <- lookupTbl ft h
 232   case lookup_result of
 233     [] -> add_it []
 234     ls -> do
 235        b <- bucket_match ls len ptr
 236        case b of
 237          Nothing -> add_it ls
 238          Just v  -> {- _trace ("re-use: "++show v) $ -} return v
 239
 240 -- | Create a 'FastString' from an existing 'ForeignPtr'; the difference
 241 -- between this and 'mkFastStringBytes' is that we don't have to copy
 242 -- the bytes if the string is new to the table.
 243 mkFastStringForeignPtr :: Ptr Word8 -> ForeignPtr Word8 -> Int -> IO FastString
 244 mkFastStringForeignPtr ptr fp len = do
 245   ft@(FastStringTable uid _) <- readIORef string_table
 246 --  _trace ("hashed: "++show (I# h)) $
 247   let
 248     h = hashStr ptr len
 249     add_it ls = do
 250         fs <- mkNewFastString uid ptr fp len
 251         updTbl string_table ft h (fs:ls)
 252         {- _trace ("new: " ++ show f_str)   $ -}
 253         return fs
 254   --
 255   lookup_result <- lookupTbl ft h
 256   case lookup_result of
 257     [] -> add_it []
 258     ls -> do
 259        b <- bucket_match ls len ptr
 260        case b of
 261          Nothing -> add_it ls
 262          Just v  -> {- _trace ("re-use: "++show v) $ -} return v
 263
 264 mkZFastStringForeignPtr :: Ptr Word8 -> ForeignPtr Word8 -> Int -> IO FastString
 265 mkZFastStringForeignPtr ptr fp len = do
 266   ft@(FastStringTable uid _) <- readIORef string_table
 267 --  _trace ("hashed: "++show (I# h)) $
 268   let
 269     h = hashStr ptr len
 270     add_it ls = do
 271         fs <- mkNewZFastString uid ptr fp len
 272         updTbl string_table ft h (fs:ls)
 273         {- _trace ("new: " ++ show f_str)   $ -}
 274         return fs
 275   --
 276   lookup_result <- lookupTbl ft h
 277   case lookup_result of
 278     [] -> add_it []
 279     ls -> do
 280        b <- bucket_match ls len ptr
 281        case b of
 282          Nothing -> add_it ls
 283          Just v  -> {- _trace ("re-use: "++show v) $ -} return v
 284
 285
 286 -- | Creates a UTF-8 encoded 'FastString' from a 'String'
 287 mkFastString :: String -> FastString
 288 mkFastString str =
 289   inlinePerformIO $ do
 290     let l = utf8EncodedLength str
 291     buf <- mallocForeignPtrBytes l
 292     withForeignPtr buf $ \ptr -> do
 293       utf8EncodeString ptr str
 294       mkFastStringForeignPtr ptr buf l
 295
 296 -- | Creates a 'FastString' from a UTF-8 encoded @[Word8]@
 297 mkFastStringByteList :: [Word8] -> FastString
 298 mkFastStringByteList str =
 299   inlinePerformIO $ do
 300     let l = Prelude.length str
 301     buf <- mallocForeignPtrBytes l
 302     withForeignPtr buf $ \ptr -> do
 303       pokeArray (castPtr ptr) str
 304       mkFastStringForeignPtr ptr buf l
 305
 306 -- | Creates a Z-encoded 'FastString' from a 'String'
 307 mkZFastString :: String -> FastString
 308 mkZFastString str =
 309   inlinePerformIO $ do
 310     let l = Prelude.length str
 311     buf <- mallocForeignPtrBytes l
 312     withForeignPtr buf $ \ptr -> do
 313       pokeCAString (castPtr ptr) str
 314       mkZFastStringForeignPtr ptr buf l
 315
 316 bucket_match :: [FastString] -> Int -> Ptr Word8 -> IO (Maybe FastString)
 317 bucket_match [] _ _ = return Nothing
 318 bucket_match (v@(FastString _ l _ buf _):ls) len ptr
 319       | len == l  =  do
 320          b <- cmpStringPrefix ptr buf len
 321          if b then return (Just v)
 322               else bucket_match ls len ptr
 323       | otherwise =
 324          bucket_match ls len ptr
 325
 326 mkNewFastString :: Int -> Ptr Word8 -> ForeignPtr Word8 -> Int
 327                 -> IO FastString
 328 mkNewFastString uid ptr fp len = do
 329   ref <- newIORef Nothing
 330   n_chars <- countUTF8Chars ptr len
 331   return (FastString uid len n_chars fp (UTF8Encoded ref))
 332
 333 mkNewZFastString :: Int -> Ptr Word8 -> ForeignPtr Word8 -> Int
 334                  -> IO FastString
 335 mkNewZFastString uid _ fp len = do
 336   return (FastString uid len len fp ZEncoded)
 337
 338 copyNewFastString :: Int -> Ptr Word8 -> Int -> IO FastString
 339 copyNewFastString uid ptr len = do
 340   fp <- copyBytesToForeignPtr ptr len
 341   ref <- newIORef Nothing
 342   n_chars <- countUTF8Chars ptr len
 343   return (FastString uid len n_chars fp (UTF8Encoded ref))
 344
 345 copyNewZFastString :: Int -> Ptr Word8 -> Int -> IO FastString
 346 copyNewZFastString uid ptr len = do
 347   fp <- copyBytesToForeignPtr ptr len
 348   return (FastString uid len len fp ZEncoded)
 349
 350 copyBytesToForeignPtr :: Ptr Word8 -> Int -> IO (ForeignPtr Word8)
 351 copyBytesToForeignPtr ptr len = do
 352   fp <- mallocForeignPtrBytes len
 353   withForeignPtr fp $ \ptr' -> copyBytes ptr' ptr len
 354   return fp
 355
 356 cmpStringPrefix :: Ptr Word8 -> ForeignPtr Word8 -> Int -> IO Bool
 357 cmpStringPrefix ptr fp len =
 358   withForeignPtr fp $ \ptr' -> do
 359     r <- memcmp ptr ptr' len
 360     return (r == 0)
 361
 362
 363 hashStr  :: Ptr Word8 -> Int -> Int
 364  -- use the Addr to produce a hash value between 0 & m (inclusive)
 365 hashStr (Ptr a#) (I# len#) = loop 0# 0#
 366    where
 367     loop h n | n GHC.Exts.==# len# = I# h
 368              | otherwise  = loop h2 (n GHC.Exts.+# 1#)
 369           where c = ord# (indexCharOffAddr# a# n)
 370                 h2 = (c GHC.Exts.+# (h GHC.Exts.*# 128#)) `remInt#`
 371                      hASH_TBL_SIZE#
 372
 373 -- -----------------------------------------------------------------------------
 374 -- Operations
 375
 376 -- | Returns the length of the 'FastString' in characters
 377 lengthFS :: FastString -> Int
 378 lengthFS f = n_chars f
 379
 380 -- | Returns 'True' if the 'FastString' is Z-encoded
 381 isZEncoded :: FastString -> Bool
 382 isZEncoded fs | ZEncoded <- enc fs = True
 383               | otherwise          = False
 384
 385 -- | Returns 'True' if this 'FastString' is not Z-encoded but already has
 386 -- a Z-encoding cached (used in producing stats).
 387 hasZEncoding :: FastString -> Bool
 388 hasZEncoding (FastString _ _ _ _ enc) =
 389   case enc of
 390     ZEncoded -> False
 391     UTF8Encoded ref ->
 392       inlinePerformIO $ do
 393         m <- readIORef ref
 394         return (isJust m)
 395
 396 -- | Returns 'True' if the 'FastString' is empty
 397 nullFS :: FastString -> Bool
 398 nullFS f  =  n_bytes f == 0
 399
 400 -- | unpacks and decodes the FastString
 401 unpackFS :: FastString -> String
 402 unpackFS (FastString _ n_bytes _ buf enc) =
 403   inlinePerformIO $ withForeignPtr buf $ \ptr ->
 404     case enc of
 405         ZEncoded      -> peekCAStringLen (castPtr ptr,n_bytes)
 406         UTF8Encoded _ -> utf8DecodeString ptr n_bytes
 407
 408 bytesFS :: FastString -> [Word8]
 409 bytesFS (FastString _ n_bytes _ buf _) =
 410   inlinePerformIO $ withForeignPtr buf $ \ptr ->
 411     peekArray n_bytes ptr
 412
 413 -- | returns a Z-encoded version of a 'FastString'.  This might be the
 414 -- original, if it was already Z-encoded.  The first time this
 415 -- function is applied to a particular 'FastString', the results are
 416 -- memoized.
 417 --
 418 zEncodeFS :: FastString -> FastString
 419 zEncodeFS fs@(FastString _ _ _ _ enc) =
 420   case enc of
 421     ZEncoded -> fs
 422     UTF8Encoded ref ->
 423       inlinePerformIO $ do
 424         m <- readIORef ref
 425         case m of
 426           Just fs -> return fs
 427           Nothing -> do
 428             let efs = mkZFastString (zEncodeString (unpackFS fs))
 429             writeIORef ref (Just efs)
 430             return efs
 431
 432 appendFS :: FastString -> FastString -> FastString
 433 appendFS fs1 fs2 = mkFastString (unpackFS fs1 ++ unpackFS fs2)
 434
 435 concatFS :: [FastString] -> FastString
 436 concatFS ls = mkFastString (Prelude.concat (map unpackFS ls)) -- ToDo: do better
 437
 438 headFS :: FastString -> Char
 439 headFS (FastString _ 0 _ _ _) = panic "headFS: Empty FastString"
 440 headFS (FastString _ _ _ buf enc) =
 441   inlinePerformIO $ withForeignPtr buf $ \ptr -> do
 442     case enc of
 443       ZEncoded -> do
 444          w <- peek (castPtr ptr)
 445          return (castCCharToChar w)
 446       UTF8Encoded _ ->
 447          return (fst (utf8DecodeChar ptr))
 448
 449 tailFS :: FastString -> FastString
 450 tailFS (FastString _ 0 _ _ _) = panic "tailFS: Empty FastString"
 451 tailFS (FastString _ n_bytes _ buf enc) =
 452   inlinePerformIO $ withForeignPtr buf $ \ptr -> do
 453     case enc of
 454       ZEncoded -> do
 455         return $! mkZFastStringBytes (ptr `plusPtr` 1) (n_bytes - 1)
 456       UTF8Encoded _ -> do
 457          let (_,ptr') = utf8DecodeChar ptr
 458          let off = ptr' `minusPtr` ptr
 459          return $! mkFastStringBytes (ptr `plusPtr` off) (n_bytes - off)
 460
 461 consFS :: Char -> FastString -> FastString
 462 consFS c fs = mkFastString (c : unpackFS fs)
 463
 464 uniqueOfFS :: FastString -> FastInt
 465 uniqueOfFS (FastString u _ _ _ _) = iUnbox u
 466
 467 nilFS :: FastString
 468 nilFS = mkFastString ""
 469
 470 -- -----------------------------------------------------------------------------
 471 -- Stats
 472
 473 getFastStringTable :: IO [[FastString]]
 474 getFastStringTable = do
 475   tbl <- readIORef string_table
 476   buckets <- mapM (lookupTbl tbl) [0 .. hASH_TBL_SIZE]
 477   return buckets
 478
 479 -- -----------------------------------------------------------------------------
 480 -- Outputting 'FastString's
 481
 482 -- |Outputs a 'FastString' with /no decoding at all/, that is, you
 483 -- get the actual bytes in the 'FastString' written to the 'Handle'.
 484 hPutFS :: Handle -> FastString -> IO ()
 485 hPutFS handle (FastString _ len _ fp _)
 486   | len == 0  = return ()
 487   | otherwise = do withForeignPtr fp $ \ptr -> hPutBuf handle ptr len
 488
 489 -- ToDo: we'll probably want an hPutFSLocal, or something, to output
 490 -- in the current locale's encoding (for error messages and suchlike).
 491
 492 -- -----------------------------------------------------------------------------
 493 -- LitStrings, here for convenience only.
 494
 495 -- hmm, not unboxed (or rather FastPtr), interesting
 496 --a.k.a. Ptr CChar, Ptr Word8, Ptr (), hmph.  We don't
 497 --really care about C types in naming, where we can help it.
 498 type LitString = Ptr Word8
 499 --Why do we recalculate length every time it's requested?
 500 --If it's commonly needed, we should perhaps have
 501 --data LitString = LitString {-#UNPACK#-}!(FastPtr Word8) {-#UNPACK#-}!FastInt
 502
 503 #if defined(__GLASGOW_HASKELL__)
 504 mkLitString# :: Addr# -> LitString
 505 mkLitString# a# = Ptr a#
 506 #endif
 507 --can/should we use FastTypes here?
 508 --Is this likely to be memory-preserving if only used on constant strings?
 509 --should we inline it? If lucky, that would make a CAF that wouldn't
 510 --be computationally repeated... although admittedly we're not
 511 --really intending to use mkLitString when __GLASGOW_HASKELL__...
 512 --(I wonder, is unicode / multi-byte characters allowed in LitStrings
 513 -- at all?)
 514 {-# INLINE mkLitString #-}
 515 mkLitString :: String -> LitString
 516 mkLitString s =
 517  unsafePerformIO (do
 518    p <- mallocBytes (length s + 1)
 519    let
 520      loop :: Int -> String -> IO ()
 521      loop n cs | n `seq` null cs = pokeByteOff p n (0 :: Word8)
 522      loop n (c:cs) = do
 523         pokeByteOff p n (fromIntegral (ord c) :: Word8)
 524         loop (1+n) cs
 525      -- XXX GHC isn't smart enough to know that we have already covered
 526      -- this case.
 527      loop _ [] = panic "mkLitString"
 528    loop 0 s
 529    return p
 530  )
 531
 532 unpackLitString :: LitString -> String
 533 unpackLitString p_ = case pUnbox p_ of
 534  p -> unpack (_ILIT(0))
 535   where
 536     unpack n = case indexWord8OffFastPtrAsFastChar p n of
 537       ch -> if ch `eqFastChar` _CLIT('\0')
 538             then [] else cBox ch : unpack (n +# _ILIT(1))
 539
 540 strLength :: LitString -> Int
 541 strLength = ptrStrLength
 542
 543 -- for now, use a simple String representation
 544 --no, let's not do that right now - it's work in other places
 545 #if 0
 546 type LitString = String
 547
 548 mkLitString :: String -> LitString
 549 mkLitString = id
 550
 551 unpackLitString :: LitString -> String
 552 unpackLitString = id
 553
 554 strLength :: LitString -> Int
 555 strLength = length
 556
 557 #endif
 558
 559 -- -----------------------------------------------------------------------------
 560 -- under the carpet
 561
 562 foreign import ccall unsafe "ghc_strlen"
 563   ptrStrLength :: Ptr Word8 -> Int
 564
 565 -- NB. does *not* add a '\0'-terminator.
 566 -- We only use CChar here to be parallel to the imported
 567 -- peekC(A)StringLen.
 568 pokeCAString :: Ptr CChar -> String -> IO ()
 569 pokeCAString ptr str =
 570   let
 571         go [] _     = return ()
 572         go (c:cs) n = do pokeElemOff ptr n (castCharToCChar c); go cs (n+1)
 573   in
 574   go str 0
 575
 576 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 602
 577 peekCAStringLen = peekCStringLen
 578 #endif
 579
 580 {-# NOINLINE sLit #-}
 581 sLit :: String -> LitString
 582 sLit x  = mkLitString x
 583
 584 {-# NOINLINE fsLit #-}
 585 fsLit :: String -> FastString
 586 fsLit x = mkFastString x
 587
 588 {-# RULES "slit"
 589     forall x . sLit  (unpackCString# x) = mkLitString#  x #-}
 590 {-# RULES "fslit"
 591     forall x . fsLit (unpackCString# x) = mkFastString# x #-}
 592 \end{code}