\section{Fast strings}
Compact representations of character strings with
-unique identifiers.
+unique identifiers (hash-cons'ish).
\begin{code}
+#include "HsVersions.h"
+
module FastString
(
FastString(..), -- not abstract, for now.
tagCmpFS -- :: FastString -> FastString -> _CMP_TAG
) where
+#if __GLASGOW_HASKELL__ <= 201
import PreludeGlaST
import PreludeGlaMisc
import HandleHack
+import Ubiq
+#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 (..) )
+#endif
+#if __GLASGOW_HASKELL__ >= 206
+import PackBase
+#endif
+#endif
import PrimPacked
-import Ubiq
#define hASH_TBL_SIZE 993
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
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# l# ba#
+#endif
unpackFS (CharStr addr len#) =
unpack 0#
where
newArray (0::Int,hASH_TBL_SIZE) [] `thenPrimIO` \ (_MutableArray _ arr#) ->
newVar (FastStringTable 0# arr#))
-lookupTbl :: FastStringTable -> Int# -> [FastString]
+lookupTbl :: FastStringTable -> Int# -> PrimIO [FastString]
lookupTbl (FastStringTable _ arr#) i# =
- unsafePerformPrimIO ( \ (S# s#) ->
- case readArray# arr# i# s# of { StateAndPtr# s2# r ->
- (r, S# s2#) } )
+ 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 (S# s#) =
+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#) }}
+ ((), S# s3#) }})
mkFastString# :: Addr# -> Int# -> FastString
mkFastString# a# len# =
h = hashStr a# len#
in
-- _trace ("hashed: "++show (I# h)) $
- case lookupTbl ft h of
+ 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
--- _trace "empty bucket" $
+ -- _trace "empty bucket" $
case copyPrefixStr (A# a#) (I# len#) of
(_ByteArray _ barr#) ->
let f_str = FastString uid# len# barr# in
ls ->
-- non-empty `bucket', scan the list looking
-- entry with same length and compare byte by byte.
--- _trace ("non-empty bucket"++show ls) $
+ -- _trace ("non-empty bucket"++show ls) $
case bucket_match ls len# a# of
Nothing ->
case copyPrefixStr (A# a#) (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)
+ ( {- _trace ("new: " ++ show f_str) $ -} returnPrimIO f_str)
Just v -> {- _trace ("re-use: "++show v) $ -} returnPrimIO v)
where
bucket_match [] _ _ = Nothing
let
h = hashSubStrFO fo# start# len#
in
- case lookupTbl ft h of
+ 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`
+ updTbl string_table ft h [f_str] `seqPrimIO`
returnPrimIO f_str
ls ->
-- non-empty `bucket', scan the list looking
h = hashSubStrBA barr# start# len#
in
-- _trace ("hashed(b): "++show (I# h)) $
- case lookupTbl ft h of
+ 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
--- _trace "empty bucket(b)" $
- case copySubStrBA (_ByteArray (error "") barr#) (I# start#) (I# len#) of
+ -- _trace "empty bucket(b)" $
+ case copySubStrBA (_ByteArray btm barr#) (I# start#) (I# len#) of
(_ByteArray _ ba#) ->
let f_str = FastString uid# len# ba# in
- updTbl string_table ft h [f_str] `seqPrimIO`
- ({- _trace ("new(b): " ++ show f_str) $ -} returnPrimIO f_str)
+ updTbl string_table ft h [f_str] `seqPrimIO`
+ -- _trace ("new(b): " ++ show f_str) $
+ returnPrimIO 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) $
+ -- 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#) ->
let f_str = FastString uid# len# ba# in
updTbl string_table ft h (f_str:ls) `seqPrimIO`
- ({- _trace ("new(b): " ++ show f_str) $ -} returnPrimIO f_str)
- Just v -> {- _trace ("re-use(b): "++show v) $ -} returnPrimIO v)
- where
+ -- _trace ("new(b): " ++ show f_str) $
+ returnPrimIO f_str
+ Just v ->
+ -- _trace ("re-use(b): "++show v) $
+ returnPrimIO v
+ )
+ where
+ btm = error ""
+
bucket_match [] _ _ _ = Nothing
bucket_match (v:ls) start# len# ba# =
case v of
if len# ==# l# && eqStrPrefixBA barr# ba# start# len# then
Just v
else
- bucket_match ls len# start# ba#
+ bucket_match ls start# len# ba#
mkFastCharString :: _Addr -> FastString
mkFastCharString a@(A# a#) =
mkFastString :: String -> FastString
mkFastString str =
- (case stringToByteArray str of
- (_ByteArray (_,I# len#) frozen#) ->
- --
- -- 0-indexed array, len# == index to one beyond end of string,
- -- i.e., (0,1) => empty string.
- --
- {- _trace (show (str,I# len#)) $ -} mkFastSubStringBA# frozen# 0# len#)
+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 205
+ case stringToByteArray str of
+#else
+ case packString str of
+#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 (A# a#) (I# start#) (I# len#)
- = mkFastString# (addrOffset# a# start#) len#
+mkFastSubString (A# a#) (I# start#) (I# len#) =
+ mkFastString# (addrOffset# a# start#) len#
mkFastSubStringFO :: _ForeignObj -> Int -> Int -> FastString
mkFastSubStringFO (_ForeignObj fo#) (I# start#) (I# 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#
-{-
- 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#)
+ c1 = indexCharOffAddr# a# (len# `quotInt#` 2# -# 1#)
+ c2 = indexCharOffAddr# a# (len# -# 1#)
+{-
+ c1 = indexCharOffAddr# a# 1#
+ c2 = indexCharOffAddr# a# 2#
+-}
hashSubStrFO :: ForeignObj# -> Int# -> Int# -> Int#
- -- use the Addr to produce a hash value between 0 & m (inclusive)
+ -- 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#
-{-
- if len# ==# 0# then
- 0#
- else
- ((ord# c0 *# 631#) +# (ord# c1 *# 217#) +# (ord# c2 *# 43#) +# len#)
- `remInt#` hASH_TBL_SIZE#
--}
where
c0 = indexCharOffFO# fo# 0#
- c1 = indexCharOffFO# fo# 1# --(len# `quotInt#` 2# -# 1#)
- c2 = indexCharOffFO# fo# 2# --(len# -# 1#)
+ 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 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#
\end{code}
else _GT
))
where
+ bottom :: (Int,Int)
bottom = error "tagCmp"
tagCmpFS (CharStr bs1 len1) (CharStr bs2 len2)
= unsafePerformPrimIO (
else _GT
))
where
- ba1 = _ByteArray (error "") bs1
+ ba1 = _ByteArray ((error "")::(Int,Int)) bs1
ba2 = A# bs2
tagCmpFS a@(CharStr _ _) b@(FastString _ _ _)
@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 ()
hPutFS handle (FastString _ l# ba#) =
if l# ==# 0# then
failWith ioError
_ClosedHandle ->
_writeHandle handle htype >>
- failWith (IllegalOperation "handle is closed")
+ failWith MkIOError(handle,IllegalOperation,"handle is closed")
_SemiClosedHandle _ _ ->
_writeHandle handle htype >>
- failWith (IllegalOperation "handle is closed")
+ failWith MkIOError(handle,IllegalOperation,"handle is closed")
_ReadHandle _ _ _ ->
_writeHandle handle htype >>
- failWith (IllegalOperation "handle is not open for writing")
+ failWith MkIOError(handle,IllegalOperation,"handle is not open for writing")
other ->
let fp = _filePtr htype in
-- here we go..
- _ccall_ writeFile (_ByteArray (error "") ba#) fp (I# l#) `thenPrimIO` \rc ->
+ _ccall_ writeFile (_ByteArray ((error "")::(Int,Int)) ba#) fp (I# l#) `CCALL_THEN` \rc ->
if rc==0 then
return ()
else
- _constructError "hPutFS" `thenPrimIO` \ err ->
+ _constructError "hPutFS" `CCALL_THEN` \ err ->
failWith err
hPutFS handle (CharStr a# l#) =
if l# ==# 0# then
failWith ioError
_ClosedHandle ->
_writeHandle handle htype >>
- failWith (IllegalOperation "handle is closed")
+ failWith MkIOError(handle,IllegalOperation,"handle is closed")
_SemiClosedHandle _ _ ->
_writeHandle handle htype >>
- failWith (IllegalOperation "handle is closed")
+ failWith MkIOError(handle,IllegalOperation,"handle is closed")
_ReadHandle _ _ _ ->
_writeHandle handle htype >>
- failWith (IllegalOperation "handle is not open for writing")
+ 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#) `thenPrimIO` \rc ->
+ _ccall_ writeFile (A# a#) fp (I# l#) `CCALL_THEN` \rc ->
if rc==0 then
return ()
else
- _constructError "hPutFS" `thenPrimIO` \ err ->
+ _constructError "hPutFS" `CCALL_THEN` \ err ->
failWith err
--ToDo: avoid silly code duplic.
projects / ghc-hetmet.git / blobdiff