(
FastString(..), -- not abstract, for now.
- --names?
mkFastString, -- :: String -> FastString
+ mkFastStringNarrow, -- :: String -> 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
+ mkFastString#, -- :: Addr# -> FastString
mkFastSubStringBA#, -- :: ByteArray# -> Int# -> Int# -> FastString
- mkFastSubString#, -- :: Addr# -> Int# -> Int# -> FastString
mkFastStringInt, -- :: [Int] -> FastString
concatFS, -- :: [FastString] -> FastString
consFS, -- :: Char -> FastString -> FastString
indexFS, -- :: FastString -> Int -> Char
+ nilFS, -- :: FastString
+
+ hPutFS, -- :: Handle -> FastString -> IO ()
- hPutFS -- :: Handle -> FastString -> IO ()
+ LitString,
+ mkLitString# -- :: Addr# -> Addr
) where
-- This #define suppresses the "import FastString" that
#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
-#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
- )
+import PrelIOBase ( IO(..) )
+#else
+import CString
+import GHC.IOBase ( IO(..) )
#endif
import PrimPacked
import Addr ( Addr(..) )
import Ptr ( Ptr(..) )
#endif
-#if __GLASGOW_HASKELL__ < 407
-import MutableArray ( MutableArray(..) )
-#else
+#if __GLASGOW_HASKELL__ < 503
import PrelArr ( STArray(..), newSTArray )
-import IOExts ( hPutBufFull, hPutBufBAFull )
+import IOExts ( hPutBufBAFull )
+#else
+import GHC.Arr ( STArray(..), newSTArray )
+import IOExts ( hPutBufBA )
+import CString ( unpackNBytesBA# )
#endif
import IOExts ( IORef, newIORef, readIORef, writeIORef )
#define hASH_TBL_SIZE 993
-#if __GLASGOW_HASKELL__ >= 400
-#define IOok STret
+#if __GLASGOW_HASKELL__ < 503
+hPutBufBA = hPutBufBAFull
#endif
\end{code}
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
+ -- 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
a /= b = case cmpFS a b of { LT -> True; EQ -> False; GT -> True }
instance Ord FastString where
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#) = unpackNBytesBA# ba# l#
-unpackFS (CharStr addr len#) =
- unpack 0#
- where
- unpack nh
- | nh ==# len# = []
- | otherwise = C# ch : unpack (nh +# 1#)
- where
- ch = indexCharOffAddr# addr nh
unpackFS (UnicodeStr _ s) = map chr s
unpackIntFS :: FastString -> [Int]
headFS :: FastString -> Char
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")
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)
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#
+
+nilFS = mkFastString ""
\end{code}
Internally, the compiler will maintain a fast string symbol
string_table :: FastStringTableVar
string_table =
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# =
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# =
+mkFastString# :: Addr# -> FastString
+mkFastString# a# =
+ case strLength (A# a#) of { (I# len#) -> mkFastStringLen# a# len# }
+
+mkFastStringLen# :: Addr# -> Int# -> FastString
+mkFastStringLen# a# len# =
unsafePerformIO (
readIORef string_table >>= \ ft@(FastStringTable uid# tbl#) ->
let
-- the string into a ByteArray
-- _trace "empty bucket" $
case copyPrefixStr (A# a#) (I# len#) of
-#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] >>
({- _trace ("new: " ++ show f_str) $ -} return f_str)
case bucket_match ls len# a# of
Nothing ->
case copyPrefixStr (A# a#) (I# len#) of
-#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) >>
( {- _trace ("new: " ++ show f_str) $ -} return f_str)
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#)
-
mkFastSubStringBA# :: ByteArray# -> Int# -> Int# -> FastString
mkFastSubStringBA# barr# start# len# =
unsafePerformIO (
-- no match, add it to table by copying out the
-- the string into a ByteArray
-- _trace "empty bucket(b)" $
-#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] >>
-- _trace ("new(b): " ++ show f_str) $
-- _trace ("non-empty bucket(b)"++show ls) $
case bucket_match ls start# len# barr# of
Nothing ->
-#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) >>
-- _trace ("new(b): " ++ show f_str) $
if s' == s then Just v else bucket_match ls
bucket_match (FastString _ _ _ : ls) = bucket_match ls
-mkFastCharString :: Addr -> FastString
-mkFastCharString a@(A# a#) =
- case strLength a of{ (I# len#) -> CharStr a# len# }
-
-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#
-
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
mkFastSubString (A# a#) (I# start#) (I# len#) =
- mkFastString# (addrOffset# a# start#) len#
+ mkFastStringLen# (addrOffset# a# start#) len#
\end{code}
\begin{code}
EQ
else
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
-#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
-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
-#if __GLASGOW_HASKELL__ < 405
- ba1 = ByteArray ((error "")::(Int,Int)) bs1
-#else
- ba1 = ByteArray (error "") ((error "")::Int) bs1
-#endif
- ba2 = A# bs2
-
-cmpFS a@(CharStr _ _) b@(FastString _ _ _)
- = -- try them the other way 'round
- case (cmpFS b a) of { LT -> GT; EQ -> EQ; GT -> LT }
-
\end{code}
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 ->
- 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..
-#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" >>= \ 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
-
-
-#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
+ 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__ < 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 ++ ")")
+\end{code}
-#endif
+Here for convenience only.
+
+\begin{code}
+type LitString = Addr
+-- ToDo: make it a Ptr when we don't have to support 4.08 any more
+
+mkLitString# :: Addr# -> LitString
+mkLitString# a# = A# a#
\end{code}