ghc/compiler/utils/FastString.lhs

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