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