-string_table :: FastStringTableVar
-string_table =
- unsafePerformIO (
- stToIO (newArray (0::Int,hASH_TBL_SIZE) []) >>= \ (MutableArray _ arr#) ->
- newIORef (FastStringTable 0# arr#))
-
-lookupTbl :: FastStringTable -> Int# -> IO [FastString]
-lookupTbl (FastStringTable _ arr#) i# =
- IO ( \ s# ->
- case readArray# arr# i# s# of { StateAndPtr# s2# r ->
- IOok s2# r })
-
-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# -> IOok s2# () }) >>
- writeIORef fs_table_var (FastStringTable (uid# +# 1#) arr#)
-
-mkFastString# :: Addr# -> Int# -> FastString
-mkFastString# a# len# =
- unsafePerformIO (
- readIORef string_table >>= \ ft@(FastStringTable uid# tbl#) ->
- let
- h = hashStr a# len#
- in
--- _trace ("hashed: "++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" $
- case copyPrefixStr (A# a#) (I# len#) of
- (ByteArray _ barr#) ->
- let f_str = FastString uid# len# barr# in
- 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#) ->
- let f_str = FastString uid# len# barr# in
- 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# =
- if len# ==# l# && eqStrPrefix a# ba# l# then
- 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# =
- unsafePerformIO (
- readIORef string_table >>= \ ft@(FastStringTable uid# tbl#) ->
- let
- h = hashSubStrFO fo# start# len#
- in
- 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#) ->
- let f_str = FastString uid# len# barr# in
- 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#) ->
- let f_str = FastString uid# len# barr# in
- 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# =
- 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# =
- 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#) ->
- let f_str = FastString uid# len# ba# 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 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) >>
- -- _trace ("new(b): " ++ show f_str) $
- return f_str
- Just v ->
- -- _trace ("re-use(b): "++show v) $
- return v
- )
- where
- btm = error ""
-
- bucket_match [] _ _ _ = Nothing
- bucket_match (v:ls) start# len# ba# =
- case v of
- FastString _ l# barr# ->
- if len# ==# l# && eqStrPrefixBA barr# ba# start# len# then
- Just v
- else
- bucket_match ls start# len# ba#
-
-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#