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          --names?
  15         mkFastString,       -- :: String -> FastString
  16         mkFastSubString,    -- :: Addr -> Int -> Int -> FastString
  17         mkFastSubStringFO,  -- :: ForeignObj -> Int -> Int -> FastString
  18
  19         -- These ones hold on to the Addr after they return, and aren't hashed;
  20         -- they are used for literals
  21         mkFastCharString,   -- :: Addr -> FastString
  22         mkFastCharString#,  -- :: Addr# -> FastString
  23         mkFastCharString2,  -- :: Addr -> Int -> FastString
  24
  25         mkFastString#,      -- :: Addr# -> Int# -> FastString
  26         mkFastSubStringBA#, -- :: ByteArray# -> Int# -> Int# -> FastString
  27         mkFastSubString#,   -- :: Addr# -> Int# -> Int# -> FastString
  28         mkFastSubStringFO#, -- :: ForeignObj# -> Int# -> Int# -> FastString
  29
  30         mkFastStringInt,    -- :: [Int] -> FastString
  31
  32         uniqueOfFS,         -- :: FastString -> Int#
  33         lengthFS,           -- :: FastString -> Int
  34         nullFastString,     -- :: FastString -> Bool
  35
  36         unpackFS,           -- :: FastString -> String
  37         unpackIntFS,        -- :: FastString -> [Int]
  38         appendFS,           -- :: FastString -> FastString -> FastString
  39         headFS,             -- :: FastString -> Char
  40         headIntFS,          -- :: FastString -> Int
  41         tailFS,             -- :: FastString -> FastString
  42         concatFS,           -- :: [FastString] -> FastString
  43         consFS,             -- :: Char -> FastString -> FastString
  44         indexFS,            -- :: FastString -> Int -> Char
  45
  46         hPutFS              -- :: Handle -> FastString -> IO ()
  47        ) where
  48
  49 -- This #define suppresses the "import FastString" that
  50 -- HsVersions otherwise produces
  51 #define COMPILING_FAST_STRING
  52 #include "HsVersions.h"
  53
  54 #if __GLASGOW_HASKELL__ < 301
  55 import PackBase
  56 import STBase           ( StateAndPtr#(..) )
  57 import IOHandle         ( filePtr, readHandle, writeHandle )
  58 import IOBase           ( Handle__(..), IOError(..), IOErrorType(..),
  59                           IOResult(..), IO(..),
  60                           constructError
  61                         )
  62 #else
  63 import PrelPack
  64 #if __GLASGOW_HASKELL__ < 400
  65 import PrelST           ( StateAndPtr#(..) )
  66 #endif
  67
  68 #if __GLASGOW_HASKELL__ <= 303
  69 import PrelHandle       ( readHandle,
  70 # if __GLASGOW_HASKELL__ < 303
  71                           filePtr,
  72 # endif
  73                           writeHandle
  74                         )
  75 #endif
  76
  77 import PrelIOBase       ( Handle__(..), IOError(..), IOErrorType(..),
  78 #if __GLASGOW_HASKELL__ < 400
  79                           IOResult(..),
  80 #endif
  81                           IO(..),
  82 #if __GLASGOW_HASKELL__ >= 303
  83                           Handle__Type(..),
  84 #endif
  85                           constructError
  86                         )
  87 #endif
  88
  89 import PrimPacked
  90 import GlaExts
  91 import PrelAddr         ( Addr(..) )
  92 #if __GLASGOW_HASKELL__ < 407
  93 import MutableArray     ( MutableArray(..) )
  94 #else
  95 import PrelArr          ( STArray(..), newSTArray )
  96 import IOExts           ( hPutBufFull, hPutBufBAFull )
  97 #endif
  98
  99 -- ForeignObj is now exported abstractly.
 100 #if __GLASGOW_HASKELL__ >= 303
 101 import PrelForeign      ( ForeignObj(..) )
 102 #else
 103 import Foreign          ( ForeignObj(..) )
 104 #endif
 105
 106 import IOExts           ( IORef, newIORef, readIORef, writeIORef )
 107 import IO
 108 import Char             ( chr, ord )
 109
 110 #define hASH_TBL_SIZE 993
 111
 112 #if __GLASGOW_HASKELL__ >= 400
 113 #define IOok STret
 114 #endif
 115 \end{code}
 116
 117 @FastString@s are packed representations of strings
 118 with a unique id for fast comparisons. The unique id
 119 is assigned when creating the @FastString@, using
 120 a hash table to map from the character string representation
 121 to the unique ID.
 122
 123 \begin{code}
 124 data FastString
 125   = FastString   -- packed repr. on the heap.
 126       Int#       -- unique id
 127                  --  0 => string literal, comparison
 128                  --  will
 129       Int#       -- length
 130       ByteArray# -- stuff
 131
 132   | CharStr      -- external C string
 133       Addr#      -- pointer to the (null-terminated) bytes in C land.
 134       Int#       -- length  (cached)
 135
 136   | UnicodeStr   -- if contains characters outside '\1'..'\xFF'
 137       Int#       -- unique id
 138       [Int]      -- character numbers
 139
 140 instance Eq FastString where
 141   a == b = case cmpFS a b of { LT -> False; EQ -> True;  GT -> False }
 142   a /= b = case cmpFS a b of { LT -> True;  EQ -> False; GT -> True  }
 143
 144 instance Ord FastString where
 145     a <= b = case cmpFS a b of { LT -> True;  EQ -> True;  GT -> False }
 146     a <  b = case cmpFS a b of { LT -> True;  EQ -> False; GT -> False }
 147     a >= b = case cmpFS a b of { LT -> False; EQ -> True;  GT -> True  }
 148     a >  b = case cmpFS a b of { LT -> False; EQ -> False; GT -> True  }
 149     max x y | x >= y    =  x
 150             | otherwise =  y
 151     min x y | x <= y    =  x
 152             | otherwise =  y
 153     compare a b = cmpFS a b
 154
 155 lengthFS :: FastString -> Int
 156 lengthFS (FastString _ l# _) = I# l#
 157 lengthFS (CharStr a# l#) = I# l#
 158 lengthFS (UnicodeStr _ s) = length s
 159
 160 nullFastString :: FastString -> Bool
 161 nullFastString (FastString _ l# _) = l# ==# 0#
 162 nullFastString (CharStr _ l#) = l# ==# 0#
 163 nullFastString (UnicodeStr _ []) = True
 164 nullFastString (UnicodeStr _ (_:_)) = False
 165
 166 unpackFS :: FastString -> String
 167 unpackFS (FastString _ l# ba#) = unpackNBytesBA# ba# l#
 168 unpackFS (CharStr addr len#) =
 169  unpack 0#
 170  where
 171     unpack nh
 172       | nh ==# len# = []
 173       | otherwise   = C# ch : unpack (nh +# 1#)
 174       where
 175         ch = indexCharOffAddr# addr nh
 176 unpackFS (UnicodeStr _ s) = map chr s
 177
 178 unpackIntFS :: FastString -> [Int]
 179 unpackIntFS (UnicodeStr _ s) = s
 180 unpackIntFS fs = map ord (unpackFS fs)
 181
 182 appendFS :: FastString -> FastString -> FastString
 183 appendFS fs1 fs2 = mkFastStringInt (unpackIntFS fs1 ++ unpackIntFS fs2)
 184
 185 concatFS :: [FastString] -> FastString
 186 concatFS ls = mkFastStringInt (concat (map unpackIntFS ls)) -- ToDo: do better
 187
 188 headFS :: FastString -> Char
 189 headFS (FastString _ l# ba#) =
 190  if l# ># 0# then C# (indexCharArray# ba# 0#) else error ("headFS: empty FS")
 191 headFS (CharStr a# l#) =
 192  if l# ># 0# then C# (indexCharOffAddr# a# 0#) else error ("headFS: empty FS")
 193 headFS (UnicodeStr _ (c:_)) = chr c
 194 headFS (UnicodeStr _ []) = error ("headFS: empty FS")
 195
 196 headIntFS :: FastString -> Int
 197 headIntFS (UnicodeStr _ (c:_)) = c
 198 headIntFS fs = ord (headFS fs)
 199
 200 indexFS :: FastString -> Int -> Char
 201 indexFS f i@(I# i#) =
 202  case f of
 203    FastString _ l# ba#
 204      | l# ># 0# && l# ># i#  -> C# (indexCharArray# ba# i#)
 205      | otherwise             -> error (msg (I# l#))
 206    CharStr a# l#
 207      | l# ># 0# && l# ># i#  -> C# (indexCharOffAddr# a# i#)
 208      | otherwise             -> error (msg (I# l#))
 209    UnicodeStr _ s            -> chr (s!!i)
 210  where
 211   msg l =  "indexFS: out of range: " ++ show (l,i)
 212
 213 tailFS :: FastString -> FastString
 214 tailFS (FastString _ l# ba#) = mkFastSubStringBA# ba# 1# (l# -# 1#)
 215 tailFS fs = mkFastStringInt (tail (unpackIntFS fs))
 216
 217 consFS :: Char -> FastString -> FastString
 218 consFS c fs = mkFastStringInt (ord c : unpackIntFS fs)
 219
 220 uniqueOfFS :: FastString -> Int#
 221 uniqueOfFS (FastString u# _ _) = u#
 222 uniqueOfFS (CharStr a# l#)     = case mkFastString# a# l# of { FastString u# _ _ -> u#} -- Ugh!
 223    {-
 224      [A somewhat moby hack]: to avoid entering all sorts
 225      of junk into the hash table, all C char strings
 226      are by default left out. The benefit of being in
 227      the table is that string comparisons are lightning fast,
 228      just an Int# comparison.
 229
 230      But, if you want to get the Unique of a CharStr, we
 231      enter it into the table and return that unique. This
 232      works, but causes the CharStr to be looked up in the hash
 233      table each time it is accessed..
 234    -}
 235 uniqueOfFS (UnicodeStr u# _) = u#
 236 \end{code}
 237
 238 Internally, the compiler will maintain a fast string symbol
 239 table, providing sharing and fast comparison. Creation of
 240 new @FastString@s then covertly does a lookup, re-using the
 241 @FastString@ if there was a hit.
 242
 243 Caution: mkFastStringUnicode assumes that if the string is in the
 244 table, it sits under the UnicodeStr constructor. Other mkFastString
 245 variants analogously assume the FastString constructor.
 246
 247 \begin{code}
 248 data FastStringTable =
 249  FastStringTable
 250     Int#
 251     (MutableArray# RealWorld [FastString])
 252
 253 type FastStringTableVar = IORef FastStringTable
 254
 255 string_table :: FastStringTableVar
 256 string_table =
 257  unsafePerformIO (
 258 #if __GLASGOW_HASKELL__ < 405
 259    stToIO (newArray (0::Int,hASH_TBL_SIZE) [])
 260         >>= \ (MutableArray _ arr#) ->
 261 #elif __GLASGOW_HASKELL__ < 407
 262    stToIO (newArray (0::Int,hASH_TBL_SIZE) [])
 263         >>= \ (MutableArray _ _ arr#) ->
 264 #else
 265    stToIO (newSTArray (0::Int,hASH_TBL_SIZE) [])
 266         >>= \ (STArray _ _ arr#) ->
 267 #endif
 268    newIORef (FastStringTable 0# arr#))
 269
 270 lookupTbl :: FastStringTable -> Int# -> IO [FastString]
 271 lookupTbl (FastStringTable _ arr#) i# =
 272   IO ( \ s# ->
 273 #if __GLASGOW_HASKELL__ < 400
 274   case readArray# arr# i# s# of { StateAndPtr# s2# r ->
 275   IOok s2# r })
 276 #else
 277   readArray# arr# i# s#)
 278 #endif
 279
 280 updTbl :: FastStringTableVar -> FastStringTable -> Int# -> [FastString] -> IO ()
 281 updTbl fs_table_var (FastStringTable uid# arr#) i# ls =
 282  IO (\ s# -> case writeArray# arr# i# ls s# of { s2# ->
 283 #if __GLASGOW_HASKELL__ < 400
 284         IOok s2# () })  >>
 285 #else
 286         (# s2#, () #) }) >>
 287 #endif
 288  writeIORef fs_table_var (FastStringTable (uid# +# 1#) arr#)
 289
 290 mkFastString# :: Addr# -> Int# -> FastString
 291 mkFastString# a# len# =
 292  unsafePerformIO  (
 293   readIORef string_table        >>= \ ft@(FastStringTable uid# tbl#) ->
 294   let
 295    h = hashStr a# len#
 296   in
 297 --  _trace ("hashed: "++show (I# h)) $
 298   lookupTbl ft h        >>= \ lookup_result ->
 299   case lookup_result of
 300     [] ->
 301        -- no match, add it to table by copying out the
 302        -- the string into a ByteArray
 303        -- _trace "empty bucket" $
 304        case copyPrefixStr (A# a#) (I# len#) of
 305 #if __GLASGOW_HASKELL__ < 405
 306          (ByteArray _ barr#) ->
 307 #else
 308          (ByteArray _ _ barr#) ->
 309 #endif
 310            let f_str = FastString uid# len# barr# in
 311            updTbl string_table ft h [f_str] >>
 312            ({- _trace ("new: " ++ show f_str)   $ -} return f_str)
 313     ls ->
 314        -- non-empty `bucket', scan the list looking
 315        -- entry with same length and compare byte by byte.
 316        -- _trace ("non-empty bucket"++show ls) $
 317        case bucket_match ls len# a# of
 318          Nothing ->
 319            case copyPrefixStr (A# a#) (I# len#) of
 320 #if __GLASGOW_HASKELL__ < 405
 321              (ByteArray _ barr#) ->
 322 #else
 323              (ByteArray _ _ barr#) ->
 324 #endif
 325               let f_str = FastString uid# len# barr# in
 326               updTbl string_table ft h (f_str:ls) >>
 327               ( {- _trace ("new: " ++ show f_str)  $ -} return f_str)
 328          Just v  -> {- _trace ("re-use: "++show v) $ -} return v)
 329   where
 330    bucket_match [] _ _ = Nothing
 331    bucket_match (v@(FastString _ l# ba#):ls) len# a# =
 332       if len# ==# l# && eqStrPrefix a# ba# l# then
 333          Just v
 334       else
 335          bucket_match ls len# a#
 336    bucket_match (UnicodeStr _ _ : ls) len# a# =
 337       bucket_match ls len# a#
 338
 339 mkFastSubString# :: Addr# -> Int# -> Int# -> FastString
 340 mkFastSubString# a# start# len# = mkFastCharString2 (A# (addrOffset# a# start#)) (I# len#)
 341
 342 mkFastSubStringFO# :: ForeignObj# -> Int# -> Int# -> FastString
 343 mkFastSubStringFO# fo# start# len# =
 344  unsafePerformIO  (
 345   readIORef string_table >>= \ ft@(FastStringTable uid# tbl#) ->
 346   let
 347    h = hashSubStrFO fo# start# len#
 348   in
 349   lookupTbl ft h        >>= \ lookup_result ->
 350   case lookup_result of
 351     [] ->
 352        -- no match, add it to table by copying out the
 353        -- the string into a ByteArray
 354        case copySubStrFO (ForeignObj fo#) (I# start#) (I# len#) of
 355 #if __GLASGOW_HASKELL__ < 405
 356          (ByteArray _ barr#) ->
 357 #else
 358          (ByteArray _ _ barr#) ->
 359 #endif
 360            let f_str = FastString uid# len# barr# in
 361            updTbl string_table ft h [f_str]       >>
 362            return f_str
 363     ls ->
 364        -- non-empty `bucket', scan the list looking
 365        -- entry with same length and compare byte by byte.
 366        case bucket_match ls start# len# fo# of
 367          Nothing ->
 368            case copySubStrFO (ForeignObj fo#) (I# start#) (I# len#) of
 369 #if __GLASGOW_HASKELL__ < 405
 370              (ByteArray _ barr#) ->
 371 #else
 372              (ByteArray _ _ barr#) ->
 373 #endif
 374               let f_str = FastString uid# len# barr# in
 375               updTbl string_table ft  h (f_str:ls) >>
 376               ( {- _trace ("new: " ++ show f_str) $ -} return f_str)
 377          Just v  -> {- _trace ("re-use: "++show v) $ -} return v)
 378   where
 379    bucket_match [] _ _ _ = Nothing
 380    bucket_match (v@(FastString _ l# barr#):ls) start# len# fo# =
 381       if len# ==# l# && eqStrPrefixFO fo# barr# start# len# then
 382          Just v
 383       else
 384          bucket_match ls start# len# fo#
 385    bucket_match (UnicodeStr _ _ : ls) start# len# fo# =
 386       bucket_match ls start# len# fo#
 387
 388 mkFastSubStringBA# :: ByteArray# -> Int# -> Int# -> FastString
 389 mkFastSubStringBA# barr# start# len# =
 390  unsafePerformIO  (
 391   readIORef string_table        >>= \ ft@(FastStringTable uid# tbl#) ->
 392   let
 393    h = hashSubStrBA barr# start# len#
 394   in
 395 --  _trace ("hashed(b): "++show (I# h)) $
 396   lookupTbl ft h                >>= \ lookup_result ->
 397   case lookup_result of
 398     [] ->
 399        -- no match, add it to table by copying out the
 400        -- the string into a ByteArray
 401        -- _trace "empty bucket(b)" $
 402 #if __GLASGOW_HASKELL__ < 405
 403        case copySubStrBA (ByteArray btm barr#) (I# start#) (I# len#) of
 404          (ByteArray _ ba#) ->
 405 #else
 406        case copySubStrBA (ByteArray btm btm barr#) (I# start#) (I# len#) of
 407          (ByteArray _ _ ba#) ->
 408 #endif
 409           let f_str = FastString uid# len# ba# in
 410           updTbl string_table ft h [f_str]     >>
 411           -- _trace ("new(b): " ++ show f_str)   $
 412           return f_str
 413     ls ->
 414        -- non-empty `bucket', scan the list looking
 415        -- entry with same length and compare byte by byte.
 416        -- _trace ("non-empty bucket(b)"++show ls) $
 417        case bucket_match ls start# len# barr# of
 418          Nothing ->
 419 #if __GLASGOW_HASKELL__ < 405
 420           case copySubStrBA (ByteArray btm barr#) (I# start#) (I# len#) of
 421             (ByteArray _ ba#) ->
 422 #else
 423           case copySubStrBA (ByteArray btm btm barr#) (I# start#) (I# len#) of
 424             (ByteArray _ _ ba#) ->
 425 #endif
 426               let f_str = FastString uid# len# ba# in
 427               updTbl string_table ft h (f_str:ls) >>
 428               -- _trace ("new(b): " ++ show f_str)   $
 429               return f_str
 430          Just v  ->
 431               -- _trace ("re-use(b): "++show v) $
 432               return v
 433   )
 434  where
 435    btm = error ""
 436
 437    bucket_match [] _ _ _ = Nothing
 438    bucket_match (v:ls) start# len# ba# =
 439     case v of
 440      FastString _ l# barr# ->
 441       if len# ==# l# && eqStrPrefixBA barr# ba# start# len# then
 442          Just v
 443       else
 444          bucket_match ls start# len# ba#
 445      UnicodeStr _ _ -> bucket_match ls start# len# ba#
 446
 447 mkFastStringUnicode :: [Int] -> FastString
 448 mkFastStringUnicode s =
 449  unsafePerformIO  (
 450   readIORef string_table        >>= \ ft@(FastStringTable uid# tbl#) ->
 451   let
 452    h = hashUnicode s
 453   in
 454 --  _trace ("hashed(b): "++show (I# h)) $
 455   lookupTbl ft h                >>= \ lookup_result ->
 456   case lookup_result of
 457     [] ->
 458        -- no match, add it to table by copying out the
 459        -- the string into a [Int]
 460           let f_str = UnicodeStr uid# s in
 461           updTbl string_table ft h [f_str]     >>
 462           -- _trace ("new(b): " ++ show f_str)   $
 463           return f_str
 464     ls ->
 465        -- non-empty `bucket', scan the list looking
 466        -- entry with same length and compare byte by byte.
 467        -- _trace ("non-empty bucket(b)"++show ls) $
 468        case bucket_match ls of
 469          Nothing ->
 470               let f_str = UnicodeStr uid# s in
 471               updTbl string_table ft h (f_str:ls) >>
 472               -- _trace ("new(b): " ++ show f_str)   $
 473               return f_str
 474          Just v  ->
 475               -- _trace ("re-use(b): "++show v) $
 476               return v
 477   )
 478  where
 479    bucket_match [] = Nothing
 480    bucket_match (v@(UnicodeStr _ s'):ls) =
 481        if s' == s then Just v else bucket_match ls
 482    bucket_match (FastString _ _ _ : ls) = bucket_match ls
 483
 484 mkFastCharString :: Addr -> FastString
 485 mkFastCharString a@(A# a#) =
 486  case strLength a of{ (I# len#) -> CharStr a# len# }
 487
 488 mkFastCharString# :: Addr# -> FastString
 489 mkFastCharString# a# =
 490  case strLength (A# a#) of { (I# len#) -> CharStr a# len# }
 491
 492 mkFastCharString2 :: Addr -> Int -> FastString
 493 mkFastCharString2 a@(A# a#) (I# len#) = CharStr a# len#
 494
 495 mkFastStringNarrow :: String -> FastString
 496 mkFastStringNarrow str =
 497  case packString str of
 498 #if __GLASGOW_HASKELL__ < 405
 499   (ByteArray (_,I# len#) frozen#) ->
 500 #else
 501   (ByteArray _ (I# len#) frozen#) ->
 502 #endif
 503     mkFastSubStringBA# frozen# 0# len#
 504     {- 0-indexed array, len# == index to one beyond end of string,
 505        i.e., (0,1) => empty string.    -}
 506
 507 mkFastString :: String -> FastString
 508 mkFastString str = if all good str
 509     then mkFastStringNarrow str
 510     else mkFastStringUnicode (map ord str)
 511     where
 512     good c = c >= '\1' && c <= '\xFF'
 513
 514 mkFastStringInt :: [Int] -> FastString
 515 mkFastStringInt str = if all good str
 516     then mkFastStringNarrow (map chr str)
 517     else mkFastStringUnicode str
 518     where
 519     good c = c >= 1 && c <= 0xFF
 520
 521 mkFastSubString :: Addr -> Int -> Int -> FastString
 522 mkFastSubString (A# a#) (I# start#) (I# len#) =
 523  mkFastString# (addrOffset# a# start#) len#
 524
 525 mkFastSubStringFO :: ForeignObj -> Int -> Int -> FastString
 526 mkFastSubStringFO (ForeignObj fo#) (I# start#) (I# len#) =
 527  mkFastSubStringFO# fo# start# len#
 528 \end{code}
 529
 530 \begin{code}
 531 hashStr  :: Addr# -> Int# -> Int#
 532  -- use the Addr to produce a hash value between 0 & m (inclusive)
 533 hashStr a# len# =
 534   case len# of
 535    0# -> 0#
 536    1# -> ((ord# c0 *# 631#) +# len#) `remInt#` hASH_TBL_SIZE#
 537    2# -> ((ord# c0 *# 631#) +# (ord# c1 *# 217#) +# len#) `remInt#` hASH_TBL_SIZE#
 538    _  -> ((ord# c0 *# 631#) +# (ord# c1 *# 217#) +# (ord# c2 *# 43#) +# len#) `remInt#` hASH_TBL_SIZE#
 539   where
 540     c0 = indexCharOffAddr# a# 0#
 541     c1 = indexCharOffAddr# a# (len# `quotInt#` 2# -# 1#)
 542     c2 = indexCharOffAddr# a# (len# -# 1#)
 543 {-
 544     c1 = indexCharOffAddr# a# 1#
 545     c2 = indexCharOffAddr# a# 2#
 546 -}
 547
 548 hashSubStrFO  :: ForeignObj# -> Int# -> Int# -> Int#
 549  -- use the FO to produce a hash value between 0 & m (inclusive)
 550 hashSubStrFO fo# start# len# =
 551   case len# of
 552    0# -> 0#
 553    1# -> ((ord# c0 *# 631#) +# len#) `remInt#` hASH_TBL_SIZE#
 554    2# -> ((ord# c0 *# 631#) +# (ord# c1 *# 217#) +# len#) `remInt#` hASH_TBL_SIZE#
 555    _  -> ((ord# c0 *# 631#) +# (ord# c1 *# 217#) +# (ord# c2 *# 43#) +# len#) `remInt#` hASH_TBL_SIZE#
 556   where
 557     c0 = indexCharOffForeignObj# fo# 0#
 558     c1 = indexCharOffForeignObj# fo# (len# `quotInt#` 2# -# 1#)
 559     c2 = indexCharOffForeignObj# fo# (len# -# 1#)
 560
 561 --    c1 = indexCharOffFO# fo# 1#
 562 --    c2 = indexCharOffFO# fo# 2#
 563
 564
 565 hashSubStrBA  :: ByteArray# -> Int# -> Int# -> Int#
 566  -- use the byte array to produce a hash value between 0 & m (inclusive)
 567 hashSubStrBA ba# start# len# =
 568   case len# of
 569    0# -> 0#
 570    1# -> ((ord# c0 *# 631#) +# len#) `remInt#` hASH_TBL_SIZE#
 571    2# -> ((ord# c0 *# 631#) +# (ord# c1 *# 217#) +# len#) `remInt#` hASH_TBL_SIZE#
 572    _  -> ((ord# c0 *# 631#) +# (ord# c1 *# 217#) +# (ord# c2 *# 43#) +# len#) `remInt#` hASH_TBL_SIZE#
 573   where
 574     c0 = indexCharArray# ba# 0#
 575     c1 = indexCharArray# ba# (len# `quotInt#` 2# -# 1#)
 576     c2 = indexCharArray# ba# (len# -# 1#)
 577
 578 --    c1 = indexCharArray# ba# 1#
 579 --    c2 = indexCharArray# ba# 2#
 580
 581 hashUnicode :: [Int] -> Int#
 582  -- use the Addr to produce a hash value between 0 & m (inclusive)
 583 hashUnicode [] = 0#
 584 hashUnicode [I# c0] = ((c0 *# 631#) +# 1#) `remInt#` hASH_TBL_SIZE#
 585 hashUnicode [I# c0, I# c1] = ((c0 *# 631#) +# (c1 *# 217#) +# 2#) `remInt#` hASH_TBL_SIZE#
 586 hashUnicode s = ((c0 *# 631#) +# (c1 *# 217#) +# (c2 *# 43#) +# len#) `remInt#` hASH_TBL_SIZE#
 587   where
 588     I# len# = length s
 589     I# c0 = s !! 0
 590     I# c1 = s !! (I# (len# `quotInt#` 2# -# 1#))
 591     I# c2 = s !! (I# (len# -# 1#))
 592
 593 \end{code}
 594
 595 \begin{code}
 596 cmpFS :: FastString -> FastString -> Ordering
 597 cmpFS (UnicodeStr u1# s1) (UnicodeStr u2# s2) = if u1# ==# u2# then EQ
 598     else compare s1 s2
 599 cmpFS (UnicodeStr _ s1) s2 = compare s1 (unpackIntFS s2)
 600 cmpFS s1 (UnicodeStr _ s2) = compare (unpackIntFS s1) s2
 601 cmpFS (FastString u1# _ b1#) (FastString u2# _ b2#) = -- assume non-null chars
 602   if u1# ==# u2# then
 603      EQ
 604   else
 605    unsafePerformIO (
 606 #if __GLASGOW_HASKELL__ < 405
 607     _ccall_ strcmp (ByteArray bot b1#) (ByteArray bot b2#)      >>= \ (I# res) ->
 608 #else
 609     _ccall_ strcmp (ByteArray bot bot b1#) (ByteArray bot bot b2#) >>= \ (I# res) ->
 610 #endif
 611     return (
 612     if      res <#  0# then LT
 613     else if res ==# 0# then EQ
 614     else                    GT
 615     ))
 616   where
 617 #if __GLASGOW_HASKELL__ < 405
 618    bot :: (Int,Int)
 619 #else
 620    bot :: Int
 621 #endif
 622    bot = error "tagCmp"
 623 cmpFS (CharStr bs1 len1) (CharStr bs2 len2)
 624   = unsafePerformIO (
 625     _ccall_ strcmp ba1 ba2      >>= \ (I# res) ->
 626     return (
 627     if      res <#  0# then LT
 628     else if res ==# 0# then EQ
 629     else                    GT
 630     ))
 631   where
 632     ba1 = A# bs1
 633     ba2 = A# bs2
 634 cmpFS (FastString _ len1 bs1) (CharStr bs2 len2)
 635  = unsafePerformIO (
 636     _ccall_ strcmp ba1 ba2      >>= \ (I# res) ->
 637     return (
 638      if      res <#  0# then LT
 639      else if res ==# 0# then EQ
 640      else                    GT
 641     ))
 642   where
 643 #if __GLASGOW_HASKELL__ < 405
 644     ba1 = ByteArray ((error "")::(Int,Int)) bs1
 645 #else
 646     ba1 = ByteArray (error "") ((error "")::Int) bs1
 647 #endif
 648     ba2 = A# bs2
 649
 650 cmpFS a@(CharStr _ _) b@(FastString _ _ _)
 651   = -- try them the other way 'round
 652     case (cmpFS b a) of { LT -> GT; EQ -> EQ; GT -> LT }
 653
 654 \end{code}
 655
 656 Outputting @FastString@s is quick, just block copying the chunk (using
 657 @fwrite@).
 658
 659 \begin{code}
 660 hPutFS :: Handle -> FastString -> IO ()
 661 #if __GLASGOW_HASKELL__ <= 302
 662 hPutFS handle (FastString _ l# ba#) =
 663  if l# ==# 0# then
 664     return ()
 665  else
 666     readHandle handle                               >>= \ htype ->
 667     case htype of
 668       ErrorHandle ioError ->
 669           writeHandle handle htype                  >>
 670           fail ioError
 671       ClosedHandle ->
 672           writeHandle handle htype                  >>
 673           fail MkIOError(handle,IllegalOperation,"handle is closed")
 674       SemiClosedHandle _ _ ->
 675           writeHandle handle htype                  >>
 676           fail MkIOError(handle,IllegalOperation,"handle is closed")
 677       ReadHandle _ _ _ ->
 678           writeHandle handle htype                  >>
 679           fail MkIOError(handle,IllegalOperation,"handle is not open for writing")
 680       other ->
 681           let fp = filePtr htype in
 682            -- here we go..
 683 #if __GLASGOW_HASKELL__ < 405
 684           _ccall_ writeFile (ByteArray ((error "")::(Int,Int)) ba#) fp (I# l#) >>= \rc ->
 685 #else
 686           _ccall_ writeFile (ByteArray ((error "")::Int) ((error "")::Int) ba#) fp (I# l#) >>= \rc ->
 687 #endif
 688           if rc==0 then
 689               return ()
 690           else
 691               constructError "hPutFS"   >>= \ err ->
 692               fail err
 693 hPutFS handle (CharStr a# l#) =
 694  if l# ==# 0# then
 695     return ()
 696  else
 697     readHandle handle                               >>= \ htype ->
 698     case htype of
 699       ErrorHandle ioError ->
 700           writeHandle handle htype                  >>
 701           fail ioError
 702       ClosedHandle ->
 703           writeHandle handle htype                  >>
 704           fail MkIOError(handle,IllegalOperation,"handle is closed")
 705       SemiClosedHandle _ _ ->
 706           writeHandle handle htype                  >>
 707           fail MkIOError(handle,IllegalOperation,"handle is closed")
 708       ReadHandle _ _ _ ->
 709           writeHandle handle htype                  >>
 710           fail MkIOError(handle,IllegalOperation,"handle is not open for writing")
 711       other ->
 712           let fp = filePtr htype in
 713            -- here we go..
 714           _ccall_ writeFile (A# a#) fp (I# l#)  >>= \rc ->
 715           if rc==0 then
 716               return ()
 717           else
 718               constructError "hPutFS"           >>= \ err ->
 719               fail err
 720
 721
 722 #else
 723 hPutFS handle (FastString _ l# ba#)
 724   | l# ==# 0#  = return ()
 725 #if __GLASGOW_HASKELL__ < 405
 726   | otherwise  = hPutBufBA handle (ByteArray bot ba#) (I# l#)
 727 #elif __GLASGOW_HASKELL__ < 407
 728   | otherwise  = hPutBufBA handle (ByteArray bot bot ba#) (I# l#)
 729 #else
 730   | otherwise  = do mba <- stToIO $ unsafeThawByteArray (ByteArray (bot::Int) bot ba#)
 731                     hPutBufBAFull  handle mba (I# l#)
 732 #endif
 733  where
 734   bot = error "hPutFS.ba"
 735
 736 --ToDo: avoid silly code duplic.
 737
 738 hPutFS handle (CharStr a# l#)
 739   | l# ==# 0#  = return ()
 740 #if __GLASGOW_HASKELL__ < 407
 741   | otherwise  = hPutBuf handle (A# a#) (I# l#)
 742 #else
 743   | otherwise  = hPutBufFull handle (A# a#) (I# l#)
 744 #endif
 745
 746 #endif
 747 \end{code}