X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Futils%2FFastString.lhs;h=3d63e7f26f08d84f94d55e912df5bd5821e1149a;hb=8ab73b40ac2ac5861b4dd03a50e4624ce3b0d024;hp=92afb6874061892dc7285a576c9b950c2c66e42a;hpb=fbf45eff4372ae40eefa2c2d2f45414c7f050847;p=ghc-hetmet.git

diff --git a/ghc/compiler/utils/FastString.lhs b/ghc/compiler/utils/FastString.lhs
index 92afb68..3d63e7f 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}
 
@@ -7,24 +7,27 @@ Compact representations of character strings with
 unique identifiers (hash-cons'ish).
 
 \begin{code}
-#include "HsVersions.h"
-
 module FastString
        (
 	FastString(..),     -- not abstract, for now.
 
          --names?
         mkFastString,       -- :: String -> FastString
-	mkFastCharString,   -- :: _Addr -> FastString
-	mkFastCharString2,  -- :: _Addr -> Int -> FastString
-        mkFastSubString,    -- :: _Addr -> Int -> Int -> 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
+	mkFastCharString,   -- :: Addr -> FastString
+	mkFastCharString#,  -- :: Addr# -> FastString
+	mkFastCharString2,  -- :: Addr -> Int -> FastString
+
 	mkFastString#,      -- :: Addr# -> Int# -> FastString
         mkFastSubStringBA#, -- :: ByteArray# -> Int# -> Int# -> FastString
         mkFastSubString#,   -- :: Addr# -> Int# -> Int# -> FastString
         mkFastSubStringFO#, -- :: ForeignObj# -> Int# -> Int# -> FastString
        
+        uniqueOfFS,	    -- :: FastString -> Int#
 	lengthFS,	    -- :: FastString -> Int
 	nullFastString,     -- :: FastString -> Bool
 
@@ -36,36 +39,76 @@ module FastString
         tailFS,		    -- :: FastString -> FastString
 	concatFS,	    -- :: [FastString] -> FastString
         consFS,             -- :: Char -> FastString -> FastString
+	indexFS,	    -- :: FastString -> Int -> Char
 
-        hPutFS,		    -- :: Handle -> FastString -> IO ()
-        tagCmpFS	    -- :: FastString -> FastString -> _CMP_TAG
+        hPutFS		    -- :: Handle -> FastString -> IO ()
        ) where
 
-#if __GLASGOW_HASKELL__ <= 201
-import PreludeGlaST
-import PreludeGlaMisc
-import HandleHack
-import Ubiq
+-- This #define suppresses the "import FastString" that
+-- HsVersions otherwise produces
+#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
-import GlaExts
-import Foreign
-import IOBase
-import IOHandle
-import ST
-import STBase
-import {-# SOURCE #-} Unique  ( mkUniqueGrimily, Unique, Uniquable(..) )
-#if __GLASGOW_HASKELL__ == 202
-import PrelBase ( Char (..) )
+import PrelPack
+#if __GLASGOW_HASKELL__ < 400
+import PrelST		( StateAndPtr#(..) )
 #endif
-#if __GLASGOW_HASKELL__ >= 206
-import PackBase
+
+#if __GLASGOW_HASKELL__ <= 303
+import PrelHandle	( readHandle, 
+# if __GLASGOW_HASKELL__ < 303
+			  filePtr,
+# endif
+			  writeHandle
+			)
+#endif
+
+import PrelIOBase	( Handle__(..), IOError(..), IOErrorType(..),
+#if __GLASGOW_HASKELL__ < 400
+		  	  IOResult(..), 
 #endif
+			  IO(..),
+#if __GLASGOW_HASKELL__ >= 303
+			  Handle__Type(..),
+#endif
+		  	  constructError
+			)
 #endif
 
 import PrimPacked
+import GlaExts
+import PrelAddr		( Addr(..) )
+#if __GLASGOW_HASKELL__ < 407
+import MutableArray	( MutableArray(..) )
+#else
+import PrelArr		( STArray(..), newSTArray )
+import IOExts		( hPutBuf, hPutBufBA )
+#endif
+
+-- ForeignObj is now exported abstractly.
+#if __GLASGOW_HASKELL__ >= 303
+import qualified PrelForeign as Foreign  ( ForeignObj(..) )
+#else
+import Foreign		( ForeignObj(..) )
+#endif
+
+import IOExts		( IORef, newIORef, readIORef, writeIORef )
+import IO
 
 #define hASH_TBL_SIZE 993
 
+#if __GLASGOW_HASKELL__ >= 400
+#define IOok STret
+#endif
 \end{code} 
 
 @FastString@s are packed representations of strings
@@ -88,42 +131,29 @@ data FastString
       Int#       -- length  (cached)
 
 instance Eq FastString where
-  a == b = case tagCmpFS a b of { _LT -> False; _EQ -> True;  _GT -> False }
-  a /= b = case tagCmpFS a b of { _LT -> True;  _EQ -> False; _GT -> True  }
-
-{-
- (FastString u1# _ _) == (FastString u2# _ _) = u1# ==# u2#
--}
-
-instance Uniquable FastString where
- uniqueOf (FastString u# _ _) = mkUniqueGrimily u#
- uniqueOf (CharStr a# l#) =
-   {-
-     [A somewhat moby hack]: to avoid entering all sorts
-     of junk into the hash table, all C char strings
-     are by default left out. The benefit of being in
-     the table is that string comparisons are lightning fast,
-     just an Int# comparison.
-   
-     But, if you want to get the Unique of a CharStr, we 
-     enter it into the table and return that unique. This
-     works, but causes the CharStr to be looked up in the hash
-     table each time it is accessed..
-   -}
-   mkUniqueGrimily (case mkFastString# a# l# of { FastString u# _ _ -> u#}) -- Ugh!
+  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  }
 
-instance Uniquable Int where
- uniqueOf (I# i#) = mkUniqueGrimily i#
-
-instance Text FastString  where
-    showsPrec p ps@(FastString u# _ _) r = showsPrec p (unpackFS ps) r
-    showsPrec p ps r = showsPrec p (unpackFS ps) r
+instance Ord FastString where
+    a <= b = case cmpFS a b of { LT -> True;  EQ -> True;  GT -> False }
+    a <	 b = case cmpFS a b of { LT -> True;  EQ -> False; GT -> False }
+    a >= b = case cmpFS a b of { LT -> False; EQ -> True;  GT -> True  }
+    a >	 b = case cmpFS a b of { LT -> False; EQ -> False; GT -> True  }
+    max x y | x >= y	=  x
+            | otherwise	=  y
+    min x y | x <= y	=  x
+            | otherwise	=  y
+    compare a b = cmpFS a b
 
 getByteArray# :: FastString -> ByteArray#
 getByteArray# (FastString _ _ ba#) = ba#
 
-getByteArray :: FastString -> _ByteArray Int
-getByteArray (FastString _ l# ba#) = _ByteArray (0,I# l#) ba#
+getByteArray :: FastString -> ByteArray Int
+#if __GLASGOW_HASKELL__ < 405
+getByteArray (FastString _ l# ba#) = ByteArray (0,I# l#) ba#
+#else
+getByteArray (FastString _ l# ba#) = ByteArray 0 (I# l#) ba#
+#endif
 
 lengthFS :: FastString -> Int
 lengthFS (FastString _ l# _) = I# l#
@@ -134,11 +164,7 @@ nullFastString (FastString _ l# _) = l# ==# 0#
 nullFastString (CharStr _ l#) = l# ==# 0#
 
 unpackFS :: FastString -> String
-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 205
-unpackFS (FastString _ l# ba#) = byteArrayToString (_ByteArray (0,I# l#) ba#)
-#else
-unpackFS (FastString _ l# ba#) = unpackCStringBA# ba# l#
-#endif
+unpackFS (FastString _ l# ba#) = unpackNBytesBA# ba# l#
 unpackFS (CharStr addr len#) =
  unpack 0#
  where
@@ -160,12 +186,39 @@ headFS f@(FastString _ l# ba#) =
 headFS f@(CharStr a# l#) = 
  if l# ># 0# then C# (indexCharOffAddr# a# 0#) else error ("headFS: empty FS: " ++ unpackFS f)
 
+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#))
+ where
+  msg l =  "indexFS: out of range: " ++ show (l,i)
+
 tailFS :: FastString -> FastString
 tailFS (FastString _ l# ba#) = mkFastSubStringBA# ba# 1# (l# -# 1#)
 
 consFS :: Char -> FastString -> FastString
 consFS c fs = mkFastString (c:unpackFS fs)
 
+uniqueOfFS :: FastString -> Int#
+uniqueOfFS (FastString u# _ _) = u#
+uniqueOfFS (CharStr a# l#)     = case mkFastString# a# l# of { FastString u# _ _ -> u#} -- Ugh!
+   {-
+     [A somewhat moby hack]: to avoid entering all sorts
+     of junk into the hash table, all C char strings
+     are by default left out. The benefit of being in
+     the table is that string comparisons are lightning fast,
+     just an Int# comparison.
+   
+     But, if you want to get the Unique of a CharStr, we 
+     enter it into the table and return that unique. This
+     works, but causes the CharStr to be looked up in the hash
+     table each time it is accessed..
+   -}
 \end{code}
 
 Internally, the compiler will maintain a fast string symbol
@@ -177,48 +230,68 @@ new @FastString@s then covertly does a lookup, re-using the
 data FastStringTable = 
  FastStringTable
     Int#
-    (MutableArray# _RealWorld [FastString])
+    (MutableArray# RealWorld [FastString])
 
-type FastStringTableVar = MutableVar _RealWorld FastStringTable
+type FastStringTableVar = IORef FastStringTable
 
 string_table :: FastStringTableVar
 string_table = 
- unsafePerformPrimIO (
-   newArray (0::Int,hASH_TBL_SIZE) [] `thenPrimIO` \ (_MutableArray _ arr#) ->
-   newVar (FastStringTable 0# arr#))
+ unsafePerformIO (
+#if __GLASGOW_HASKELL__ < 405
+   stToIO (newArray (0::Int,hASH_TBL_SIZE) [])
+	>>= \ (MutableArray _ arr#) ->
+#elif __GLASGOW_HASKELL__ < 407
+   stToIO (newArray (0::Int,hASH_TBL_SIZE) [])
+	>>= \ (MutableArray _ _ arr#) ->
+#else
+   stToIO (newSTArray (0::Int,hASH_TBL_SIZE) [])
+	>>= \ (STArray _ _ arr#) ->
+#endif
+   newIORef (FastStringTable 0# arr#))
 
-lookupTbl :: FastStringTable -> Int# -> PrimIO [FastString]
+lookupTbl :: FastStringTable -> Int# -> IO [FastString]
 lookupTbl (FastStringTable _ arr#) i# =
-  MkST ( \ (S# s#) ->
+  IO ( \ s# ->
+#if __GLASGOW_HASKELL__ < 400
   case readArray# arr# i# s# of { StateAndPtr# s2# r ->
-    (r, S# s2#) })
+  IOok s2# r })
+#else
+  readArray# arr# i# s#)
+#endif
 
-updTbl :: FastStringTableVar -> FastStringTable -> Int# -> [FastString] -> PrimIO ()
-updTbl (_MutableArray _ var#) (FastStringTable uid# arr#) i# ls =
- MkST ( \ (S# s#) ->
- case writeArray# arr# i# ls s# of { s2# ->
- case writeArray# var# 0# (FastStringTable (uid# +# 1#) arr#) s2# of { s3# ->
-  ((), S# s3#) }})
+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# -> 
+#if __GLASGOW_HASKELL__ < 400
+	IOok s2# () })	>>
+#else
+	(# s2#, () #) }) >>
+#endif
+ writeIORef fs_table_var (FastStringTable (uid# +# 1#) arr#)
 
 mkFastString# :: Addr# -> Int# -> FastString
 mkFastString# a# len# =
- unsafePerformPrimIO  (
-  readVar string_table `thenPrimIO` \ ft@(FastStringTable uid# tbl#) ->
+ unsafePerformIO  (
+  readIORef string_table	>>= \ ft@(FastStringTable uid# tbl#) ->
   let
    h = hashStr a# len#
   in
 --  _trace ("hashed: "++show (I# h)) $
-  lookupTbl ft h	`thenPrimIO` \ lookup_result ->
+  lookupTbl ft h	>>= \ lookup_result ->
   case lookup_result of
     [] -> 
        -- no match, add it to table by copying out the
        -- the string into a ByteArray
        -- _trace "empty bucket" $
        case copyPrefixStr (A# a#) (I# len#) of
-	 (_ByteArray _ barr#) ->  
+#if __GLASGOW_HASKELL__ < 405
+	 (ByteArray _ barr#) ->  
+#else
+	 (ByteArray _ _ barr#) ->  
+#endif
 	   let f_str = FastString uid# len# barr# in
-           updTbl string_table ft h [f_str] `seqPrimIO`
-           ({- _trace ("new: " ++ show f_str)   $ -} returnPrimIO f_str)
+           updTbl string_table ft h [f_str] >>
+           ({- _trace ("new: " ++ show f_str)   $ -} return f_str)
     ls -> 
        -- non-empty `bucket', scan the list looking
        -- entry with same length and compare byte by byte.
@@ -226,11 +299,15 @@ mkFastString# a# len# =
        case bucket_match ls len# a# of
 	 Nothing -> 
            case copyPrefixStr (A# a#) (I# len#) of
-  	    (_ByteArray _ barr#) ->  
+#if __GLASGOW_HASKELL__ < 405
+	     (ByteArray _ barr#) ->  
+#else
+	     (ByteArray _ _ barr#) ->  
+#endif
               let f_str = FastString uid# len# barr# in
-              updTbl string_table ft h (f_str:ls) `seqPrimIO`
-	      ( {- _trace ("new: " ++ show f_str)  $ -} returnPrimIO f_str)
-	 Just v  -> {- _trace ("re-use: "++show v) $ -} returnPrimIO v)
+              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# ba#):ls) len# a# =
@@ -244,32 +321,40 @@ mkFastSubString# a# start# len# = mkFastCharString2 (A# (addrOffset# a# start#))
 
 mkFastSubStringFO# :: ForeignObj# -> Int# -> Int# -> FastString
 mkFastSubStringFO# fo# start# len# =
- unsafePerformPrimIO  (
-  readVar string_table `thenPrimIO` \ ft@(FastStringTable uid# tbl#) ->
+ unsafePerformIO  (
+  readIORef string_table >>= \ ft@(FastStringTable uid# tbl#) ->
   let
    h = hashSubStrFO fo# start# len#
   in
-  lookupTbl ft h	`thenPrimIO` \ lookup_result ->
+  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#) ->  
+#if __GLASGOW_HASKELL__ < 405
+	 (ByteArray _ barr#) ->  
+#else
+	 (ByteArray _ _ barr#) ->  
+#endif
 	   let f_str = FastString uid# len# barr# in
-           updTbl string_table ft h [f_str]       `seqPrimIO`
-	   returnPrimIO f_str
+           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#) ->  
+#if __GLASGOW_HASKELL__ < 405
+	     (ByteArray _ barr#) ->  
+#else
+	     (ByteArray _ _ barr#) ->  
+#endif
               let f_str = FastString uid# len# barr# in
-              updTbl string_table ft  h (f_str:ls) `seqPrimIO`
-	      ( {- _trace ("new: " ++ show f_str) $ -} returnPrimIO f_str)
-	 Just v  -> {- _trace ("re-use: "++show v) $ -} returnPrimIO v)
+              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# =
@@ -281,39 +366,49 @@ mkFastSubStringFO# fo# start# len# =
 
 mkFastSubStringBA# :: ByteArray# -> Int# -> Int# -> FastString
 mkFastSubStringBA# barr# start# len# =
- unsafePerformPrimIO  (
-  readVar string_table `thenPrimIO` \ ft@(FastStringTable uid# tbl#) ->
+ unsafePerformIO  (
+  readIORef string_table	>>= \ ft@(FastStringTable uid# tbl#) ->
   let
    h = hashSubStrBA barr# start# len#
   in
 --  _trace ("hashed(b): "++show (I# h)) $
-  lookupTbl ft h	`thenPrimIO` \ lookup_result ->
+  lookupTbl ft h		>>= \ lookup_result ->
   case lookup_result of
     [] -> 
        -- 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#) ->  
+#if __GLASGOW_HASKELL__ < 405
+       case copySubStrBA (ByteArray btm barr#) (I# start#) (I# len#) of
+         (ByteArray _ ba#) ->  
+#else
+       case copySubStrBA (ByteArray btm btm barr#) (I# start#) (I# len#) of
+         (ByteArray _ _ ba#) ->  
+#endif
           let f_str = FastString uid# len# ba# in
-          updTbl string_table ft h [f_str]     `seqPrimIO`
+          updTbl string_table ft h [f_str]     >>
           -- _trace ("new(b): " ++ show f_str)   $
-	  returnPrimIO 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 start# len# barr# of
 	 Nothing -> 
-          case copySubStrBA (_ByteArray (error "") barr#) (I# start#) (I# len#) of
-            (_ByteArray _ ba#) ->  
+#if __GLASGOW_HASKELL__ < 405
+          case copySubStrBA (ByteArray btm barr#) (I# start#) (I# len#) of
+            (ByteArray _ ba#) ->  
+#else
+          case copySubStrBA (ByteArray btm btm barr#) (I# start#) (I# len#) of
+            (ByteArray _ _ ba#) ->  
+#endif
               let f_str = FastString uid# len# ba# in
-              updTbl string_table ft h (f_str:ls) `seqPrimIO`
+              updTbl string_table ft h (f_str:ls) >>
 	      -- _trace ("new(b): " ++ show f_str)   $
-	      returnPrimIO f_str
+	      return f_str
 	 Just v  -> 
               -- _trace ("re-use(b): "++show v) $
-	      returnPrimIO v
+	      return v
   )
  where
    btm = error ""
@@ -327,33 +422,36 @@ mkFastSubStringBA# barr# start# len# =
       else
 	 bucket_match ls start# len# ba#
 
-mkFastCharString :: _Addr -> FastString
+mkFastCharString :: Addr -> FastString
 mkFastCharString a@(A# a#) = 
  case strLength a of{ (I# len#) -> CharStr a# len# }
 
-mkFastCharString2 :: _Addr -> Int -> FastString
+mkFastCharString# :: Addr# -> FastString
+mkFastCharString# a# = 
+ case strLength (A# a#) of { (I# len#) -> CharStr a# len# }
+
+mkFastCharString2 :: Addr -> Int -> FastString
 mkFastCharString2 a@(A# a#) (I# len#) = CharStr a# len#
 
 mkFastString :: String -> FastString
 mkFastString str = 
-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 205
- case stringToByteArray str of
-#else
  case packString str of
+#if __GLASGOW_HASKELL__ < 405
+  (ByteArray (_,I# len#) frozen#) -> 
+#else
+  (ByteArray _ (I# len#) frozen#) -> 
 #endif
-  (_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.    -}
 
-mkFastSubString :: _Addr -> Int -> Int -> FastString
+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}
@@ -383,9 +481,9 @@ hashSubStrFO fo# start# len# =
    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 = indexCharOffFO# fo# 0#
-    c1 = indexCharOffFO# fo# (len# `quotInt#` 2# -# 1#)
-    c2 = indexCharOffFO# fo# (len# -# 1#)
+    c0 = indexCharOffForeignObj# fo# 0#
+    c1 = indexCharOffForeignObj# fo# (len# `quotInt#` 2# -# 1#)
+    c2 = indexCharOffForeignObj# fo# (len# -# 1#)
 
 --    c1 = indexCharOffFO# fo# 1#
 --    c2 = indexCharOffFO# fo# 2#
@@ -410,58 +508,59 @@ hashSubStrBA ba# start# len# =
 \end{code}
 
 \begin{code}
-tagCmpFS :: FastString -> FastString -> _CMP_TAG
-tagCmpFS (FastString u1# _ b1#) (FastString u2# _ b2#) = -- assume non-null chars
+cmpFS :: FastString -> FastString -> Ordering
+cmpFS (FastString u1# _ b1#) (FastString u2# _ b2#) = -- assume non-null chars
   if u1# ==# u2# then
-     _EQ
+     EQ
   else
-   unsafePerformPrimIO (
-    _ccall_ strcmp (_ByteArray bottom b1#) (_ByteArray bottom b2#) `thenPrimIO` \ (I# res) ->
-    returnPrimIO (
-    if      res <#  0# then _LT
-    else if res ==# 0# then _EQ
-    else		    _GT
+   unsafePerformIO (
+#if __GLASGOW_HASKELL__ < 405
+    _ccall_ strcmp (ByteArray bot b1#) (ByteArray bot b2#)	>>= \ (I# res) ->
+#else
+    _ccall_ strcmp (ByteArray bot bot b1#) (ByteArray bot bot b2#) >>= \ (I# res) ->
+#endif
+    return (
+    if      res <#  0# then LT
+    else if res ==# 0# then EQ
+    else		    GT
     ))
   where
-   bottom :: (Int,Int)
-   bottom = error "tagCmp"
-tagCmpFS (CharStr bs1 len1) (CharStr bs2 len2)
-  = unsafePerformPrimIO (
-    _ccall_ strcmp ba1 ba2  `thenPrimIO` \ (I# res) ->
-    returnPrimIO (
-    if      res <#  0# then _LT
-    else if res ==# 0# then _EQ
-    else		    _GT
+#if __GLASGOW_HASKELL__ < 405
+   bot :: (Int,Int)
+#else
+   bot :: Int
+#endif
+   bot = error "tagCmp"
+cmpFS (CharStr bs1 len1) (CharStr bs2 len2)
+  = unsafePerformIO (
+    _ccall_ strcmp ba1 ba2	>>= \ (I# res) ->
+    return (
+    if      res <#  0# then LT
+    else if res ==# 0# then EQ
+    else		    GT
     ))
   where
     ba1 = A# bs1
     ba2 = A# bs2
-tagCmpFS (FastString _ len1 bs1) (CharStr bs2 len2)
- = unsafePerformPrimIO (
-    _ccall_ strcmp ba1 ba2 `thenPrimIO` \ (I# res) ->
-    returnPrimIO (
-     if      res <#  0# then _LT
-     else if res ==# 0# then _EQ
-     else		    _GT
+cmpFS (FastString _ len1 bs1) (CharStr bs2 len2)
+ = unsafePerformIO (
+    _ccall_ strcmp ba1 ba2	>>= \ (I# res) ->
+    return (
+     if      res <#  0# then LT
+     else if res ==# 0# then EQ
+     else		     GT
     ))
   where
-    ba1 = _ByteArray ((error "")::(Int,Int)) bs1
+#if __GLASGOW_HASKELL__ < 405
+    ba1 = ByteArray ((error "")::(Int,Int)) bs1
+#else
+    ba1 = ByteArray (error "") ((error "")::Int) bs1
+#endif
     ba2 = A# bs2
 
-tagCmpFS a@(CharStr _ _) b@(FastString _ _ _)
+cmpFS a@(CharStr _ _) b@(FastString _ _ _)
   = -- try them the other way 'round
-    case (tagCmpFS b a) of { _LT -> _GT; _EQ -> _EQ; _GT -> _LT }
-
-instance Ord FastString where
-    a <= b = case tagCmpFS a b of { _LT -> True;  _EQ -> True;  _GT -> False }
-    a <	 b = case tagCmpFS a b of { _LT -> True;  _EQ -> False; _GT -> False }
-    a >= b = case tagCmpFS a b of { _LT -> False; _EQ -> True;  _GT -> True  }
-    a >	 b = case tagCmpFS a b of { _LT -> False; _EQ -> False; _GT -> True  }
-    max x y | x >= y	=  x
-            | otherwise	=  y
-    min x y | x <= y	=  x
-            | otherwise	=  y
-    _tagCmp a b = tagCmpFS a b
+    case (cmpFS b a) of { LT -> GT; EQ -> EQ; GT -> LT }
 
 \end{code}
 
@@ -469,71 +568,89 @@ Outputting @FastString@s is quick, just block copying the chunk (using
 @fwrite@).
 
 \begin{code}
-#if __GLASGOW_HASKELL__ >= 201
-#define _ErrorHandle IOBase.ErrorHandle
-#define _ReadHandle IOBase.ReadHandle
-#define _ClosedHandle IOBase.ClosedHandle
-#define _SemiClosedHandle IOBase.SemiClosedHandle
-#define _constructError  IOBase.constructError
-#define _filePtr IOHandle.filePtr
-#define failWith fail
-#endif
-
 hPutFS :: Handle -> FastString -> IO ()
+#if __GLASGOW_HASKELL__ <= 302
 hPutFS handle (FastString _ l# ba#) =
  if l# ==# 0# then
     return ()
  else
-    _readHandle handle				    >>= \ htype ->
+    readHandle handle				    >>= \ htype ->
     case htype of 
-      _ErrorHandle ioError ->
-	  _writeHandle handle htype		    >>
-          failWith ioError
-      _ClosedHandle ->
-	  _writeHandle handle htype		    >>
-	  failWith MkIOError(handle,IllegalOperation,"handle is closed")
-      _SemiClosedHandle _ _ ->
-	  _writeHandle handle htype		    >>
-	  failWith MkIOError(handle,IllegalOperation,"handle is closed")
-      _ReadHandle _ _ _ ->
-	  _writeHandle handle htype		    >>
-	  failWith MkIOError(handle,IllegalOperation,"handle is not open for writing")
+      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
+          let fp = filePtr htype in
 	   -- here we go..
-          _ccall_ writeFile (_ByteArray ((error "")::(Int,Int)) ba#) fp (I# l#) `CCALL_THEN` \rc ->
+#if __GLASGOW_HASKELL__ < 405
+          _ccall_ writeFile (ByteArray ((error "")::(Int,Int)) ba#) fp (I# l#) >>= \rc ->
+#else
+          _ccall_ writeFile (ByteArray ((error "")::Int) ((error "")::Int) ba#) fp (I# l#) >>= \rc ->
+#endif
           if rc==0 then
               return ()
           else
-              _constructError "hPutFS"   `CCALL_THEN` \ err ->
-	      failWith err
+              constructError "hPutFS"   >>= \ err ->
+	      fail err
 hPutFS handle (CharStr a# l#) =
  if l# ==# 0# then
     return ()
  else
-    _readHandle handle				    >>= \ htype ->
+    readHandle handle				    >>= \ htype ->
     case htype of 
-      _ErrorHandle ioError ->
-	  _writeHandle handle htype		    >>
-          failWith ioError
-      _ClosedHandle ->
-	  _writeHandle handle htype		    >>
-	  failWith MkIOError(handle,IllegalOperation,"handle is closed")
-      _SemiClosedHandle _ _ ->
-	  _writeHandle handle htype		    >>
-	  failWith MkIOError(handle,IllegalOperation,"handle is closed")
-      _ReadHandle _ _ _ ->
-	  _writeHandle handle htype		    >>
-	  failWith MkIOError(handle,IllegalOperation,"handle is not open for writing")
+      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
+          let fp = filePtr htype in
 	   -- here we go..
-          _ccall_ writeFile (A# a#) fp (I# l#) `CCALL_THEN` \rc ->
+          _ccall_ writeFile (A# a#) fp (I# l#)	>>= \rc ->
           if rc==0 then
               return ()
           else
-              _constructError "hPutFS"   `CCALL_THEN` \ err ->
-	      failWith err
+              constructError "hPutFS"   	>>= \ err ->
+	      fail err
+
+
+#else
+hPutFS handle (FastString _ l# ba#)
+  | l# ==# 0#  = return ()
+#if __GLASGOW_HASKELL__ < 405
+  | otherwise  = hPutBufBA handle (ByteArray bot ba#) (I# l#)
+#elif __GLASGOW_HASKELL__ < 407
+  | otherwise  = hPutBufBA handle (ByteArray bot bot ba#) (I# l#)
+#else
+  | otherwise  = do mba <- stToIO $ unsafeThawByteArray (ByteArray (bot::Int) bot ba#)
+                    hPutBufBA  handle mba (I# l#)
+                    return ()
+#endif
+ where
+  bot = error "hPutFS.ba"
 
 --ToDo: avoid silly code duplic.
+
+hPutFS handle (CharStr a# l#)
+  | l# ==# 0#  = return ()
+  | otherwise  = do hPutBuf handle (A# a#) (I# l#) ; return ()
+
+
+#endif
 \end{code}