X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Futils%2FFastString.lhs;h=eebb53a67bcf41109032b83d34f696f5b35576d5;hb=be2838643b5497b6257fe645e6e9a99435efac0e;hp=985c083a95511ab36649084f768b4d0cf3fcbff9;hpb=00638b9287b045767d0edea797abd92639ee6f42;p=ghc-hetmet.git

diff --git a/ghc/compiler/utils/FastString.lhs b/ghc/compiler/utils/FastString.lhs
index 985c083..eebb53a 100644
--- a/ghc/compiler/utils/FastString.lhs
+++ b/ghc/compiler/utils/FastString.lhs
@@ -1,10 +1,10 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1997
+% (c) The GRASP/AQUA Project, Glasgow University, 1997-1998
 %
 \section{Fast strings}
 
 Compact representations of character strings with
-unique identifiers.
+unique identifiers (hash-cons'ish).
 
 \begin{code}
 module FastString
@@ -13,41 +13,101 @@ module FastString
 
          --names?
         mkFastString,       -- :: String -> FastString
-	mkFastCharString,   -- :: _Addr -> FastString
-	mkFastCharString2,  -- :: _Addr -> Int -> FastString
-        mkFastSubString,    -- :: _Addr -> Int -> Int -> FastString
-        mkFastSubStringFO,  -- :: ForeignObj -> Int -> Int -> FastString
+        mkFastSubString,    -- :: Addr -> 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
-       
+
+        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 ()
-        tagCmpFS	    -- :: FastString -> FastString -> _CMP_TAG
+        hPutFS		    -- :: Handle -> FastString -> IO ()
        ) where
 
