X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Futils%2FFastString.lhs;h=86b2a8a444b542b9be8f1a2e0d2cc18d8798b426;hb=2cc5b907318f97e19b28b2ad8ed9ff8c1f401dcc;hp=8a2d89af6d7d6c4d8e59564de756a6f407e35a8d;hpb=be33dbc967b4915cfdb0307ae1b7ae3cee651b8c;p=ghc-hetmet.git

diff --git a/ghc/compiler/utils/FastString.lhs b/ghc/compiler/utils/FastString.lhs
index 8a2d89a..86b2a8a 100644
--- a/ghc/compiler/utils/FastString.lhs
+++ b/ghc/compiler/utils/FastString.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1997
+% (c) The GRASP/AQUA Project, Glasgow University, 1997-1998
 %
 \section{Fast strings}
 
@@ -13,8 +13,8 @@ module FastString
 
          --names?
         mkFastString,       -- :: String -> FastString
+        mkFastStringNarrow, -- :: String -> FastString
         mkFastSubString,    -- :: Addr -> Int -> Int -> FastString
-        mkFastSubStringFO,  -- :: ForeignObj -> Int -> Int -> FastString
 
 	-- These ones hold on to the Addr after they return, and aren't hashed; 
 	-- they are used for literals
@@ -25,20 +25,22 @@ module FastString
 	mkFastString#,      -- :: Addr# -> Int# -> FastString
         mkFastSubStringBA#, -- :: ByteArray# -> Int# -> Int# -> FastString
         mkFastSubString#,   -- :: Addr# -> Int# -> Int# -> FastString
-        mkFastSubStringFO#, -- :: ForeignObj# -> Int# -> Int# -> FastString
-       
+
+        mkFastStringInt,    -- :: [Int] -> FastString
+
         uniqueOfFS,	    -- :: FastString -> Int#
 	lengthFS,	    -- :: FastString -> Int
 	nullFastString,     -- :: FastString -> Bool
 
-	getByteArray#,	    -- :: FastString -> ByteArray#
-        getByteArray,       -- :: FastString -> _ByteArray Int
 	unpackFS,	    -- :: FastString -> String
+	unpackIntFS,	    -- :: FastString -> [Int]
 	appendFS,	    -- :: FastString -> FastString -> FastString
         headFS,		    -- :: FastString -> Char
+        headIntFS,	    -- :: FastString -> Int
         tailFS,		    -- :: FastString -> FastString
 	concatFS,	    -- :: [FastString] -> FastString
         consFS,             -- :: Char -> FastString -> FastString
+	indexFS,	    -- :: FastString -> Int -> Char
 
         hPutFS		    -- :: Handle -> FastString -> IO ()
        ) where
@@ -48,33 +50,42 @@ module FastString
 #define COMPILING_FAST_STRING
 #include "HsVersions.h"
 
