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