-import PreludeGlaST
-import PreludeGlaMisc
-import HandleHack
+-- 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 PrelPack
+#if __GLASGOW_HASKELL__ < 400
+import PrelST		( StateAndPtr#(..) )
+#endif
+
+#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 Ubiq
+import GlaExts
+#if __GLASGOW_HASKELL__ < 411
+import PrelAddr		( Addr(..) )
+#else
+import Addr		( Addr(..) )
+import Ptr		( Ptr(..) )
+#endif
+#if __GLASGOW_HASKELL__ < 407
+import MutableArray	( MutableArray(..) )
+#else
+import PrelArr		( STArray(..), newSTArray )
+import IOExts		( hPutBufFull, hPutBufBAFull )
+#endif
+
+import IOExts		( IORef, newIORef, readIORef, writeIORef )
+import IO
+import Char             ( chr, ord )
 
 #define hASH_TBL_SIZE 993
 
+#if __GLASGOW_HASKELL__ >= 400
+#define IOok STret
+#endif
 \end{code} 
 
 @FastString@s are packed representations of strings
@@ -69,55 +129,38 @@ data FastString
       Addr#      -- pointer to the (null-terminated) bytes in C land.
       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!
-
-instance Uniquable Int where
- uniqueOf (I# i#) = mkUniqueGrimily i#
-
-instance Text FastString  where
-    readsPrec p = error "readsPrec: FastString: ToDo"
-    showsPrec p ps@(FastString u# _ _) r = showsPrec p (unpackFS ps) r
-    showsPrec p ps r = showsPrec p (unpackFS ps) r
+  | UnicodeStr   -- if contains characters outside '\1'..'\xFF'
+      Int#       -- unique id
+      [Int]      -- character numbers
 
-getByteArray# :: FastString -> ByteArray#
-getByteArray# (FastString _ _ ba#) = ba#
+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  }
 
-getByteArray :: FastString -> _ByteArray Int
-getByteArray (FastString _ l# ba#) = _ByteArray (0,I# l#) ba#
+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
 
 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#) = byteArrayToString (_ByteArray (0,I# l#) ba#)
+unpackFS (FastString _ l# ba#) = unpackNBytesBA# ba# l#
 unpackFS (CharStr addr len#) =
  unpack 0#
  where
@@ -126,25 +169,66 @@ 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#
+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..
+   -}
+uniqueOfFS (UnicodeStr u# _) = u#
 \end{code}
 
 Internally, the compiler will maintain a fast string symbol
@@ -152,50 +236,76 @@ 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
     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#))
-
-lookupTbl :: FastStringTable -> Int# -> [FastString]
+ 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# -> IO [FastString]
 lookupTbl (FastStringTable _ arr#) i# =
- unsafePerformPrimIO ( \ (S# s#) ->
-   case readArray# arr# i# s# of { StateAndPtr# s2# r ->
-    (r, S# s2#) } )
-
-updTbl :: FastStringTableVar -> FastStringTable -> Int# -> [FastString] -> PrimIO ()
-updTbl (_MutableArray _ var#) (FastStringTable uid# arr#) i# ls (S# s#) =
- case writeArray# arr# i# ls s# of { s2# ->
- case writeArray# var# 0# (FastStringTable (uid# +# 1#) arr#) s2# of { s3# ->
-  ((), S# s3#) }}
+  IO ( \ s# ->
+#if __GLASGOW_HASKELL__ < 400
+  case readArray# arr# i# s# of { StateAndPtr# s2# r ->
+  IOok s2# r })
+#else
+  readArray# arr# i# s#)
+#endif
+
+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)) $
-  case lookupTbl ft h of
+  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.
@@ -203,11 +313,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# =
@@ -215,76 +329,57 @@ 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# =
- unsafePerformPrimIO  (
-  readVar string_table                 `thenPrimIO` \ ft@(FastStringTable uid# tbl#) ->
-  let h = hashSubStrFO fo# start# len# in
-  case lookupTbl ft h 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]       `seqPrimIO`
-	   returnPrimIO 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) `seqPrimIO`
-	      ( {- _trace ("new: " ++ show f_str) $ -} returnPrimIO f_str)
-	 Just v  -> {- _trace ("re-use: "++show v) $ -} returnPrimIO 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# =
- unsafePerformPrimIO  (
-  readVar string_table                   `thenPrimIO` \ ft@(FastStringTable uid# tbl#) ->
-  let h = hashSubStrBA barr# start# len# in
-  -- _trace ("hashed(b): "++show (I# h)) $
-  case lookupTbl ft h of
+ unsafePerformIO  (
+  readIORef string_table	>>= \ ft@(FastStringTable uid# tbl#) ->
+  let
+   h = hashSubStrBA barr# start# len#
+  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 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 ""
@@ -297,30 +392,85 @@ 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 :: 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 = 
- case stringToByteArray str of
-  (_ByteArray (_,I# len#) frozen#) -> 
+mkFastStringNarrow :: String -> FastString
+mkFastStringNarrow str =
+ case packString str of
+#if __GLASGOW_HASKELL__ < 405
+  (ByteArray (_,I# len#) frozen#) -> 
+#else
+  (ByteArray _ (I# len#) frozen#) -> 
+#endif
     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
+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}
@@ -332,113 +482,103 @@ hashStr a# len# =
    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#
-{- Currently UNUSED:
-  if len# ==# 0# then
-     0#
-  else
-     ((ord# c0 *# 631#) +# (ord# c1 *# 217#) +# (ord# c2 *# 43#) +# len#)
-	`remInt#` hASH_TBL_SIZE#
--}
   where
     c0 = indexCharOffAddr# a# 0#
-    c1 = indexCharOffAddr# a# 1# --(len# `quotInt#` 2# -# 1#)
-    c2 = indexCharOffAddr# a# 2# --(len# -# 1#)
-
-hashSubStrFO  :: ForeignObj# -> Int# -> Int# -> Int#
- -- use the Addr 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#
+    c1 = indexCharOffAddr# a# (len# `quotInt#` 2# -# 1#)
+    c2 = indexCharOffAddr# a# (len# -# 1#)
 {-
-  if len# ==# 0# then
-     0#
-  else
-     ((ord# c0 *# 631#) +# (ord# c1 *# 217#) +# (ord# c2 *# 43#) +# len#)
-	`remInt#` hASH_TBL_SIZE#
+    c1 = indexCharOffAddr# a# 1#
+    c2 = indexCharOffAddr# a# 2#
 -}
-  where
-    c0 = indexCharOffFO# fo# 0#
-    c1 = indexCharOffFO# fo# 1# --(len# `quotInt#` 2# -# 1#)
-    c2 = indexCharOffFO# fo# 2# --(len# -# 1#)
-
 
 hashSubStrBA  :: ByteArray# -> Int# -> Int# -> Int#
- -- use the Addr to produce a hash value between 0 & m (inclusive)
+ -- use the byte array to produce a hash value between 0 & m (inclusive)
 hashSubStrBA ba# 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#
-{-
-  if len# ==# 0# then
-     0#
-  else
-     ((ord# c0 *# 631#) +# (ord# c1 *# 217#) +# (ord# c2 *# 43#) +# len#)
-	`remInt#` hASH_TBL_SIZE#
--}
   where
     c0 = indexCharArray# ba# 0#
-    c1 = indexCharArray# ba# 1# --(len# `quotInt#` 2# -# 1#)
-    c2 = indexCharArray# ba# 2# --(len# -# 1#)
+    c1 = indexCharArray# ba# (len# `quotInt#` 2# -# 1#)
+    c2 = indexCharArray# ba# (len# -# 1#)
+
+--    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}
-tagCmpFS :: FastString -> FastString -> _CMP_TAG
-tagCmpFS (FastString u1# _ b1#) (FastString u2# _ b2#) = -- assume non-null chars
+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
+     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 = 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 "") 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}
 
@@ -447,60 +587,97 @@ Outputting @FastString@s is quick, just block copying the chunk (using
 
 \begin{code}
 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 (IllegalOperation "handle is closed")
-      _SemiClosedHandle _ _ ->
-	  _writeHandle handle htype		    >>
-	  failWith (IllegalOperation "handle is closed")
-      _ReadHandle _ _ _ ->
-	  _writeHandle handle htype		    >>
-	  failWith (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 "") ba#) fp (I# l#) `thenPrimIO` \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"   `thenPrimIO` \ 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 (IllegalOperation "handle is closed")
-      _SemiClosedHandle _ _ ->
-	  _writeHandle handle htype		    >>
-	  failWith (IllegalOperation "handle is closed")
-      _ReadHandle _ _ _ ->
-	  _writeHandle handle htype		    >>
-	  failWith (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#) `thenPrimIO` \rc ->
+          _ccall_ writeFile (A# a#) fp (I# l#)	>>= \rc ->
           if rc==0 then
               return ()
           else
-              _constructError "hPutFS"   `thenPrimIO` \ 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#)
+                    hPutBufBAFull  handle mba (I# l#)
+#endif
+ where
+  bot = error "hPutFS.ba"
 
 --ToDo: avoid silly code duplic.
+
+hPutFS handle (CharStr a# l#)
+  | l# ==# 0#  = return ()
+#if __GLASGOW_HASKELL__ < 407
+  | otherwise  = hPutBuf handle (A# a#) (I# l#)
+#elif __GLASGOW_HASKELL__ < 411
+  | otherwise  = hPutBufFull handle (A# a#) (I# l#)
+#else
+  | otherwise  = hPutBufFull 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 ++ ")")
+
+#endif
 \end{code}