compiler/utils/FastString.lhs

   1 %
   2 % (c) The University of Glasgow, 1997-2006
   3 %
   4 \begin{code}
   5 {-# OPTIONS -w #-}
   6 -- The above warning supression flag is a temporary kludge.
   7 -- While working on this module you are encouraged to remove it and fix
   8 -- any warnings in the module. See
   9 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
  10 -- for details
  11
  12 {-
  13 FastString:     A compact, hash-consed, representation of character strings.
  14                 Comparison is O(1), and you can get a Unique from them.
  15                 Generated by the FSLIT macro
  16                 Turn into SDoc with Outputable.ftext
  17
  18 LitString:      Just a wrapper for the Addr# of a C string (Ptr CChar).
  19                 Practically no operations
  20                 Outputing them is fast
  21                 Generated by the SLIT macro
  22                 Turn into SDoc with Outputable.ptext
  23
  24 Use LitString unless you want the facilities of FastString
  25 -}
  26 module FastString
  27        (
  28         -- * FastStrings
  29         FastString(..),     -- not abstract, for now.
  30
  31         -- ** Construction
  32         mkFastString,
  33         mkFastStringBytes,
  34         mkFastStringByteList,
  35         mkFastStringForeignPtr,
  36 #if defined(__GLASGOW_HASKELL__)
  37         mkFastString#,
  38 #endif
  39         mkZFastString,
  40         mkZFastStringBytes,
  41
  42         -- ** Deconstruction
  43         unpackFS,           -- :: FastString -> String
  44         bytesFS,            -- :: FastString -> [Word8]
  45
  46         -- ** Encoding
  47         isZEncoded,
  48         zEncodeFS,
  49
  50         -- ** Operations
  51         uniqueOfFS,
  52         lengthFS,
  53         nullFS,
  54         appendFS,
  55         headFS,
  56         tailFS,
  57         concatFS,
  58         consFS,
  59         nilFS,
  60
  61         -- ** Outputing
  62         hPutFS,
  63
  64         -- ** Internal
  65         getFastStringTable,
  66         hasZEncoding,
  67
  68         -- * LitStrings
  69         LitString,
  70 #if defined(__GLASGOW_HASKELL__)
  71         mkLitString#,
  72 #else
  73         mkLitString,
  74 #endif
  75         unpackLitString,
  76         strLength,
  77
  78         ptrStrLength
  79        ) where
  80
  81 -- This #define suppresses the "import FastString" that
  82 -- HsVersions otherwise produces
  83 #define COMPILING_FAST_STRING
  84 #include "HsVersions.h"
  85
  86 import Encoding
  87 import FastTypes
  88 import FastFunctions
  89
  90 import Foreign
  91 import Foreign.C
  92 import GHC.Exts
  93 import System.IO.Unsafe ( unsafePerformIO )
  94 import Control.Monad.ST ( stToIO )
  95 import Data.IORef       ( IORef, newIORef, readIORef, writeIORef )
  96 import System.IO        ( hPutBuf )
  97 import Data.Maybe       ( isJust )
  98 import Data.Char        ( ord )
  99
 100 import GHC.ST
 101 import GHC.IOBase       ( IO(..) )
 102 import GHC.Ptr          ( Ptr(..) )
 103
 104 #define hASH_TBL_SIZE          4091
 105 #define hASH_TBL_SIZE_UNBOXED  4091#
 106
 107
 108 {-|
 109 A 'FastString' is an array of bytes, hashed to support fast O(1)
 110 comparison.  It is also associated with a character encoding, so that
 111 we know how to convert a 'FastString' to the local encoding, or to the
 112 Z-encoding used by the compiler internally.
 113
 114 'FastString's support a memoized conversion to the Z-encoding via zEncodeFS.
 115 -}
 116
 117 data FastString = FastString {
 118       uniq    :: {-# UNPACK #-} !Int, -- unique id
 119       n_bytes :: {-# UNPACK #-} !Int, -- number of bytes
 120       n_chars :: {-# UNPACK #-} !Int, -- number of chars
 121       buf     :: {-# UNPACK #-} !(ForeignPtr Word8),
 122       enc     :: FSEncoding
 123   }
 124
 125 data FSEncoding
 126     -- including strings that don't need any encoding
 127   = ZEncoded
 128     -- A UTF-8 string with a memoized Z-encoding
 129   | UTF8Encoded {-# UNPACK #-} !(IORef (Maybe FastString))
 130
 131 instance Eq FastString where
 132   f1 == f2  =  uniq f1 == uniq f2
 133
 134 instance Ord FastString where
 135     -- Compares lexicographically, not by unique
 136     a <= b = case cmpFS a b of { LT -> True;  EQ -> True;  GT -> False }
 137     a <  b = case cmpFS a b of { LT -> True;  EQ -> False; GT -> False }
 138     a >= b = case cmpFS a b of { LT -> False; EQ -> True;  GT -> True  }
 139     a >  b = case cmpFS a b of { LT -> False; EQ -> False; GT -> True  }
 140     max x y | x >= y    =  x
 141             | otherwise =  y
 142     min x y | x <= y    =  x
 143             | otherwise =  y
 144     compare a b = cmpFS a b
 145
 146 instance Show FastString where
 147    show fs = show (unpackFS fs)
 148
 149 cmpFS :: FastString -> FastString -> Ordering
 150 cmpFS (FastString u1 l1 _ buf1 _) (FastString u2 l2 _ buf2 _) =
 151   if u1 == u2 then EQ else
 152   case unsafeMemcmp buf1 buf2 (min l1 l2) `compare` 0 of
 153      LT -> LT
 154      EQ -> compare l1 l2
 155      GT -> GT
 156
 157 unsafeMemcmp :: ForeignPtr a -> ForeignPtr b -> Int -> Int
 158 unsafeMemcmp buf1 buf2 l =
 159       inlinePerformIO $
 160         withForeignPtr buf1 $ \p1 ->
 161         withForeignPtr buf2 $ \p2 ->
 162           memcmp p1 p2 l
 163
 164 #ifndef __HADDOCK__
 165 foreign import ccall unsafe "ghc_memcmp"
 166   memcmp :: Ptr a -> Ptr b -> Int -> IO Int
 167 #endif
 168
 169 -- -----------------------------------------------------------------------------
 170 -- Construction
 171
 172 {-
 173 Internally, the compiler will maintain a fast string symbol
 174 table, providing sharing and fast comparison. Creation of
 175 new @FastString@s then covertly does a lookup, re-using the
 176 @FastString@ if there was a hit.
 177 -}
 178
 179 data FastStringTable =
 180  FastStringTable
 181     {-# UNPACK #-} !Int
 182     (MutableArray# RealWorld [FastString])
 183
 184 {-# NOINLINE string_table #-}
 185 string_table :: IORef FastStringTable
 186 string_table =
 187  unsafePerformIO $ do
 188    tab <- IO $ \s1# -> case newArray# hASH_TBL_SIZE_UNBOXED [] s1# of
 189                            (# s2#, arr# #) ->
 190                                (# s2#, FastStringTable 0 arr# #)
 191    newIORef tab
 192
 193 lookupTbl :: FastStringTable -> Int -> IO [FastString]
 194 lookupTbl (FastStringTable _ arr#) (I# i#) =
 195   IO $ \ s# -> readArray# arr# i# s#
 196
 197 updTbl :: IORef FastStringTable -> FastStringTable -> Int -> [FastString] -> IO ()
 198 updTbl fs_table_var (FastStringTable uid arr#) (I# i#) ls = do
 199   (IO $ \ s# -> case writeArray# arr# i# ls s# of { s2# -> (# s2#, () #) })
 200   writeIORef fs_table_var (FastStringTable (uid+1) arr#)
 201
 202 mkFastString# :: Addr# -> FastString
 203 mkFastString# a# = mkFastStringBytes ptr (ptrStrLength ptr)
 204   where ptr = Ptr a#
 205
 206 mkFastStringBytes :: Ptr Word8 -> Int -> FastString
 207 mkFastStringBytes ptr len = unsafePerformIO $ do
 208   ft@(FastStringTable uid tbl#) <- readIORef string_table
 209   let
 210    h = hashStr ptr len
 211    add_it ls = do
 212         fs <- copyNewFastString uid ptr len
 213         updTbl string_table ft h (fs:ls)
 214         {- _trace ("new: " ++ show f_str)   $ -}
 215         return fs
 216   --
 217   lookup_result <- lookupTbl ft h
 218   case lookup_result of
 219     [] -> add_it []
 220     ls -> do
 221        b <- bucket_match ls len ptr
 222        case b of
 223          Nothing -> add_it ls
 224          Just v  -> {- _trace ("re-use: "++show v) $ -} return v
 225
 226 mkZFastStringBytes :: Ptr Word8 -> Int -> FastString
 227 mkZFastStringBytes ptr len = unsafePerformIO $ do
 228   ft@(FastStringTable uid tbl#) <- readIORef string_table
 229   let
 230    h = hashStr ptr len
 231    add_it ls = do
 232         fs <- copyNewZFastString uid ptr len
 233         updTbl string_table ft h (fs:ls)
 234         {- _trace ("new: " ++ show f_str)   $ -}
 235         return fs
 236   --
 237   lookup_result <- lookupTbl ft h
 238   case lookup_result of
 239     [] -> add_it []
 240     ls -> do
 241        b <- bucket_match ls len ptr
 242        case b of
 243          Nothing -> add_it ls
 244          Just v  -> {- _trace ("re-use: "++show v) $ -} return v
 245
 246 -- | Create a 'FastString' from an existing 'ForeignPtr'; the difference
 247 -- between this and 'mkFastStringBytes' is that we don't have to copy
 248 -- the bytes if the string is new to the table.
 249 mkFastStringForeignPtr :: Ptr Word8 -> ForeignPtr Word8 -> Int -> IO FastString
 250 mkFastStringForeignPtr ptr fp len = do
 251   ft@(FastStringTable uid tbl#) <- readIORef string_table
 252 --  _trace ("hashed: "++show (I# h)) $
 253   let
 254     h = hashStr ptr len
 255     add_it ls = do
 256         fs <- mkNewFastString uid ptr fp len
 257         updTbl string_table ft h (fs:ls)
 258         {- _trace ("new: " ++ show f_str)   $ -}
 259         return fs
 260   --
 261   lookup_result <- lookupTbl ft h
 262   case lookup_result of
 263     [] -> add_it []
 264     ls -> do
 265        b <- bucket_match ls len ptr
 266        case b of
 267          Nothing -> add_it ls
 268          Just v  -> {- _trace ("re-use: "++show v) $ -} return v
 269
 270 mkZFastStringForeignPtr :: Ptr Word8 -> ForeignPtr Word8 -> Int -> IO FastString
 271 mkZFastStringForeignPtr ptr fp len = do
 272   ft@(FastStringTable uid tbl#) <- readIORef string_table
 273 --  _trace ("hashed: "++show (I# h)) $
 274   let
 275     h = hashStr ptr len
 276     add_it ls = do
 277         fs <- mkNewZFastString uid ptr fp len
 278         updTbl string_table ft h (fs:ls)
 279         {- _trace ("new: " ++ show f_str)   $ -}
 280         return fs
 281   --
 282   lookup_result <- lookupTbl ft h
 283   case lookup_result of
 284     [] -> add_it []
 285     ls -> do
 286        b <- bucket_match ls len ptr
 287        case b of
 288          Nothing -> add_it ls
 289          Just v  -> {- _trace ("re-use: "++show v) $ -} return v
 290
 291
 292 -- | Creates a UTF-8 encoded 'FastString' from a 'String'
 293 mkFastString :: String -> FastString
 294 mkFastString str =
 295   inlinePerformIO $ do
 296     let l = utf8EncodedLength str
 297     buf <- mallocForeignPtrBytes l
 298     withForeignPtr buf $ \ptr -> do
 299       utf8EncodeString ptr str
 300       mkFastStringForeignPtr ptr buf l
 301
 302 -- | Creates a 'FastString' from a UTF-8 encoded @[Word8]@
 303 mkFastStringByteList :: [Word8] -> FastString
 304 mkFastStringByteList str =
 305   inlinePerformIO $ do
 306     let l = Prelude.length str
 307     buf <- mallocForeignPtrBytes l
 308     withForeignPtr buf $ \ptr -> do
 309       pokeArray (castPtr ptr) str
 310       mkFastStringForeignPtr ptr buf l
 311
 312 -- | Creates a Z-encoded 'FastString' from a 'String'
 313 mkZFastString :: String -> FastString
 314 mkZFastString str =
 315   inlinePerformIO $ do
 316     let l = Prelude.length str
 317     buf <- mallocForeignPtrBytes l
 318     withForeignPtr buf $ \ptr -> do
 319       pokeCAString (castPtr ptr) str
 320       mkZFastStringForeignPtr ptr buf l
 321
 322 bucket_match [] _ _ = return Nothing
 323 bucket_match (v@(FastString _ l _ buf _):ls) len ptr
 324       | len == l  =  do
 325          b <- cmpStringPrefix ptr buf len
 326          if b then return (Just v)
 327               else bucket_match ls len ptr
 328       | otherwise =
 329          bucket_match ls len ptr
 330
 331 mkNewFastString uid ptr fp len = do
 332   ref <- newIORef Nothing
 333   n_chars <- countUTF8Chars ptr len
 334   return (FastString uid len n_chars fp (UTF8Encoded ref))
 335
 336 mkNewZFastString uid ptr fp len = do
 337   return (FastString uid len len fp ZEncoded)
 338
 339
 340 copyNewFastString uid ptr len = do
 341   fp <- copyBytesToForeignPtr ptr len
 342   ref <- newIORef Nothing
 343   n_chars <- countUTF8Chars ptr len
 344   return (FastString uid len n_chars fp (UTF8Encoded ref))
 345
 346 copyNewZFastString uid ptr len = do
 347   fp <- copyBytesToForeignPtr ptr len
 348   return (FastString uid len len fp ZEncoded)
 349
 350
 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 fs@(FastString uid n_bytes _ fp 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 enc) =
 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 uid n_bytes _ fp 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 _ n_bytes _ buf enc) =
 440   inlinePerformIO $ withForeignPtr buf $ \ptr -> do
 441     case enc of
 442       ZEncoded -> do
 443          w <- peek (castPtr ptr)
 444          return (castCCharToChar w)
 445       UTF8Encoded _ ->
 446          return (fst (utf8DecodeChar ptr))
 447
 448 tailFS :: FastString -> FastString
 449 tailFS (FastString _ n_bytes _ buf enc) =
 450   inlinePerformIO $ withForeignPtr buf $ \ptr -> do
 451     case enc of
 452       ZEncoded -> do
 453         return $! mkZFastStringBytes (ptr `plusPtr` 1) (n_bytes - 1)
 454       UTF8Encoded _ -> do
 455          let (_,ptr') = utf8DecodeChar ptr
 456          let off = ptr' `minusPtr` ptr
 457          return $! mkFastStringBytes (ptr `plusPtr` off) (n_bytes - off)
 458
 459 consFS :: Char -> FastString -> FastString
 460 consFS c fs = mkFastString (c : unpackFS fs)
 461
 462 uniqueOfFS :: FastString -> FastInt
 463 uniqueOfFS (FastString u _ _ _ _) = iUnbox u
 464
 465 nilFS = mkFastString ""
 466
 467 -- -----------------------------------------------------------------------------
 468 -- Stats
 469
 470 getFastStringTable :: IO [[FastString]]
 471 getFastStringTable = do
 472   tbl <- readIORef string_table
 473   buckets <- mapM (lookupTbl tbl) [0 .. hASH_TBL_SIZE]
 474   return buckets
 475
 476 -- -----------------------------------------------------------------------------
 477 -- Outputting 'FastString's
 478
 479 -- |Outputs a 'FastString' with /no decoding at all/, that is, you
 480 -- get the actual bytes in the 'FastString' written to the 'Handle'.
 481 hPutFS handle (FastString _ len _ fp _)
 482   | len == 0  = return ()
 483   | otherwise = do withForeignPtr fp $ \ptr -> hPutBuf handle ptr len
 484
 485 -- ToDo: we'll probably want an hPutFSLocal, or something, to output
 486 -- in the current locale's encoding (for error messages and suchlike).
 487
 488 -- -----------------------------------------------------------------------------
 489 -- LitStrings, here for convenience only.
 490
 491 -- hmm, not unboxed (or rather FastPtr), interesting
 492 --a.k.a. Ptr CChar, Ptr Word8, Ptr (), hmph.  We don't
 493 --really care about C types in naming, where we can help it.
 494 type LitString = Ptr Word8
 495 --Why do we recalculate length every time it's requested?
 496 --If it's commonly needed, we should perhaps have
 497 --data LitString = LitString {-#UNPACK#-}!(FastPtr Word8) {-#UNPACK#-}!FastInt
 498
 499 #if defined(__GLASGOW_HASKELL__)
 500 mkLitString# :: Addr# -> LitString
 501 mkLitString# a# = Ptr a#
 502 #endif
 503
 504 --can/should we use FastTypes here?
 505 --Is this likely to be memory-preserving if only used on constant strings?
 506 --should we inline it? If lucky, that would make a CAF that wouldn't
 507 --be computationally repeated... although admittedly we're not
 508 --really intending to use mkLitString when __GLASGOW_HASKELL__...
 509 --(I wonder, is unicode / multi-byte characters allowed in LitStrings
 510 -- at all?)
 511 {-# INLINE mkLitString #-}
 512 mkLitString :: String -> LitString
 513 mkLitString s =
 514  unsafePerformIO (do
 515    p <- mallocBytes (length s + 1)
 516    let
 517      loop :: Int -> String -> IO ()
 518      loop n cs | n `seq` null cs = pokeByteOff p n (0 :: Word8)
 519      loop n (c:cs) = do
 520         pokeByteOff p n (fromIntegral (ord c) :: Word8)
 521         loop (1+n) cs
 522    loop 0 s
 523    return p
 524  )
 525
 526 unpackLitString :: LitString -> String
 527 unpackLitString p_ = case pUnbox p_ of
 528  p -> unpack (_ILIT(0))
 529   where
 530     unpack n = case indexWord8OffFastPtrAsFastChar p n of
 531       ch -> if ch `eqFastChar` _CLIT('\0')
 532             then [] else cBox ch : unpack (n +# _ILIT(1))
 533
 534 strLength :: LitString -> Int
 535 strLength = ptrStrLength
 536
 537 -- for now, use a simple String representation
 538 --no, let's not do that right now - it's work in other places
 539 #if 0
 540 type LitString = String
 541
 542 mkLitString :: String -> LitString
 543 mkLitString = id
 544
 545 unpackLitString :: LitString -> String
 546 unpackLitString = id
 547
 548 strLength :: LitString -> Int
 549 strLength = length
 550
 551 #endif
 552
 553 -- -----------------------------------------------------------------------------
 554 -- under the carpet
 555
 556 foreign import ccall unsafe "ghc_strlen"
 557   ptrStrLength :: Ptr Word8 -> Int
 558
 559 -- NB. does *not* add a '\0'-terminator.
 560 -- We only use CChar here to be parallel to the imported
 561 -- peekC(A)StringLen.
 562 pokeCAString :: Ptr CChar -> String -> IO ()
 563 pokeCAString ptr str =
 564   let
 565         go [] n     = return ()
 566         go (c:cs) n = do pokeElemOff ptr n (castCharToCChar c); go cs (n+1)
 567   in
 568   go str 0
 569
 570 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 602
 571 peekCAStringLen = peekCStringLen
 572 #endif
 573 \end{code}