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