ghc/compiler/utils/FastString.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1997-1998
   3 %
   4 \section{Fast strings}
   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 \begin{code}
  20 module FastString
  21        (
  22         FastString(..),     -- not abstract, for now.
  23
  24         mkFastString,       -- :: String -> FastString
  25         mkFastStringNarrow, -- :: String -> FastString
  26         mkFastSubString,    -- :: Addr -> Int -> Int -> FastString
  27
  28         mkFastString#,      -- :: Addr# -> FastString
  29         mkFastSubStringBA#, -- :: ByteArray# -> Int# -> Int# -> FastString
  30
  31         mkFastStringInt,    -- :: [Int] -> FastString
  32
  33         uniqueOfFS,         -- :: FastString -> Int#
  34         lengthFS,           -- :: FastString -> Int
  35         nullFastString,     -- :: FastString -> Bool
  36
  37         unpackFS,           -- :: FastString -> String
  38         unpackIntFS,        -- :: FastString -> [Int]
  39         appendFS,           -- :: FastString -> FastString -> FastString
  40         headFS,             -- :: FastString -> Char
  41         headIntFS,          -- :: FastString -> Int
  42         tailFS,             -- :: FastString -> FastString
  43         concatFS,           -- :: [FastString] -> FastString
  44         consFS,             -- :: Char -> FastString -> FastString
  45         indexFS,            -- :: FastString -> Int -> Char
  46         nilFS,              -- :: FastString
  47
  48         hPutFS,             -- :: Handle -> FastString -> IO ()
  49
  50         LitString,
  51         mkLitString#        -- :: Addr# -> LitString
  52        ) where
  53
  54 -- This #define suppresses the "import FastString" that
  55 -- HsVersions otherwise produces
  56 #define COMPILING_FAST_STRING
  57 #include "HsVersions.h"
  58
  59 #if __GLASGOW_HASKELL__ < 503
  60 import PrelIOBase       ( IO(..) )
  61 #else
  62 import GHC.IOBase       ( IO(..) )
  63 #endif
  64
  65 import PrimPacked
  66 import GLAEXTS
  67 import UNSAFE_IO        ( unsafePerformIO )
  68 import MONAD_ST         ( stToIO )
  69 import DATA_IOREF       ( IORef, newIORef, readIORef, writeIORef )
  70
  71 #if __GLASGOW_HASKELL__ < 503
  72 import PrelArr          ( STArray(..), newSTArray )
  73 #else
  74 import GHC.Arr          ( STArray(..), newSTArray )
  75 #endif
  76
  77 #if __GLASGOW_HASKELL__ >= 504
  78 import GHC.IOBase
  79 import GHC.Handle
  80 import Foreign.C
  81 #else
  82 import IOExts           ( hPutBufBAFull )
  83 #endif
  84
  85 import IO
  86 import Char             ( chr, ord )
  87
  88 #define hASH_TBL_SIZE  4091
  89 \end{code}
  90
  91 @FastString@s are packed representations of strings
  92 with a unique id for fast comparisons. The unique id
  93 is assigned when creating the @FastString@, using
  94 a hash table to map from the character string representation
  95 to the unique ID.
  96
  97 \begin{code}
  98 data FastString
  99   = FastString   -- packed repr. on the heap.
 100       Int#       -- unique id
 101                  --  0 => string literal, comparison
 102                  --  will
 103       Int#       -- length
 104       ByteArray# -- stuff
 105
 106   | UnicodeStr   -- if contains characters outside '\1'..'\xFF'
 107       Int#       -- unique id
 108       [Int]      -- character numbers
 109
 110 instance Eq FastString where
 111         -- shortcut for real FastStrings
 112   (FastString u1 _ _) == (FastString u2 _ _) = u1 ==# u2
 113   a == b = case cmpFS a b of { LT -> False; EQ -> True;  GT -> False }
 114
 115   (FastString u1 _ _) /= (FastString u2 _ _) = u1 /=# u2
 116   a /= b = case cmpFS a b of { LT -> True;  EQ -> False; GT -> True  }
 117
 118 instance Ord FastString where
 119         -- Compares lexicographically, not by unique
 120     a <= b = case cmpFS a b of { LT -> True;  EQ -> True;  GT -> False }
 121     a <  b = case cmpFS a b of { LT -> True;  EQ -> False; GT -> False }
 122     a >= b = case cmpFS a b of { LT -> False; EQ -> True;  GT -> True  }
 123     a >  b = case cmpFS a b of { LT -> False; EQ -> False; GT -> True  }
 124     max x y | x >= y    =  x
 125             | otherwise =  y
 126     min x y | x <= y    =  x
 127             | otherwise =  y
 128     compare a b = cmpFS a b
 129
 130 instance Show FastString where
 131    show fs = show (unpackFS fs)
 132
 133 lengthFS :: FastString -> Int
 134 lengthFS (FastString _ l# _) = I# l#
 135 lengthFS (UnicodeStr _ s) = length s
 136
 137 nullFastString :: FastString -> Bool
 138 nullFastString (FastString _ l# _) = l# ==# 0#
 139 nullFastString (UnicodeStr _ []) = True
 140 nullFastString (UnicodeStr _ (_:_)) = False
 141
 142 unpackFS :: FastString -> String
 143 unpackFS (FastString _ l# ba#) = unpackNBytesBA (BA ba#) (I# l#)
 144 unpackFS (UnicodeStr _ s) = map chr s
 145
 146 unpackIntFS :: FastString -> [Int]
 147 unpackIntFS (UnicodeStr _ s) = s
 148 unpackIntFS fs = map ord (unpackFS fs)
 149
 150 appendFS :: FastString -> FastString -> FastString
 151 appendFS fs1 fs2 = mkFastStringInt (unpackIntFS fs1 ++ unpackIntFS fs2)
 152
 153 concatFS :: [FastString] -> FastString
 154 concatFS ls = mkFastStringInt (concat (map unpackIntFS ls)) -- ToDo: do better
 155
 156 headFS :: FastString -> Char
 157 headFS (FastString _ l# ba#) =
 158  if l# ># 0# then C# (indexCharArray# ba# 0#) else error ("headFS: empty FS")
 159 headFS (UnicodeStr _ (c:_)) = chr c
 160 headFS (UnicodeStr _ []) = error ("headFS: empty FS")
 161
 162 headIntFS :: FastString -> Int
 163 headIntFS (UnicodeStr _ (c:_)) = c
 164 headIntFS fs = ord (headFS fs)
 165
 166 indexFS :: FastString -> Int -> Char
 167 indexFS f i@(I# i#) =
 168  case f of
 169    FastString _ l# ba#
 170      | l# ># 0# && l# ># i#  -> C# (indexCharArray# ba# i#)
 171      | otherwise             -> error (msg (I# l#))
 172    UnicodeStr _ s            -> chr (s!!i)
 173  where
 174   msg l =  "indexFS: out of range: " ++ show (l,i)
 175
 176 tailFS :: FastString -> FastString
 177 tailFS (FastString _ l# ba#) = mkFastSubStringBA# ba# 1# (l# -# 1#)
 178 tailFS fs = mkFastStringInt (tail (unpackIntFS fs))
 179
 180 consFS :: Char -> FastString -> FastString
 181 consFS c fs = mkFastStringInt (ord c : unpackIntFS fs)
 182
 183 uniqueOfFS :: FastString -> Int#
 184 uniqueOfFS (FastString u# _ _) = u#
 185 uniqueOfFS (UnicodeStr u# _) = u#
 186
 187 nilFS = mkFastString ""
 188 \end{code}
 189
 190 Internally, the compiler will maintain a fast string symbol
 191 table, providing sharing and fast comparison. Creation of
 192 new @FastString@s then covertly does a lookup, re-using the
 193 @FastString@ if there was a hit.
 194
 195 Caution: mkFastStringUnicode assumes that if the string is in the
 196 table, it sits under the UnicodeStr constructor. Other mkFastString
 197 variants analogously assume the FastString constructor.
 198
 199 \begin{code}
 200 data FastStringTable =
 201  FastStringTable
 202     Int#
 203     (MutableArray# RealWorld [FastString])
 204
 205 type FastStringTableVar = IORef FastStringTable
 206
 207 string_table :: FastStringTableVar
 208 string_table =
 209  unsafePerformIO (
 210    stToIO (newSTArray (0::Int,hASH_TBL_SIZE) [])
 211         >>= \ (STArray _ _ arr#) ->
 212    newIORef (FastStringTable 0# arr#))
 213
 214 lookupTbl :: FastStringTable -> Int# -> IO [FastString]
 215 lookupTbl (FastStringTable _ arr#) i# =
 216   IO ( \ s# ->
 217   readArray# arr# i# s#)
 218
 219 updTbl :: FastStringTableVar -> FastStringTable -> Int# -> [FastString] -> IO ()
 220 updTbl fs_table_var (FastStringTable uid# arr#) i# ls =
 221  IO (\ s# -> case writeArray# arr# i# ls s# of { s2# ->
 222         (# s2#, () #) }) >>
 223  writeIORef fs_table_var (FastStringTable (uid# +# 1#) arr#)
 224
 225 mkFastString# :: Addr# -> FastString
 226 mkFastString# a# =
 227  case strLength (Ptr a#) of { (I# len#) -> mkFastStringLen# a# len# }
 228
 229 mkFastStringLen# :: Addr# -> Int# -> FastString
 230 mkFastStringLen# a# len# =
 231  unsafePerformIO  (
 232   readIORef string_table        >>= \ ft@(FastStringTable uid# tbl#) ->
 233   let
 234    h = hashStr a# len#
 235   in
 236 --  _trace ("hashed: "++show (I# h)) $
 237   lookupTbl ft h        >>= \ lookup_result ->
 238   case lookup_result of
 239     [] ->
 240        -- no match, add it to table by copying out the
 241        -- the string into a ByteArray
 242        -- _trace "empty bucket" $
 243        case copyPrefixStr a# (I# len#) of
 244          BA barr# ->
 245            let f_str = FastString uid# len# barr# in
 246            updTbl string_table ft h [f_str] >>
 247            ({- _trace ("new: " ++ show f_str)   $ -} return f_str)
 248     ls ->
 249        -- non-empty `bucket', scan the list looking
 250        -- entry with same length and compare byte by byte.
 251        -- _trace ("non-empty bucket"++show ls) $
 252        case bucket_match ls len# a# of
 253          Nothing ->
 254            case copyPrefixStr a# (I# len#) of
 255              BA barr# ->
 256               let f_str = FastString uid# len# barr# in
 257               updTbl string_table ft h (f_str:ls) >>
 258               ( {- _trace ("new: " ++ show f_str)  $ -} return f_str)
 259          Just v  -> {- _trace ("re-use: "++show v) $ -} return v)
 260   where
 261    bucket_match [] _ _ = Nothing
 262    bucket_match (v@(FastString _ l# ba#):ls) len# a# =
 263       if len# ==# l# && eqStrPrefix a# ba# l# then
 264          Just v
 265       else
 266          bucket_match ls len# a#
 267    bucket_match (UnicodeStr _ _ : ls) len# a# =
 268       bucket_match ls len# a#
 269
 270 mkFastSubStringBA# :: ByteArray# -> Int# -> Int# -> FastString
 271 mkFastSubStringBA# barr# start# len# =
 272  unsafePerformIO  (
 273   readIORef string_table        >>= \ ft@(FastStringTable uid# tbl#) ->
 274   let
 275    h = hashSubStrBA barr# start# len#
 276   in
 277 --  _trace ("hashed(b): "++show (I# h)) $
 278   lookupTbl ft h                >>= \ lookup_result ->
 279   case lookup_result of
 280     [] ->
 281        -- no match, add it to table by copying out the
 282        -- the string into a ByteArray
 283        -- _trace "empty bucket(b)" $
 284        case copySubStrBA (BA barr#) (I# start#) (I# len#) of
 285          BA ba# ->
 286           let f_str = FastString uid# len# ba# in
 287           updTbl string_table ft h [f_str]     >>
 288           -- _trace ("new(b): " ++ show f_str)   $
 289           return f_str
 290     ls ->
 291        -- non-empty `bucket', scan the list looking
 292        -- entry with same length and compare byte by byte.
 293        -- _trace ("non-empty bucket(b)"++show ls) $
 294        case bucket_match ls start# len# barr# of
 295          Nothing ->
 296           case copySubStrBA (BA barr#) (I# start#) (I# len#) of
 297             BA ba# ->
 298               let f_str = FastString uid# len# ba# in
 299               updTbl string_table ft h (f_str:ls) >>
 300               -- _trace ("new(b): " ++ show f_str)   $
 301               return f_str
 302          Just v  ->
 303               -- _trace ("re-use(b): "++show v) $
 304               return v
 305   )
 306  where
 307    bucket_match [] _ _ _ = Nothing
 308    bucket_match (v:ls) start# len# ba# =
 309     case v of
 310      FastString _ l# barr# ->
 311       if len# ==# l# && eqStrPrefixBA barr# ba# start# len# then
 312          Just v
 313       else
 314          bucket_match ls start# len# ba#
 315      UnicodeStr _ _ -> bucket_match ls start# len# ba#
 316
 317 mkFastStringUnicode :: [Int] -> FastString
 318 mkFastStringUnicode s =
 319  unsafePerformIO  (
 320   readIORef string_table        >>= \ ft@(FastStringTable uid# tbl#) ->
 321   let
 322    h = hashUnicode s 0#
 323   in
 324 --  _trace ("hashed(b): "++show (I# h)) $
 325   lookupTbl ft h                >>= \ lookup_result ->
 326   case lookup_result of
 327     [] ->
 328        -- no match, add it to table by copying out the
 329        -- the string into a [Int]
 330           let f_str = UnicodeStr uid# s in
 331           updTbl string_table ft h [f_str]     >>
 332           -- _trace ("new(b): " ++ show f_str)   $
 333           return f_str
 334     ls ->
 335        -- non-empty `bucket', scan the list looking
 336        -- entry with same length and compare byte by byte.
 337        -- _trace ("non-empty bucket(b)"++show ls) $
 338        case bucket_match ls of
 339          Nothing ->
 340               let f_str = UnicodeStr uid# s in
 341               updTbl string_table ft h (f_str:ls) >>
 342               -- _trace ("new(b): " ++ show f_str)   $
 343               return f_str
 344          Just v  ->
 345               -- _trace ("re-use(b): "++show v) $
 346               return v
 347   )
 348  where
 349    bucket_match [] = Nothing
 350    bucket_match (v@(UnicodeStr _ s'):ls) =
 351        if s' == s then Just v else bucket_match ls
 352    bucket_match (FastString _ _ _ : ls) = bucket_match ls
 353
 354 mkFastStringNarrow :: String -> FastString
 355 mkFastStringNarrow str =
 356  case packString str of { (I# len#, BA frozen#) ->
 357     mkFastSubStringBA# frozen# 0# len#
 358  }
 359  {- 0-indexed array, len# == index to one beyond end of string,
 360     i.e., (0,1) => empty string.    -}
 361
 362 mkFastString :: String -> FastString
 363 mkFastString str = if all good str
 364     then mkFastStringNarrow str
 365     else mkFastStringUnicode (map ord str)
 366     where
 367     good c = c >= '\1' && c <= '\xFF'
 368
 369 mkFastStringInt :: [Int] -> FastString
 370 mkFastStringInt str = if all good str
 371     then mkFastStringNarrow (map chr str)
 372     else mkFastStringUnicode str
 373     where
 374     good c = c >= 1 && c <= 0xFF
 375
 376 mkFastSubString :: Addr# -> Int -> Int -> FastString
 377 mkFastSubString a# (I# start#) (I# len#) =
 378  mkFastStringLen# (a# `plusAddr#` start#) len#
 379 \end{code}
 380
 381 \begin{code}
 382 hashStr  :: Addr# -> Int# -> Int#
 383  -- use the Addr to produce a hash value between 0 & m (inclusive)
 384 hashStr a# len# = loop 0# 0#
 385    where
 386     loop h n | n ==# len# = h
 387              | otherwise  = loop h2 (n +# 1#)
 388           where c = ord# (indexCharOffAddr# a# n)
 389                 h2 = (c +# (h *# 128#)) `remInt#` hASH_TBL_SIZE#
 390
 391 hashSubStrBA  :: ByteArray# -> Int# -> Int# -> Int#
 392  -- use the byte array to produce a hash value between 0 & m (inclusive)
 393 hashSubStrBA ba# start# len# = loop 0# 0#
 394    where
 395     loop h n | n ==# len# = h
 396              | otherwise  = loop h2 (n +# 1#)
 397           where c = ord# (indexCharArray# ba# (start# +# n))
 398                 h2 = (c +# (h *# 128#)) `remInt#` hASH_TBL_SIZE#
 399
 400 hashUnicode :: [Int] -> Int# -> Int#
 401 hashUnicode [] h = h
 402 hashUnicode (I# c : cs) h = hashUnicode cs ((c +# (h *# 128#)) `remInt#` hASH_TBL_SIZE#)
 403 \end{code}
 404
 405 \begin{code}
 406 cmpFS :: FastString -> FastString -> Ordering
 407 cmpFS (UnicodeStr u1# s1) (UnicodeStr u2# s2) = if u1# ==# u2# then EQ
 408     else compare s1 s2
 409 cmpFS (UnicodeStr _ s1) s2 = compare s1 (unpackIntFS s2)
 410 cmpFS s1 (UnicodeStr _ s2) = compare (unpackIntFS s1) s2
 411 cmpFS (FastString u1# l1# b1#) (FastString u2# l2# b2#) =
 412   if u1# ==# u2# then EQ else
 413   let l# = if l1# <=# l2# then l1# else l2# in
 414   unsafePerformIO (
 415     memcmp b1# b2# l# >>= \ (I# res) ->
 416     return (
 417     if      res <#  0# then LT
 418     else if res ==# 0# then
 419         if l1# ==# l2# then EQ
 420         else if l1# <# l2# then LT else GT
 421     else                    GT
 422     ))
 423
 424 #ifndef __HADDOCK__
 425 foreign import ccall unsafe "ghc_memcmp"
 426   memcmp :: ByteArray# -> ByteArray# -> Int# -> IO Int
 427 #endif
 428
 429 -- -----------------------------------------------------------------------------
 430 -- Outputting 'FastString's
 431
 432 #if __GLASGOW_HASKELL__ >= 504
 433
 434 -- this is our own version of hPutBuf for FastStrings, because in
 435 -- 5.04+ we don't have mutable byte arrays and therefore hPutBufBA.
 436 -- The closest is hPutArray in Data.Array.IO, but that does some extra
 437 -- range checks that we want to avoid here.
 438
 439 foreign import ccall unsafe "__hscore_memcpy_dst_off"
 440    memcpy_baoff_ba :: RawBuffer -> Int -> RawBuffer -> CSize -> IO (Ptr ())
 441
 442 hPutFS handle (FastString _ l# ba#)
 443   | l# ==# 0#  = return ()
 444   | otherwise
 445    = do wantWritableHandle "hPutFS" handle $
 446           \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=stream } -> do
 447
 448           old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size }
 449             <- readIORef ref
 450
 451           let count = I# l#
 452               raw = unsafeCoerce# ba# :: MutableByteArray# RealWorld
 453
 454           -- enough room in handle buffer?
 455           if (size - w > count)
 456                 -- There's enough room in the buffer:
 457                 -- just copy the data in and update bufWPtr.
 458             then do memcpy_baoff_ba old_raw w raw (fromIntegral count)
 459                     writeIORef ref old_buf{ bufWPtr = w + count }
 460                     return ()
 461
 462                 -- else, we have to flush
 463             else do flushed_buf <- flushWriteBuffer fd stream old_buf
 464                     writeIORef ref flushed_buf
 465                     let this_buf =
 466                             Buffer{ bufBuf=raw, bufState=WriteBuffer,
 467                                     bufRPtr=0, bufWPtr=count, bufSize=count }
 468                     flushWriteBuffer fd stream this_buf
 469                     return ()
 470
 471 #else
 472
 473 hPutFS :: Handle -> FastString -> IO ()
 474 hPutFS handle (FastString _ l# ba#)
 475   | l# ==# 0#  = return ()
 476   | otherwise  = do mba <- stToIO $ unsafeThawByteArray (ByteArray (bot::Int) bot ba#)
 477                     hPutBufBAFull  handle mba (I# l#)
 478  where
 479   bot = error "hPutFS.ba"
 480
 481 #endif
 482
 483 -- ONLY here for debugging the NCG (so -ddump-stix works for string
 484 -- literals); no idea if this is really necessary.  JRS, 010131
 485 hPutFS handle (UnicodeStr _ is)
 486   = hPutStr handle ("(UnicodeStr " ++ show is ++ ")")
 487
 488 -- -----------------------------------------------------------------------------
 489 -- LitStrings, here for convenience only.
 490
 491 type LitString = Ptr ()
 492
 493 mkLitString# :: Addr# -> LitString
 494 mkLitString# a# = Ptr a#
 495 \end{code}