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