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