2 % (c) The GRASP/AQUA Project, Glasgow University, 1997-1998
6 Compact representations of character strings with
7 unique identifiers (hash-cons'ish).
12 FastString(..), -- not abstract, for now.
15 mkFastString, -- :: String -> FastString
16 mkFastSubString, -- :: Addr -> Int -> Int -> FastString
17 mkFastSubStringFO, -- :: ForeignObj -> Int -> Int -> FastString
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
25 mkFastString#, -- :: Addr# -> Int# -> FastString
26 mkFastSubStringBA#, -- :: ByteArray# -> Int# -> Int# -> FastString
27 mkFastSubString#, -- :: Addr# -> Int# -> Int# -> FastString
28 mkFastSubStringFO#, -- :: ForeignObj# -> Int# -> Int# -> FastString
30 mkFastStringInt, -- :: [Int] -> FastString
32 uniqueOfFS, -- :: FastString -> Int#
33 lengthFS, -- :: FastString -> Int
34 nullFastString, -- :: FastString -> Bool
36 unpackFS, -- :: FastString -> String
37 unpackIntFS, -- :: FastString -> [Int]
38 appendFS, -- :: FastString -> FastString -> FastString
39 headFS, -- :: FastString -> Char
40 headIntFS, -- :: FastString -> Int
41 tailFS, -- :: FastString -> FastString
42 concatFS, -- :: [FastString] -> FastString
43 consFS, -- :: Char -> FastString -> FastString
44 indexFS, -- :: FastString -> Int -> Char
46 hPutFS -- :: Handle -> FastString -> IO ()
49 -- This #define suppresses the "import FastString" that
50 -- HsVersions otherwise produces
51 #define COMPILING_FAST_STRING
52 #include "HsVersions.h"
54 #if __GLASGOW_HASKELL__ < 301
56 import STBase ( StateAndPtr#(..) )
57 import IOHandle ( filePtr, readHandle, writeHandle )
58 import IOBase ( Handle__(..), IOError(..), IOErrorType(..),
64 #if __GLASGOW_HASKELL__ < 400
65 import PrelST ( StateAndPtr#(..) )
68 #if __GLASGOW_HASKELL__ <= 303
69 import PrelHandle ( readHandle,
70 # if __GLASGOW_HASKELL__ < 303
77 import PrelIOBase ( Handle__(..), IOError, IOErrorType(..),
78 #if __GLASGOW_HASKELL__ < 400
82 #if __GLASGOW_HASKELL__ >= 303
91 import PrelAddr ( Addr(..) )
92 #if __GLASGOW_HASKELL__ < 407
93 import MutableArray ( MutableArray(..) )
95 import PrelArr ( STArray(..), newSTArray )
96 import IOExts ( hPutBufFull, hPutBufBAFull )
99 -- ForeignObj is now exported abstractly.
100 #if __GLASGOW_HASKELL__ >= 303
101 import PrelForeign ( ForeignObj(..) )
103 import Foreign ( ForeignObj(..) )
106 import IOExts ( IORef, newIORef, readIORef, writeIORef )
108 import Char ( chr, ord )
110 #define hASH_TBL_SIZE 993
112 #if __GLASGOW_HASKELL__ >= 400
117 @FastString@s are packed representations of strings
118 with a unique id for fast comparisons. The unique id
119 is assigned when creating the @FastString@, using
120 a hash table to map from the character string representation
125 = FastString -- packed repr. on the heap.
127 -- 0 => string literal, comparison
132 | CharStr -- external C string
133 Addr# -- pointer to the (null-terminated) bytes in C land.
134 Int# -- length (cached)
136 | UnicodeStr -- if contains characters outside '\1'..'\xFF'
138 [Int] -- character numbers
140 instance Eq FastString where
141 a == b = case cmpFS a b of { LT -> False; EQ -> True; GT -> False }
142 a /= b = case cmpFS a b of { LT -> True; EQ -> False; GT -> True }
144 instance Ord FastString where
145 a <= b = case cmpFS a b of { LT -> True; EQ -> True; GT -> False }
146 a < b = case cmpFS a b of { LT -> True; EQ -> False; GT -> False }
147 a >= b = case cmpFS a b of { LT -> False; EQ -> True; GT -> True }
148 a > b = case cmpFS a b of { LT -> False; EQ -> False; GT -> True }
153 compare a b = cmpFS a b
155 lengthFS :: FastString -> Int
156 lengthFS (FastString _ l# _) = I# l#
157 lengthFS (CharStr a# l#) = I# l#
158 lengthFS (UnicodeStr _ s) = length s
160 nullFastString :: FastString -> Bool
161 nullFastString (FastString _ l# _) = l# ==# 0#
162 nullFastString (CharStr _ l#) = l# ==# 0#
163 nullFastString (UnicodeStr _ []) = True
164 nullFastString (UnicodeStr _ (_:_)) = False
166 unpackFS :: FastString -> String
167 unpackFS (FastString _ l# ba#) = unpackNBytesBA# ba# l#
168 unpackFS (CharStr addr len#) =
173 | otherwise = C# ch : unpack (nh +# 1#)
175 ch = indexCharOffAddr# addr nh
176 unpackFS (UnicodeStr _ s) = map chr s
178 unpackIntFS :: FastString -> [Int]
179 unpackIntFS (UnicodeStr _ s) = s
180 unpackIntFS fs = map ord (unpackFS fs)
182 appendFS :: FastString -> FastString -> FastString
183 appendFS fs1 fs2 = mkFastStringInt (unpackIntFS fs1 ++ unpackIntFS fs2)
185 concatFS :: [FastString] -> FastString
186 concatFS ls = mkFastStringInt (concat (map unpackIntFS ls)) -- ToDo: do better
188 headFS :: FastString -> Char
189 headFS (FastString _ l# ba#) =
190 if l# ># 0# then C# (indexCharArray# ba# 0#) else error ("headFS: empty FS")
191 headFS (CharStr a# l#) =
192 if l# ># 0# then C# (indexCharOffAddr# a# 0#) else error ("headFS: empty FS")
193 headFS (UnicodeStr _ (c:_)) = chr c
194 headFS (UnicodeStr _ []) = error ("headFS: empty FS")
196 headIntFS :: FastString -> Int
197 headIntFS (UnicodeStr _ (c:_)) = c
198 headIntFS fs = ord (headFS fs)
200 indexFS :: FastString -> Int -> Char
201 indexFS f i@(I# i#) =
204 | l# ># 0# && l# ># i# -> C# (indexCharArray# ba# i#)
205 | otherwise -> error (msg (I# l#))
207 | l# ># 0# && l# ># i# -> C# (indexCharOffAddr# a# i#)
208 | otherwise -> error (msg (I# l#))
209 UnicodeStr _ s -> chr (s!!i)
211 msg l = "indexFS: out of range: " ++ show (l,i)
213 tailFS :: FastString -> FastString
214 tailFS (FastString _ l# ba#) = mkFastSubStringBA# ba# 1# (l# -# 1#)
215 tailFS fs = mkFastStringInt (tail (unpackIntFS fs))
217 consFS :: Char -> FastString -> FastString
218 consFS c fs = mkFastStringInt (ord c : unpackIntFS fs)
220 uniqueOfFS :: FastString -> Int#
221 uniqueOfFS (FastString u# _ _) = u#
222 uniqueOfFS (CharStr a# l#) = case mkFastString# a# l# of { FastString u# _ _ -> u#} -- Ugh!
224 [A somewhat moby hack]: to avoid entering all sorts
225 of junk into the hash table, all C char strings
226 are by default left out. The benefit of being in
227 the table is that string comparisons are lightning fast,
228 just an Int# comparison.
230 But, if you want to get the Unique of a CharStr, we
231 enter it into the table and return that unique. This
232 works, but causes the CharStr to be looked up in the hash
233 table each time it is accessed..
235 uniqueOfFS (UnicodeStr u# _) = u#
238 Internally, the compiler will maintain a fast string symbol
239 table, providing sharing and fast comparison. Creation of
240 new @FastString@s then covertly does a lookup, re-using the
241 @FastString@ if there was a hit.
243 Caution: mkFastStringUnicode assumes that if the string is in the
244 table, it sits under the UnicodeStr constructor. Other mkFastString
245 variants analogously assume the FastString constructor.
248 data FastStringTable =
251 (MutableArray# RealWorld [FastString])
253 type FastStringTableVar = IORef FastStringTable
255 string_table :: FastStringTableVar
258 #if __GLASGOW_HASKELL__ < 405
259 stToIO (newArray (0::Int,hASH_TBL_SIZE) [])
260 >>= \ (MutableArray _ arr#) ->
261 #elif __GLASGOW_HASKELL__ < 407
262 stToIO (newArray (0::Int,hASH_TBL_SIZE) [])
263 >>= \ (MutableArray _ _ arr#) ->
265 stToIO (newSTArray (0::Int,hASH_TBL_SIZE) [])
266 >>= \ (STArray _ _ arr#) ->
268 newIORef (FastStringTable 0# arr#))
270 lookupTbl :: FastStringTable -> Int# -> IO [FastString]
271 lookupTbl (FastStringTable _ arr#) i# =
273 #if __GLASGOW_HASKELL__ < 400
274 case readArray# arr# i# s# of { StateAndPtr# s2# r ->
277 readArray# arr# i# s#)
280 updTbl :: FastStringTableVar -> FastStringTable -> Int# -> [FastString] -> IO ()
281 updTbl fs_table_var (FastStringTable uid# arr#) i# ls =
282 IO (\ s# -> case writeArray# arr# i# ls s# of { s2# ->
283 #if __GLASGOW_HASKELL__ < 400
288 writeIORef fs_table_var (FastStringTable (uid# +# 1#) arr#)
290 mkFastString# :: Addr# -> Int# -> FastString
291 mkFastString# a# len# =
293 readIORef string_table >>= \ ft@(FastStringTable uid# tbl#) ->
297 -- _trace ("hashed: "++show (I# h)) $
298 lookupTbl ft h >>= \ lookup_result ->
299 case lookup_result of
301 -- no match, add it to table by copying out the
302 -- the string into a ByteArray
303 -- _trace "empty bucket" $
304 case copyPrefixStr (A# a#) (I# len#) of
305 #if __GLASGOW_HASKELL__ < 405
306 (ByteArray _ barr#) ->
308 (ByteArray _ _ barr#) ->
310 let f_str = FastString uid# len# barr# in
311 updTbl string_table ft h [f_str] >>
312 ({- _trace ("new: " ++ show f_str) $ -} return f_str)
314 -- non-empty `bucket', scan the list looking
315 -- entry with same length and compare byte by byte.
316 -- _trace ("non-empty bucket"++show ls) $
317 case bucket_match ls len# a# of
319 case copyPrefixStr (A# a#) (I# len#) of
320 #if __GLASGOW_HASKELL__ < 405
321 (ByteArray _ barr#) ->
323 (ByteArray _ _ barr#) ->
325 let f_str = FastString uid# len# barr# in
326 updTbl string_table ft h (f_str:ls) >>
327 ( {- _trace ("new: " ++ show f_str) $ -} return f_str)
328 Just v -> {- _trace ("re-use: "++show v) $ -} return v)
330 bucket_match [] _ _ = Nothing
331 bucket_match (v@(FastString _ l# ba#):ls) len# a# =
332 if len# ==# l# && eqStrPrefix a# ba# l# then
335 bucket_match ls len# a#
336 bucket_match (UnicodeStr _ _ : ls) len# a# =
337 bucket_match ls len# a#
339 mkFastSubString# :: Addr# -> Int# -> Int# -> FastString
340 mkFastSubString# a# start# len# = mkFastCharString2 (A# (addrOffset# a# start#)) (I# len#)
342 mkFastSubStringFO# :: ForeignObj# -> Int# -> Int# -> FastString
343 mkFastSubStringFO# fo# start# len# =
345 readIORef string_table >>= \ ft@(FastStringTable uid# tbl#) ->
347 h = hashSubStrFO fo# start# len#
349 lookupTbl ft h >>= \ lookup_result ->
350 case lookup_result of
352 -- no match, add it to table by copying out the
353 -- the string into a ByteArray
354 case copySubStrFO (ForeignObj fo#) (I# start#) (I# len#) of
355 #if __GLASGOW_HASKELL__ < 405
356 (ByteArray _ barr#) ->
358 (ByteArray _ _ barr#) ->
360 let f_str = FastString uid# len# barr# in
361 updTbl string_table ft h [f_str] >>
364 -- non-empty `bucket', scan the list looking
365 -- entry with same length and compare byte by byte.
366 case bucket_match ls start# len# fo# of
368 case copySubStrFO (ForeignObj fo#) (I# start#) (I# len#) of
369 #if __GLASGOW_HASKELL__ < 405
370 (ByteArray _ barr#) ->
372 (ByteArray _ _ barr#) ->
374 let f_str = FastString uid# len# barr# in
375 updTbl string_table ft h (f_str:ls) >>
376 ( {- _trace ("new: " ++ show f_str) $ -} return f_str)
377 Just v -> {- _trace ("re-use: "++show v) $ -} return v)
379 bucket_match [] _ _ _ = Nothing
380 bucket_match (v@(FastString _ l# barr#):ls) start# len# fo# =
381 if len# ==# l# && eqStrPrefixFO fo# barr# start# len# then
384 bucket_match ls start# len# fo#
385 bucket_match (UnicodeStr _ _ : ls) start# len# fo# =
386 bucket_match ls start# len# fo#
388 mkFastSubStringBA# :: ByteArray# -> Int# -> Int# -> FastString
389 mkFastSubStringBA# barr# start# len# =
391 readIORef string_table >>= \ ft@(FastStringTable uid# tbl#) ->
393 h = hashSubStrBA barr# start# len#
395 -- _trace ("hashed(b): "++show (I# h)) $
396 lookupTbl ft h >>= \ lookup_result ->
397 case lookup_result of
399 -- no match, add it to table by copying out the
400 -- the string into a ByteArray
401 -- _trace "empty bucket(b)" $
402 #if __GLASGOW_HASKELL__ < 405
403 case copySubStrBA (ByteArray btm barr#) (I# start#) (I# len#) of
406 case copySubStrBA (ByteArray btm btm barr#) (I# start#) (I# len#) of
407 (ByteArray _ _ ba#) ->
409 let f_str = FastString uid# len# ba# in
410 updTbl string_table ft h [f_str] >>
411 -- _trace ("new(b): " ++ show f_str) $
414 -- non-empty `bucket', scan the list looking
415 -- entry with same length and compare byte by byte.
416 -- _trace ("non-empty bucket(b)"++show ls) $
417 case bucket_match ls start# len# barr# of
419 #if __GLASGOW_HASKELL__ < 405
420 case copySubStrBA (ByteArray btm barr#) (I# start#) (I# len#) of
423 case copySubStrBA (ByteArray btm btm barr#) (I# start#) (I# len#) of
424 (ByteArray _ _ ba#) ->
426 let f_str = FastString uid# len# ba# in
427 updTbl string_table ft h (f_str:ls) >>
428 -- _trace ("new(b): " ++ show f_str) $
431 -- _trace ("re-use(b): "++show v) $
437 bucket_match [] _ _ _ = Nothing
438 bucket_match (v:ls) start# len# ba# =
440 FastString _ l# barr# ->
441 if len# ==# l# && eqStrPrefixBA barr# ba# start# len# then
444 bucket_match ls start# len# ba#
445 UnicodeStr _ _ -> bucket_match ls start# len# ba#
447 mkFastStringUnicode :: [Int] -> FastString
448 mkFastStringUnicode s =
450 readIORef string_table >>= \ ft@(FastStringTable uid# tbl#) ->
454 -- _trace ("hashed(b): "++show (I# h)) $
455 lookupTbl ft h >>= \ lookup_result ->
456 case lookup_result of
458 -- no match, add it to table by copying out the
459 -- the string into a [Int]
460 let f_str = UnicodeStr uid# s in
461 updTbl string_table ft h [f_str] >>
462 -- _trace ("new(b): " ++ show f_str) $
465 -- non-empty `bucket', scan the list looking
466 -- entry with same length and compare byte by byte.
467 -- _trace ("non-empty bucket(b)"++show ls) $
468 case bucket_match ls of
470 let f_str = UnicodeStr uid# s in
471 updTbl string_table ft h (f_str:ls) >>
472 -- _trace ("new(b): " ++ show f_str) $
475 -- _trace ("re-use(b): "++show v) $
479 bucket_match [] = Nothing
480 bucket_match (v@(UnicodeStr _ s'):ls) =
481 if s' == s then Just v else bucket_match ls
482 bucket_match (FastString _ _ _ : ls) = bucket_match ls
484 mkFastCharString :: Addr -> FastString
485 mkFastCharString a@(A# a#) =
486 case strLength a of{ (I# len#) -> CharStr a# len# }
488 mkFastCharString# :: Addr# -> FastString
489 mkFastCharString# a# =
490 case strLength (A# a#) of { (I# len#) -> CharStr a# len# }
492 mkFastCharString2 :: Addr -> Int -> FastString
493 mkFastCharString2 a@(A# a#) (I# len#) = CharStr a# len#
495 mkFastStringNarrow :: String -> FastString
496 mkFastStringNarrow str =
497 case packString str of
498 #if __GLASGOW_HASKELL__ < 405
499 (ByteArray (_,I# len#) frozen#) ->
501 (ByteArray _ (I# len#) frozen#) ->
503 mkFastSubStringBA# frozen# 0# len#
504 {- 0-indexed array, len# == index to one beyond end of string,
505 i.e., (0,1) => empty string. -}
507 mkFastString :: String -> FastString
508 mkFastString str = if all good str
509 then mkFastStringNarrow str
510 else mkFastStringUnicode (map ord str)
512 good c = c >= '\1' && c <= '\xFF'
514 mkFastStringInt :: [Int] -> FastString
515 mkFastStringInt str = if all good str
516 then mkFastStringNarrow (map chr str)
517 else mkFastStringUnicode str
519 good c = c >= 1 && c <= 0xFF
521 mkFastSubString :: Addr -> Int -> Int -> FastString
522 mkFastSubString (A# a#) (I# start#) (I# len#) =
523 mkFastString# (addrOffset# a# start#) len#
525 mkFastSubStringFO :: ForeignObj -> Int -> Int -> FastString
526 mkFastSubStringFO (ForeignObj fo#) (I# start#) (I# len#) =
527 mkFastSubStringFO# fo# start# len#
531 hashStr :: Addr# -> Int# -> Int#
532 -- use the Addr to produce a hash value between 0 & m (inclusive)
536 1# -> ((ord# c0 *# 631#) +# len#) `remInt#` hASH_TBL_SIZE#
537 2# -> ((ord# c0 *# 631#) +# (ord# c1 *# 217#) +# len#) `remInt#` hASH_TBL_SIZE#
538 _ -> ((ord# c0 *# 631#) +# (ord# c1 *# 217#) +# (ord# c2 *# 43#) +# len#) `remInt#` hASH_TBL_SIZE#
540 c0 = indexCharOffAddr# a# 0#
541 c1 = indexCharOffAddr# a# (len# `quotInt#` 2# -# 1#)
542 c2 = indexCharOffAddr# a# (len# -# 1#)
544 c1 = indexCharOffAddr# a# 1#
545 c2 = indexCharOffAddr# a# 2#
548 hashSubStrFO :: ForeignObj# -> Int# -> Int# -> Int#
549 -- use the FO to produce a hash value between 0 & m (inclusive)
550 hashSubStrFO fo# start# len# =
553 1# -> ((ord# c0 *# 631#) +# len#) `remInt#` hASH_TBL_SIZE#
554 2# -> ((ord# c0 *# 631#) +# (ord# c1 *# 217#) +# len#) `remInt#` hASH_TBL_SIZE#
555 _ -> ((ord# c0 *# 631#) +# (ord# c1 *# 217#) +# (ord# c2 *# 43#) +# len#) `remInt#` hASH_TBL_SIZE#
557 c0 = indexCharOffForeignObj# fo# 0#
558 c1 = indexCharOffForeignObj# fo# (len# `quotInt#` 2# -# 1#)
559 c2 = indexCharOffForeignObj# fo# (len# -# 1#)
561 -- c1 = indexCharOffFO# fo# 1#
562 -- c2 = indexCharOffFO# fo# 2#
565 hashSubStrBA :: ByteArray# -> Int# -> Int# -> Int#
566 -- use the byte array to produce a hash value between 0 & m (inclusive)
567 hashSubStrBA ba# start# len# =
570 1# -> ((ord# c0 *# 631#) +# len#) `remInt#` hASH_TBL_SIZE#
571 2# -> ((ord# c0 *# 631#) +# (ord# c1 *# 217#) +# len#) `remInt#` hASH_TBL_SIZE#
572 _ -> ((ord# c0 *# 631#) +# (ord# c1 *# 217#) +# (ord# c2 *# 43#) +# len#) `remInt#` hASH_TBL_SIZE#
574 c0 = indexCharArray# ba# 0#
575 c1 = indexCharArray# ba# (len# `quotInt#` 2# -# 1#)
576 c2 = indexCharArray# ba# (len# -# 1#)
578 -- c1 = indexCharArray# ba# 1#
579 -- c2 = indexCharArray# ba# 2#
581 hashUnicode :: [Int] -> Int#
582 -- use the Addr to produce a hash value between 0 & m (inclusive)
584 hashUnicode [I# c0] = ((c0 *# 631#) +# 1#) `remInt#` hASH_TBL_SIZE#
585 hashUnicode [I# c0, I# c1] = ((c0 *# 631#) +# (c1 *# 217#) +# 2#) `remInt#` hASH_TBL_SIZE#
586 hashUnicode s = ((c0 *# 631#) +# (c1 *# 217#) +# (c2 *# 43#) +# len#) `remInt#` hASH_TBL_SIZE#
590 I# c1 = s !! (I# (len# `quotInt#` 2# -# 1#))
591 I# c2 = s !! (I# (len# -# 1#))
596 cmpFS :: FastString -> FastString -> Ordering
597 cmpFS (UnicodeStr u1# s1) (UnicodeStr u2# s2) = if u1# ==# u2# then EQ
599 cmpFS (UnicodeStr _ s1) s2 = compare s1 (unpackIntFS s2)
600 cmpFS s1 (UnicodeStr _ s2) = compare (unpackIntFS s1) s2
601 cmpFS (FastString u1# _ b1#) (FastString u2# _ b2#) = -- assume non-null chars
606 #if __GLASGOW_HASKELL__ < 405
607 _ccall_ strcmp (ByteArray bot b1#) (ByteArray bot b2#) >>= \ (I# res) ->
609 _ccall_ strcmp (ByteArray bot bot b1#) (ByteArray bot bot b2#) >>= \ (I# res) ->
613 else if res ==# 0# then EQ
617 #if __GLASGOW_HASKELL__ < 405
623 cmpFS (CharStr bs1 len1) (CharStr bs2 len2)
625 _ccall_ strcmp ba1 ba2 >>= \ (I# res) ->
628 else if res ==# 0# then EQ
634 cmpFS (FastString _ len1 bs1) (CharStr bs2 len2)
636 _ccall_ strcmp ba1 ba2 >>= \ (I# res) ->
639 else if res ==# 0# then EQ
643 #if __GLASGOW_HASKELL__ < 405
644 ba1 = ByteArray ((error "")::(Int,Int)) bs1
646 ba1 = ByteArray (error "") ((error "")::Int) bs1
650 cmpFS a@(CharStr _ _) b@(FastString _ _ _)
651 = -- try them the other way 'round
652 case (cmpFS b a) of { LT -> GT; EQ -> EQ; GT -> LT }
656 Outputting @FastString@s is quick, just block copying the chunk (using
660 hPutFS :: Handle -> FastString -> IO ()
661 #if __GLASGOW_HASKELL__ <= 302
662 hPutFS handle (FastString _ l# ba#) =
666 readHandle handle >>= \ htype ->
668 ErrorHandle ioError ->
669 writeHandle handle htype >>
672 writeHandle handle htype >>
673 fail MkIOError(handle,IllegalOperation,"handle is closed")
674 SemiClosedHandle _ _ ->
675 writeHandle handle htype >>
676 fail MkIOError(handle,IllegalOperation,"handle is closed")
678 writeHandle handle htype >>
679 fail MkIOError(handle,IllegalOperation,"handle is not open for writing")
681 let fp = filePtr htype in
683 #if __GLASGOW_HASKELL__ < 405
684 _ccall_ writeFile (ByteArray ((error "")::(Int,Int)) ba#) fp (I# l#) >>= \rc ->
686 _ccall_ writeFile (ByteArray ((error "")::Int) ((error "")::Int) ba#) fp (I# l#) >>= \rc ->
691 constructError "hPutFS" >>= \ err ->
693 hPutFS handle (CharStr a# l#) =
697 readHandle handle >>= \ htype ->
699 ErrorHandle ioError ->
700 writeHandle handle htype >>
703 writeHandle handle htype >>
704 fail MkIOError(handle,IllegalOperation,"handle is closed")
705 SemiClosedHandle _ _ ->
706 writeHandle handle htype >>
707 fail MkIOError(handle,IllegalOperation,"handle is closed")
709 writeHandle handle htype >>
710 fail MkIOError(handle,IllegalOperation,"handle is not open for writing")
712 let fp = filePtr htype in
714 _ccall_ writeFile (A# a#) fp (I# l#) >>= \rc ->
718 constructError "hPutFS" >>= \ err ->
723 hPutFS handle (FastString _ l# ba#)
724 | l# ==# 0# = return ()
725 #if __GLASGOW_HASKELL__ < 405
726 | otherwise = hPutBufBA handle (ByteArray bot ba#) (I# l#)
727 #elif __GLASGOW_HASKELL__ < 407
728 | otherwise = hPutBufBA handle (ByteArray bot bot ba#) (I# l#)
730 | otherwise = do mba <- stToIO $ unsafeThawByteArray (ByteArray (bot::Int) bot ba#)
731 hPutBufBAFull handle mba (I# l#)
734 bot = error "hPutFS.ba"
736 --ToDo: avoid silly code duplic.
738 hPutFS handle (CharStr a# l#)
739 | l# ==# 0# = return ()
740 #if __GLASGOW_HASKELL__ < 407
741 | otherwise = hPutBuf handle (A# a#) (I# l#)
743 | otherwise = hPutBufFull handle (A# a#) (I# l#)