compiler/utils/FastString.lhs

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