-#if __GLASGOW_HASKELL__ < 301
-import PackBase
-import STBase		( StateAndPtr#(..) )
-import IOHandle		( filePtr, readHandle, writeHandle )
-import IOBase		( Handle__(..), IOError(..), IOErrorType(..),
-		  	  IOResult(..), IO(..),
-		  	  constructError
-			)
-#else
+#if __GLASGOW_HASKELL__ < 503
 import PrelPack
-import PrelST		( StateAndPtr#(..) )
-import PrelHandle	( filePtr, readHandle, writeHandle )
-import PrelIOBase	( Handle__(..), IOError(..), IOErrorType(..),
-		  	  IOResult(..), IO(..),
-		  	  constructError
-			)
+import PrelIOBase	( IO(..) )
+#else
+import CString
+import GHC.IOBase	( IO(..) )
 #endif
 
 import PrimPacked
 import GlaExts
+#if __GLASGOW_HASKELL__ < 411
+import PrelAddr		( Addr(..) )
+#else
 import Addr		( Addr(..) )
-import MutableArray	( MutableArray(..) )
-import Foreign		( ForeignObj(..) )
+import Ptr		( Ptr(..) )
+#endif
+#if __GLASGOW_HASKELL__ < 503
+import PrelArr		( STArray(..), newSTArray )
+import IOExts		( hPutBufFull, hPutBufBAFull )
+#else
+import GHC.Arr		( STArray(..), newSTArray )
+import System.IO	( hPutBuf )
+import IOExts 		( hPutBufBA )
+import CString		( unpackNBytesBA# )
+#endif
+
 import IOExts		( IORef, newIORef, readIORef, writeIORef )
 import IO
+import Char             ( chr, ord )
 
 #define hASH_TBL_SIZE 993
+
+#if __GLASGOW_HASKELL__ < 503
+hPutBuf = hPutBufFull
+hPutBufBA = hPutBufBAFull
+#endif
 \end{code} 
 
 @FastString@s are packed representations of strings
@@ -96,6 +107,10 @@ data FastString
       Addr#      -- pointer to the (null-terminated) bytes in C land.
       Int#       -- length  (cached)
 
+  | UnicodeStr   -- if contains characters outside '\1'..'\xFF'
+      Int#       -- unique id
+      [Int]      -- character numbers
+
 instance Eq FastString where
   a == b = case cmpFS a b of { LT -> False; EQ -> True;  GT -> False }
   a /= b = case cmpFS a b of { LT -> True;  EQ -> False; GT -> True  }
@@ -111,26 +126,19 @@ instance Ord FastString where
             | otherwise	=  y
     compare a b = cmpFS a b
 
-instance Text FastString  where
-    showsPrec p ps@(FastString u# _ _) r = showsPrec p (unpackFS ps) r
-    showsPrec p ps r = showsPrec p (unpackFS ps) r
-
-getByteArray# :: FastString -> ByteArray#
-getByteArray# (FastString _ _ ba#) = ba#
-
-getByteArray :: FastString -> ByteArray Int
-getByteArray (FastString _ l# ba#) = ByteArray (0,I# l#) ba#
-
 lengthFS :: FastString -> Int
 lengthFS (FastString _ l# _) = I# l#
 lengthFS (CharStr a# l#) = I# l#
+lengthFS (UnicodeStr _ s) = length s
 
 nullFastString :: FastString -> Bool
 nullFastString (FastString _ l# _) = l# ==# 0#
 nullFastString (CharStr _ l#) = l# ==# 0#
+nullFastString (UnicodeStr _ []) = True
+nullFastString (UnicodeStr _ (_:_)) = False
 
 unpackFS :: FastString -> String
-unpackFS (FastString _ l# ba#) = unpackCStringBA# ba# l#
+unpackFS (FastString _ l# ba#) = unpackNBytesBA# ba# l#
 unpackFS (CharStr addr len#) =
  unpack 0#
  where
@@ -139,24 +147,49 @@ unpackFS (CharStr addr len#) =
       | otherwise   = C# ch : unpack (nh +# 1#)
       where
 	ch = indexCharOffAddr# addr nh
+unpackFS (UnicodeStr _ s) = map chr s
+
+unpackIntFS :: FastString -> [Int]
+unpackIntFS (UnicodeStr _ s) = s
+unpackIntFS fs = map ord (unpackFS fs)
 
 appendFS :: FastString -> FastString -> FastString
-appendFS fs1 fs2 = mkFastString (unpackFS fs1 ++ unpackFS fs2)
+appendFS fs1 fs2 = mkFastStringInt (unpackIntFS fs1 ++ unpackIntFS fs2)
 
 concatFS :: [FastString] -> FastString
-concatFS ls = mkFastString (concat (map (unpackFS) ls)) -- ToDo: do better
+concatFS ls = mkFastStringInt (concat (map unpackIntFS ls)) -- ToDo: do better
 
 headFS :: FastString -> Char
-headFS f@(FastString _ l# ba#) = 
- if l# ># 0# then C# (indexCharArray# ba# 0#) else error ("headFS: empty FS: " ++ unpackFS f)
-headFS f@(CharStr a# l#) = 
- if l# ># 0# then C# (indexCharOffAddr# a# 0#) else error ("headFS: empty FS: " ++ unpackFS f)
+headFS (FastString _ l# ba#) = 
+ if l# ># 0# then C# (indexCharArray# ba# 0#) else error ("headFS: empty FS")
+headFS (CharStr a# l#) = 
+ if l# ># 0# then C# (indexCharOffAddr# a# 0#) else error ("headFS: empty FS")
+headFS (UnicodeStr _ (c:_)) = chr c
+headFS (UnicodeStr _ []) = error ("headFS: empty FS")
+
+headIntFS :: FastString -> Int
+headIntFS (UnicodeStr _ (c:_)) = c
+headIntFS fs = ord (headFS fs)
+
+indexFS :: FastString -> Int -> Char
+indexFS f i@(I# i#) =
+ case f of
+   FastString _ l# ba#
+     | l# ># 0# && l# ># i#  -> C# (indexCharArray# ba# i#)
+     | otherwise	     -> error (msg (I# l#))
+   CharStr a# l#
+     | l# ># 0# && l# ># i#  -> C# (indexCharOffAddr# a# i#)
+     | otherwise	     -> error (msg (I# l#))
+   UnicodeStr _ s	     -> chr (s!!i)
+ where
+  msg l =  "indexFS: out of range: " ++ show (l,i)
 
 tailFS :: FastString -> FastString
 tailFS (FastString _ l# ba#) = mkFastSubStringBA# ba# 1# (l# -# 1#)
+tailFS fs = mkFastStringInt (tail (unpackIntFS fs))
 
 consFS :: Char -> FastString -> FastString
-consFS c fs = mkFastString (c:unpackFS fs)
+consFS c fs = mkFastStringInt (ord c : unpackIntFS fs)
 
 uniqueOfFS :: FastString -> Int#
 uniqueOfFS (FastString u# _ _) = u#
@@ -173,6 +206,7 @@ uniqueOfFS (CharStr a# l#)     = case mkFastString# a# l# of { FastString u# _ _
      works, but causes the CharStr to be looked up in the hash
      table each time it is accessed..
    -}
+uniqueOfFS (UnicodeStr u# _) = u#
 \end{code}
 
 Internally, the compiler will maintain a fast string symbol
@@ -180,6 +214,10 @@ table, providing sharing and fast comparison. Creation of
 new @FastString@s then covertly does a lookup, re-using the
 @FastString@ if there was a hit.
 
+Caution: mkFastStringUnicode assumes that if the string is in the
+table, it sits under the UnicodeStr constructor. Other mkFastString
+variants analogously assume the FastString constructor.
+
 \begin{code}
 data FastStringTable = 
  FastStringTable
@@ -191,18 +229,19 @@ type FastStringTableVar = IORef FastStringTable
 string_table :: FastStringTableVar
 string_table = 
  unsafePerformIO (
-   stToIO (newArray (0::Int,hASH_TBL_SIZE) [])		>>= \ (MutableArray _ arr#) ->
+   stToIO (newSTArray (0::Int,hASH_TBL_SIZE) [])
+	>>= \ (STArray _ _ arr#) ->
    newIORef (FastStringTable 0# arr#))
 
 lookupTbl :: FastStringTable -> Int# -> IO [FastString]
 lookupTbl (FastStringTable _ arr#) i# =
   IO ( \ s# ->
-  case readArray# arr# i# s# of { StateAndPtr# s2# r ->
-  IOok s2# r })
+  readArray# arr# i# s#)
 
 updTbl :: FastStringTableVar -> FastStringTable -> Int# -> [FastString] -> IO ()
 updTbl fs_table_var (FastStringTable uid# arr#) i# ls =
- IO (\ s# -> case writeArray# arr# i# ls s# of { s2# -> IOok s2# () })	>>
+ IO (\ s# -> case writeArray# arr# i# ls s# of { s2# -> 
+	(# s2#, () #) }) >>
  writeIORef fs_table_var (FastStringTable (uid# +# 1#) arr#)
 
 mkFastString# :: Addr# -> Int# -> FastString
@@ -220,7 +259,7 @@ mkFastString# a# len# =
        -- the string into a ByteArray
        -- _trace "empty bucket" $
        case copyPrefixStr (A# a#) (I# len#) of
-	 (ByteArray _ barr#) ->  
+	 (ByteArray _ _ barr#) ->  
 	   let f_str = FastString uid# len# barr# in
            updTbl string_table ft h [f_str] >>
            ({- _trace ("new: " ++ show f_str)   $ -} return f_str)
@@ -231,7 +270,7 @@ mkFastString# a# len# =
        case bucket_match ls len# a# of
 	 Nothing -> 
            case copyPrefixStr (A# a#) (I# len#) of
-  	    (ByteArray _ barr#) ->  
+	     (ByteArray _ _ barr#) ->  
               let f_str = FastString uid# len# barr# in
               updTbl string_table ft h (f_str:ls) >>
 	      ( {- _trace ("new: " ++ show f_str)  $ -} return f_str)
@@ -243,47 +282,12 @@ mkFastString# a# len# =
 	 Just v
       else
 	 bucket_match ls len# a#
+   bucket_match (UnicodeStr _ _ : ls) len# a# =
+      bucket_match ls len# a#
 
 mkFastSubString# :: Addr# -> Int# -> Int# -> FastString
 mkFastSubString# a# start# len# = mkFastCharString2 (A# (addrOffset# a# start#)) (I# len#)
 
-mkFastSubStringFO# :: ForeignObj# -> Int# -> Int# -> FastString
-mkFastSubStringFO# fo# start# len# =
- unsafePerformIO  (
-  readIORef string_table >>= \ ft@(FastStringTable uid# tbl#) ->
-  let
-   h = hashSubStrFO fo# start# len#
-  in
-  lookupTbl ft h	>>= \ lookup_result ->
-  case lookup_result of
-    [] -> 
-       -- no match, add it to table by copying out the
-       -- the string into a ByteArray
-       case copySubStrFO (_ForeignObj fo#) (I# start#) (I# len#) of
-	 (ByteArray _ barr#) ->  
-	   let f_str = FastString uid# len# barr# in
-           updTbl string_table ft h [f_str]       >>
-	   return f_str
-    ls -> 
-       -- non-empty `bucket', scan the list looking
-       -- entry with same length and compare byte by byte.
-       case bucket_match ls start# len# fo# of
-	 Nothing -> 
-           case copySubStrFO (_ForeignObj fo#) (I# start#) (I# len#) of
-   	     (ByteArray _ barr#) ->  
-              let f_str = FastString uid# len# barr# in
-              updTbl string_table ft  h (f_str:ls) >>
-	      ( {- _trace ("new: " ++ show f_str) $ -} return f_str)
-	 Just v  -> {- _trace ("re-use: "++show v) $ -} return v)
-  where
-   bucket_match [] _ _ _ = Nothing
-   bucket_match (v@(FastString _ l# barr#):ls) start# len# fo# =
-      if len# ==# l# && eqStrPrefixFO fo# barr# start# len# then
-	 Just v
-      else
-	 bucket_match ls start# len# fo#
-
-
 mkFastSubStringBA# :: ByteArray# -> Int# -> Int# -> FastString
 mkFastSubStringBA# barr# start# len# =
  unsafePerformIO  (
@@ -298,8 +302,8 @@ mkFastSubStringBA# barr# start# len# =
        -- no match, add it to table by copying out the
        -- the string into a ByteArray
        -- _trace "empty bucket(b)" $
-       case copySubStrBA (ByteArray btm barr#) (I# start#) (I# len#) of
-         (ByteArray _ ba#) ->  
+       case copySubStrBA (ByteArray btm btm barr#) (I# start#) (I# len#) of
+         (ByteArray _ _ ba#) ->  
           let f_str = FastString uid# len# ba# in
           updTbl string_table ft h [f_str]     >>
           -- _trace ("new(b): " ++ show f_str)   $
@@ -310,8 +314,8 @@ mkFastSubStringBA# barr# start# len# =
        -- _trace ("non-empty bucket(b)"++show ls) $
        case bucket_match ls start# len# barr# of
 	 Nothing -> 
-          case copySubStrBA (ByteArray (error "") barr#) (I# start#) (I# len#) of
-            (ByteArray _ ba#) ->  
+          case copySubStrBA (ByteArray btm btm barr#) (I# start#) (I# len#) of
+            (ByteArray _ _ ba#) ->  
               let f_str = FastString uid# len# ba# in
               updTbl string_table ft h (f_str:ls) >>
 	      -- _trace ("new(b): " ++ show f_str)   $
@@ -331,6 +335,44 @@ mkFastSubStringBA# barr# start# len# =
 	 Just v
       else
 	 bucket_match ls start# len# ba#
+     UnicodeStr _ _ -> bucket_match ls start# len# ba#
+
+mkFastStringUnicode :: [Int] -> FastString
+mkFastStringUnicode s =
+ unsafePerformIO  (
+  readIORef string_table	>>= \ ft@(FastStringTable uid# tbl#) ->
+  let
+   h = hashUnicode s
+  in
+--  _trace ("hashed(b): "++show (I# h)) $
+  lookupTbl ft h		>>= \ lookup_result ->
+  case lookup_result of
+    [] -> 
+       -- no match, add it to table by copying out the
+       -- the string into a [Int]
+          let f_str = UnicodeStr uid# s in
+          updTbl string_table ft h [f_str]     >>
+          -- _trace ("new(b): " ++ show f_str)   $
+	  return f_str
+    ls -> 
+       -- non-empty `bucket', scan the list looking
+       -- entry with same length and compare byte by byte. 
+       -- _trace ("non-empty bucket(b)"++show ls) $
+       case bucket_match ls of
+	 Nothing -> 
+              let f_str = UnicodeStr uid# s in
+              updTbl string_table ft h (f_str:ls) >>
+	      -- _trace ("new(b): " ++ show f_str)   $
+	      return f_str
+	 Just v  -> 
+              -- _trace ("re-use(b): "++show v) $
+	      return v
+  )
+ where
+   bucket_match [] = Nothing
+   bucket_match (v@(UnicodeStr _ s'):ls) =
+       if s' == s then Just v else bucket_match ls
+   bucket_match (FastString _ _ _ : ls) = bucket_match ls
 
 mkFastCharString :: Addr -> FastString
 mkFastCharString a@(A# a#) = 
@@ -343,21 +385,31 @@ mkFastCharString# a# =
 mkFastCharString2 :: Addr -> Int -> FastString
 mkFastCharString2 a@(A# a#) (I# len#) = CharStr a# len#
 
-mkFastString :: String -> FastString
-mkFastString str = 
+mkFastStringNarrow :: String -> FastString
+mkFastStringNarrow str =
  case packString str of
-  (ByteArray (_,I# len#) frozen#) -> 
+  (ByteArray _ (I# len#) frozen#) -> 
     mkFastSubStringBA# frozen# 0# len#
     {- 0-indexed array, len# == index to one beyond end of string,
        i.e., (0,1) => empty string.    -}
 
+mkFastString :: String -> FastString
+mkFastString str = if all good str
+    then mkFastStringNarrow str
+    else mkFastStringUnicode (map ord str)
+    where
+    good c = c >= '\1' && c <= '\xFF'
+
+mkFastStringInt :: [Int] -> FastString
+mkFastStringInt str = if all good str
+    then mkFastStringNarrow (map chr str)
+    else mkFastStringUnicode str
+    where
+    good c = c >= 1 && c <= 0xFF
+
 mkFastSubString :: Addr -> Int -> Int -> FastString
 mkFastSubString (A# a#) (I# start#) (I# len#) =
  mkFastString# (addrOffset# a# start#) len#
-
-mkFastSubStringFO :: _ForeignObj -> Int -> Int -> FastString
-mkFastSubStringFO (_ForeignObj fo#) (I# start#) (I# len#) =
- mkFastSubStringFO# fo# start# len#
 \end{code}
 
 \begin{code}
@@ -378,23 +430,6 @@ hashStr a# len# =
     c2 = indexCharOffAddr# a# 2#
 -}
 
-hashSubStrFO  :: ForeignObj# -> Int# -> Int# -> Int#
- -- use the FO to produce a hash value between 0 & m (inclusive)
-hashSubStrFO fo# start# len# =
-  case len# of
-   0# -> 0#
-   1# -> ((ord# c0 *# 631#) +# len#) `remInt#` hASH_TBL_SIZE#
-   2# -> ((ord# c0 *# 631#) +# (ord# c1 *# 217#) +# len#) `remInt#` hASH_TBL_SIZE#
-   _  -> ((ord# c0 *# 631#) +# (ord# c1 *# 217#) +# (ord# c2 *# 43#) +# len#) `remInt#` hASH_TBL_SIZE#
-  where
-    c0 = indexCharOffForeignObj# fo# 0#
-    c1 = indexCharOffForeignObj# fo# (len# `quotInt#` 2# -# 1#)
-    c2 = indexCharOffForeignObj# fo# (len# -# 1#)
-
---    c1 = indexCharOffFO# fo# 1#
---    c2 = indexCharOffFO# fo# 2#
-
-
 hashSubStrBA  :: ByteArray# -> Int# -> Int# -> Int#
  -- use the byte array to produce a hash value between 0 & m (inclusive)
 hashSubStrBA ba# start# len# =
@@ -411,24 +446,40 @@ hashSubStrBA ba# start# len# =
 --    c1 = indexCharArray# ba# 1#
 --    c2 = indexCharArray# ba# 2#
 
+hashUnicode :: [Int] -> Int#
+ -- use the Addr to produce a hash value between 0 & m (inclusive)
+hashUnicode [] = 0#
+hashUnicode [I# c0] = ((c0 *# 631#) +# 1#) `remInt#` hASH_TBL_SIZE#
+hashUnicode [I# c0, I# c1] = ((c0 *# 631#) +# (c1 *# 217#) +# 2#) `remInt#` hASH_TBL_SIZE#
+hashUnicode s = ((c0 *# 631#) +# (c1 *# 217#) +# (c2 *# 43#) +# len#) `remInt#` hASH_TBL_SIZE#
+  where
+    I# len# = length s
+    I# c0 = s !! 0
+    I# c1 = s !! (I# (len# `quotInt#` 2# -# 1#))
+    I# c2 = s !! (I# (len# -# 1#))
+
 \end{code}
 
 \begin{code}
 cmpFS :: FastString -> FastString -> Ordering
+cmpFS (UnicodeStr u1# s1) (UnicodeStr u2# s2) = if u1# ==# u2# then EQ
+    else compare s1 s2
+cmpFS (UnicodeStr _ s1) s2 = compare s1 (unpackIntFS s2)
+cmpFS s1 (UnicodeStr _ s2) = compare (unpackIntFS s1) s2
 cmpFS (FastString u1# _ b1#) (FastString u2# _ b2#) = -- assume non-null chars
   if u1# ==# u2# then
      EQ
   else
    unsafePerformIO (
-    _ccall_ strcmp (ByteArray bottom b1#) (ByteArray bottom b2#)	>>= \ (I# res) ->
+    _ccall_ strcmp (ByteArray bot bot b1#) (ByteArray bot bot b2#) >>= \ (I# res) ->
     return (
     if      res <#  0# then LT
     else if res ==# 0# then EQ
     else		    GT
     ))
   where
-   bottom :: (Int,Int)
-   bottom = error "tagCmp"
+   bot :: Int
+   bot = error "tagCmp"
 cmpFS (CharStr bs1 len1) (CharStr bs2 len2)
   = unsafePerformIO (
     _ccall_ strcmp ba1 ba2	>>= \ (I# res) ->
@@ -449,7 +500,7 @@ cmpFS (FastString _ len1 bs1) (CharStr bs2 len2)
      else		     GT
     ))
   where
-    ba1 = ByteArray ((error "")::(Int,Int)) bs1
+    ba1 = ByteArray (error "") ((error "")::Int) bs1
     ba2 = A# bs2
 
 cmpFS a@(CharStr _ _) b@(FastString _ _ _)
@@ -463,60 +514,25 @@ Outputting @FastString@s is quick, just block copying the chunk (using
 
 \begin{code}
 hPutFS :: Handle -> FastString -> IO ()
-hPutFS handle (FastString _ l# ba#) =
- if l# ==# 0# then
-    return ()
- else
-    readHandle handle				    >>= \ htype ->
-    case htype of 
-      ErrorHandle ioError ->
-	  writeHandle handle htype		    >>
-          fail ioError
-      ClosedHandle ->
-	  writeHandle handle htype		    >>
-	  fail MkIOError(handle,IllegalOperation,"handle is closed")
-      SemiClosedHandle _ _ ->
-	  writeHandle handle htype		    >>
-	  fail MkIOError(handle,IllegalOperation,"handle is closed")
-      ReadHandle _ _ _ ->
-	  writeHandle handle htype		    >>
-	  fail MkIOError(handle,IllegalOperation,"handle is not open for writing")
-      other -> 
-          let fp = filePtr htype in
-	   -- here we go..
-          _ccall_ writeFile (ByteArray ((error "")::(Int,Int)) ba#) fp (I# l#) >>= \rc ->
-          if rc==0 then
-              return ()
-          else
-              constructError "hPutFS"   >>= \ err ->
-	      fail err
-hPutFS handle (CharStr a# l#) =
- if l# ==# 0# then
-    return ()
- else
-    readHandle handle				    >>= \ htype ->
-    case htype of 
-      ErrorHandle ioError ->
-	  writeHandle handle htype		    >>
-          fail ioError
-      ClosedHandle ->
-	  writeHandle handle htype		    >>
-	  fail MkIOError(handle,IllegalOperation,"handle is closed")
-      SemiClosedHandle _ _ ->
-	  writeHandle handle htype		    >>
-	  fail MkIOError(handle,IllegalOperation,"handle is closed")
-      ReadHandle _ _ _ ->
-	  writeHandle handle htype		    >>
-	  fail MkIOError(handle,IllegalOperation,"handle is not open for writing")
-      other -> 
-          let fp = filePtr htype in
-	   -- here we go..
-          _ccall_ writeFile (A# a#) fp (I# l#)	>>= \rc ->
-          if rc==0 then
-              return ()
-          else
-              constructError "hPutFS"   	>>= \ err ->
-	      fail err
+hPutFS handle (FastString _ l# ba#)
+  | l# ==# 0#  = return ()
+  | otherwise  = do mba <- stToIO $ unsafeThawByteArray (ByteArray (bot::Int) bot ba#)
+                    hPutBufBA  handle mba (I# l#)
+ where
+  bot = error "hPutFS.ba"
 
 --ToDo: avoid silly code duplic.
+
+hPutFS handle (CharStr a# l#)
+  | l# ==# 0#  = return ()
+#if __GLASGOW_HASKELL__ < 411
+  | otherwise  = hPutBuf handle (A# a#) (I# l#)
+#else
+  | otherwise  = hPutBuf handle (Ptr a#) (I# l#)
+#endif
+
+-- ONLY here for debugging the NCG (so -ddump-stix works for string
+-- literals); no idea if this is really necessary.  JRS, 010131
+hPutFS handle (UnicodeStr _ is) 
+  = hPutStr handle ("(UnicodeStr " ++ show is ++ ")")
 \end{code}