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

diff --git a/ghc/compiler/utils/FastString.lhs b/ghc/compiler/utils/FastString.lhs
index 92afb68..8dbfefa 100644
--- a/ghc/compiler/utils/FastString.lhs
+++ b/ghc/compiler/utils/FastString.lhs
@@ -1,71 +1,91 @@
 %
-% (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 (hash-cons'ish).
+FastString:	A compact, hash-consed, representation of character strings.
+		Comparison is O(1), and you can get a Unique from them.
+		Generated by the FSLIT macro
+		Turn into SDoc with Outputable.ftext
 
-\begin{code}
-#include "HsVersions.h"
+LitString:	Just a wrapper for the Addr# of a C string (Ptr CChar).
+		Practically no operations
+		Outputing them is fast
+		Generated by the SLIT macro
+		Turn into SDoc with Outputable.ptext
 
+Use LitString unless you want the facilities of FastString
+
+\begin{code}
 module FastString
        (
 	FastString(..),     -- not abstract, for now.
 
-         --names?
         mkFastString,       -- :: String -> FastString
-	mkFastCharString,   -- :: _Addr -> FastString
-	mkFastCharString2,  -- :: _Addr -> Int -> FastString
-        mkFastSubString,    -- :: _Addr -> Int -> Int -> FastString
-        mkFastSubStringFO,  -- :: ForeignObj -> Int -> Int -> FastString
+        mkFastStringNarrow, -- :: String -> FastString
+        mkFastSubString,    -- :: Addr -> Int -> Int -> FastString
 
-	mkFastString#,      -- :: Addr# -> Int# -> FastString
+	mkFastString#,      -- :: Addr# -> 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
+	nilFS,		    -- :: FastString
 
         hPutFS,		    -- :: Handle -> FastString -> IO ()
-        tagCmpFS	    -- :: FastString -> FastString -> _CMP_TAG
+
+	LitString, 
+	mkLitString#	    -- :: Addr# -> LitString
        ) 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__ < 503
+import PrelIOBase	( IO(..) )
 #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 GHC.IOBase	( IO(..) )
 #endif
-#if __GLASGOW_HASKELL__ >= 206
-import PackBase
+
+import PrimPacked
+import GLAEXTS
+import UNSAFE_IO	( unsafePerformIO )
+import MONAD_ST		( stToIO )
+import DATA_IOREF	( IORef, newIORef, readIORef, writeIORef )
+
+#if __GLASGOW_HASKELL__ < 503
+import PrelArr		( STArray(..), newSTArray )
+#else
+import GHC.Arr		( STArray(..), newSTArray )
 #endif
+
+#if __GLASGOW_HASKELL__ >= 504
+import GHC.IOBase
+import GHC.Handle
+import Foreign.C
+#else
+import IOExts		( hPutBufBAFull )
 #endif
 
-import PrimPacked
+import IO
+import Char             ( chr, ord )
 
 #define hASH_TBL_SIZE 993
-
 \end{code} 
 
 @FastString@s are packed representations of strings
@@ -83,89 +103,85 @@ data FastString
       Int#       -- length
       ByteArray# -- stuff
 
-  | CharStr      -- external C string
-      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 tagCmpFS a b of { _LT -> False; _EQ -> True;  _GT -> False }
-  a /= b = case tagCmpFS a b of { _LT -> True;  _EQ -> False; _GT -> True  }
+	-- shortcut for real FastStrings
+  (FastString u1 _ _) == (FastString u2 _ _) = u1 ==# u2
+  a == b = case cmpFS a b of { LT -> False; EQ -> True;  GT -> False }
 
-{-
- (FastString u1# _ _) == (FastString u2# _ _) = u1# ==# u2#
--}
+  (FastString u1 _ _) /= (FastString u2 _ _) = u1 /=# u2
+  a /= b = case cmpFS a b of { LT -> True;  EQ -> False; GT -> True  }
 
-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
-    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#
+instance Ord FastString where
+	-- Compares lexicographically, not by unique
+    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
-#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 (CharStr addr len#) =
- unpack 0#
- where
-    unpack nh
-      | nh ==# len# = []
-      | otherwise   = C# ch : unpack (nh +# 1#)
-      where
-	ch = indexCharOffAddr# addr nh
+unpackFS (FastString _ l# ba#) = unpackNBytesBA (BA ba#) (I# l#)
+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 (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#))
+   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 (UnicodeStr u# _) = u#
 
+nilFS = mkFastString ""
 \end{code}
 
 Internally, the compiler will maintain a fast string symbol
@@ -173,64 +189,71 @@ 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#))
+ unsafePerformIO (
+   stToIO (newSTArray (0::Int,hASH_TBL_SIZE) [])
+	>>= \ (STArray _ _ arr#) ->
+   newIORef (FastStringTable 0# arr#))
 
-lookupTbl :: FastStringTable -> Int# -> PrimIO [FastString]
+lookupTbl :: FastStringTable -> Int# -> IO [FastString]
 lookupTbl (FastStringTable _ arr#) i# =
-  MkST ( \ (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 =
- MkST ( \ (S# s#) ->
- case writeArray# arr# i# ls s# of { s2# ->
- case writeArray# var# 0# (FastStringTable (uid# +# 1#) arr#) s2# of { s3# ->
-  ((), S# s3#) }})
-
-mkFastString# :: Addr# -> Int# -> FastString
-mkFastString# a# len# =
- unsafePerformPrimIO  (
-  readVar string_table `thenPrimIO` \ ft@(FastStringTable uid# tbl#) ->
+  IO ( \ s# ->
+  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# -> 
+	(# s2#, () #) }) >>
+ writeIORef fs_table_var (FastStringTable (uid# +# 1#) arr#)
+
+mkFastString# :: Addr# -> FastString
+mkFastString# a# =
+ case strLength (Ptr a#) of { (I# len#) -> mkFastStringLen# a# len# }
+
+mkFastStringLen# :: Addr# -> Int# -> FastString
+mkFastStringLen# a# len# =
+ 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#) ->  
+       case copyPrefixStr a# (I# len#) of
+	 BA barr# ->  
 	   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.
        -- _trace ("non-empty bucket"++show ls) $
        case bucket_match ls len# a# of
 	 Nothing -> 
-           case copyPrefixStr (A# a#) (I# len#) of
-  	    (_ByteArray _ barr#) ->  
+           case copyPrefixStr a# (I# len#) of
+	     BA 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)
+              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# =
@@ -238,86 +261,46 @@ mkFastString# a# len# =
 	 Just v
       else
 	 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
-  lookupTbl ft h	`thenPrimIO` \ 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]       `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#
-
+   bucket_match (UnicodeStr _ _ : ls) len# a# =
+      bucket_match ls len# a#
 
 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#) ->  
+       case copySubStrBA (BA barr#) (I# start#) (I# len#) of
+         BA ba# ->  
           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#) ->  
+          case copySubStrBA (BA barr#) (I# start#) (I# len#) of
+            BA ba# ->  
               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 ""
-
    bucket_match [] _ _ _ = Nothing
    bucket_match (v:ls) start# len# ba# =
     case v of
@@ -326,34 +309,70 @@ mkFastSubStringBA# barr# start# len# =
 	 Just v
       else
 	 bucket_match ls start# len# ba#
+     UnicodeStr _ _ -> bucket_match ls start# len# ba#
 
-mkFastCharString :: _Addr -> FastString
-mkFastCharString a@(A# a#) = 
- case strLength 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
-#endif
-  (_ByteArray (_,I# len#) frozen#) -> 
+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
+
+mkFastStringNarrow :: String -> FastString
+mkFastStringNarrow str =
+ case packString str of { (I# len#, BA 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 (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#
+ }
+ {- 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# (I# start#) (I# len#) =
+ mkFastStringLen# (a# `plusAddr#` start#) len#
 \end{code}
 
 \begin{code}
@@ -374,23 +393,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 = indexCharOffFO# fo# 0#
-    c1 = indexCharOffFO# fo# (len# `quotInt#` 2# -# 1#)
-    c2 = indexCharOffFO# 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# =
@@ -400,140 +402,113 @@ hashSubStrBA ba# 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 = indexCharArray# ba# 0#
-    c1 = indexCharArray# ba# (len# `quotInt#` 2# -# 1#)
-    c2 = indexCharArray# ba# (len# -# 1#)
+    c0 = indexCharArray# ba# (start# +# 0#)
+    c1 = indexCharArray# ba# (start# +# (len# `quotInt#` 2# -# 1#))
+    c2 = indexCharArray# ba# (start# +# (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
-  if u1# ==# u2# then
-     _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
-    ))
-  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
+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# l1# b1#) (FastString u2# l2# b2#) =
+  if u1# ==# u2# then EQ else
+  let l# = if l1# <=# l2# then l1# else l2# in
+  unsafePerformIO (
+    memcmp b1# b2# l# >>= \ (I# res) ->
+    return (
+    if      res <#  0# then LT
+    else if res ==# 0# then 
+	if l1# ==# l2# then EQ
+	else if l1# <# l2# then LT else GT
+    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
-    ))
-  where
-    ba1 = _ByteArray ((error "")::(Int,Int)) bs1
-    ba2 = A# bs2
 
-tagCmpFS a@(CharStr _ _) b@(FastString _ _ _)
-  = -- try them the other way 'round
-    case (tagCmpFS b a) of { _LT -> _GT; _EQ -> _EQ; _GT -> _LT }
+foreign import ccall "ghc_memcmp" unsafe 
+  memcmp :: ByteArray# -> ByteArray# -> Int# -> IO Int
 
-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
+-- -----------------------------------------------------------------------------
+-- Outputting 'FastString's
 
-\end{code}
+#if __GLASGOW_HASKELL__ >= 504
 
-Outputting @FastString@s is quick, just block copying the chunk (using
-@fwrite@).
+-- this is our own version of hPutBuf for FastStrings, because in
+-- 5.04+ we don't have mutable byte arrays and therefore hPutBufBA.
+-- The closest is hPutArray in Data.Array.IO, but that does some extra
+-- range checks that we want to avoid here.
 
-\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
+foreign import ccall unsafe "__hscore_memcpy_dst_off"
+   memcpy_baoff_ba :: RawBuffer -> Int -> RawBuffer -> CSize -> IO (Ptr ())
+
+hPutFS handle (FastString _ l# ba#)
+  | l# ==# 0#  = return ()
+  | otherwise
+   = do wantWritableHandle "hPutFS" handle $ 
+          \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=stream } -> do
+
+          old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size }
+	    <- readIORef ref
+
+	  let count = I# l#
+	      raw = unsafeCoerce# ba# :: MutableByteArray# RealWorld
+
+          -- enough room in handle buffer?
+          if (size - w > count)
+		-- There's enough room in the buffer:
+		-- just copy the data in and update bufWPtr.
+	    then do memcpy_baoff_ba old_raw w raw (fromIntegral count)
+		    writeIORef ref old_buf{ bufWPtr = w + count }
+		    return ()
+
+		-- else, we have to flush
+	    else do flushed_buf <- flushWriteBuffer fd stream old_buf
+		    writeIORef ref flushed_buf
+		    let this_buf = 
+			    Buffer{ bufBuf=raw, bufState=WriteBuffer, 
+				    bufRPtr=0, bufWPtr=count, bufSize=count }
+		    flushWriteBuffer fd stream this_buf
+		    return ()
+
+#else
 
 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		    >>
-          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")
-      other -> 
-          let fp = _filePtr htype in
-	   -- here we go..
-          _ccall_ writeFile (_ByteArray ((error "")::(Int,Int)) ba#) fp (I# l#) `CCALL_THEN` \rc ->
-          if rc==0 then
-              return ()
-          else
-              _constructError "hPutFS"   `CCALL_THEN` \ err ->
-	      failWith err
-hPutFS handle (CharStr a# l#) =
- if l# ==# 0# then
-    return ()
- else
-    _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")
-      other -> 
-          let fp = _filePtr htype in
-	   -- here we go..
-          _ccall_ writeFile (A# a#) fp (I# l#) `CCALL_THEN` \rc ->
-          if rc==0 then
-              return ()
-          else
-              _constructError "hPutFS"   `CCALL_THEN` \ err ->
-	      failWith err
-
---ToDo: avoid silly code duplic.
+hPutFS handle (FastString _ l# ba#)
+  | l# ==# 0#  = return ()
+  | otherwise  = do mba <- stToIO $ unsafeThawByteArray (ByteArray (bot::Int) bot ba#)
+                    hPutBufBAFull  handle mba (I# l#)
+ where
+  bot = error "hPutFS.ba"
+
+#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 ++ ")")
+
+-- -----------------------------------------------------------------------------
+-- LitStrings, here for convenience only.
+
+type LitString = Ptr ()
+
+mkLitString# :: Addr# -> LitString
+mkLitString# a# = Ptr a#
 \end{code}