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