2 % (c) The GRASP/AQUA Project, Glasgow University, 1997-1998
6 Compact representations of character strings with
7 unique identifiers (hash-cons'ish).
12 FastString(..), -- not abstract, for now.
14 mkFastString, -- :: String -> FastString
15 mkFastStringNarrow, -- :: String -> FastString
16 mkFastSubString, -- :: Addr -> Int -> Int -> FastString
18 mkFastString#, -- :: Addr# -> FastString
19 mkFastSubStringBA#, -- :: ByteArray# -> Int# -> Int# -> FastString
21 mkFastStringInt, -- :: [Int] -> FastString
23 uniqueOfFS, -- :: FastString -> Int#
24 lengthFS, -- :: FastString -> Int
25 nullFastString, -- :: FastString -> Bool
27 unpackFS, -- :: FastString -> String
28 unpackIntFS, -- :: FastString -> [Int]
29 appendFS, -- :: FastString -> FastString -> FastString
30 headFS, -- :: FastString -> Char
31 headIntFS, -- :: FastString -> Int
32 tailFS, -- :: FastString -> FastString
33 concatFS, -- :: [FastString] -> FastString
34 consFS, -- :: Char -> FastString -> FastString
35 indexFS, -- :: FastString -> Int -> Char
36 nilFS, -- :: FastString
38 hPutFS, -- :: Handle -> FastString -> IO ()
41 mkLitString# -- :: Addr# -> LitString
44 -- This #define suppresses the "import FastString" that
45 -- HsVersions otherwise produces
46 #define COMPILING_FAST_STRING
47 #include "HsVersions.h"
49 #if __GLASGOW_HASKELL__ < 503
50 import PrelPack hiding (packString)
51 import PrelIOBase ( IO(..) )
53 import GHC.IOBase ( IO(..) )
58 import UNSAFE_IO ( unsafePerformIO )
60 import DATA_IOREF ( IORef, newIORef, readIORef, writeIORef )
62 #if __GLASGOW_HASKELL__ < 503
63 import PrelArr ( STArray(..), newSTArray )
65 import GHC.Arr ( STArray(..), newSTArray )
68 #if __GLASGOW_HASKELL__ >= 504
73 import IOExts ( hPutBufBAFull )
77 import Char ( chr, ord )
79 #define hASH_TBL_SIZE 993
82 @FastString@s are packed representations of strings
83 with a unique id for fast comparisons. The unique id
84 is assigned when creating the @FastString@, using
85 a hash table to map from the character string representation
90 = FastString -- packed repr. on the heap.
92 -- 0 => string literal, comparison
97 | UnicodeStr -- if contains characters outside '\1'..'\xFF'
99 [Int] -- character numbers
101 instance Eq FastString where
102 -- shortcut for real FastStrings
103 (FastString u1 _ _) == (FastString u2 _ _) = u1 ==# u2
104 a == b = case cmpFS a b of { LT -> False; EQ -> True; GT -> False }
106 (FastString u1 _ _) /= (FastString u2 _ _) = u1 /=# u2
107 a /= b = case cmpFS a b of { LT -> True; EQ -> False; GT -> True }
109 instance Ord FastString where
110 a <= b = case cmpFS a b of { LT -> True; EQ -> True; GT -> False }
111 a < b = case cmpFS a b of { LT -> True; EQ -> False; GT -> False }
112 a >= b = case cmpFS a b of { LT -> False; EQ -> True; GT -> True }
113 a > b = case cmpFS a b of { LT -> False; EQ -> False; GT -> True }
118 compare a b = cmpFS a b
120 lengthFS :: FastString -> Int
121 lengthFS (FastString _ l# _) = I# l#
122 lengthFS (UnicodeStr _ s) = length s
124 nullFastString :: FastString -> Bool
125 nullFastString (FastString _ l# _) = l# ==# 0#
126 nullFastString (UnicodeStr _ []) = True
127 nullFastString (UnicodeStr _ (_:_)) = False
129 unpackFS :: FastString -> String
130 unpackFS (FastString _ l# ba#) = unpackCStringBA (BA ba#) (I# l#)
131 unpackFS (UnicodeStr _ s) = map chr s
133 unpackIntFS :: FastString -> [Int]
134 unpackIntFS (UnicodeStr _ s) = s
135 unpackIntFS fs = map ord (unpackFS fs)
137 appendFS :: FastString -> FastString -> FastString
138 appendFS fs1 fs2 = mkFastStringInt (unpackIntFS fs1 ++ unpackIntFS fs2)
140 concatFS :: [FastString] -> FastString
141 concatFS ls = mkFastStringInt (concat (map unpackIntFS ls)) -- ToDo: do better
143 headFS :: FastString -> Char
144 headFS (FastString _ l# ba#) =
145 if l# ># 0# then C# (indexCharArray# ba# 0#) else error ("headFS: empty FS")
146 headFS (UnicodeStr _ (c:_)) = chr c
147 headFS (UnicodeStr _ []) = error ("headFS: empty FS")
149 headIntFS :: FastString -> Int
150 headIntFS (UnicodeStr _ (c:_)) = c
151 headIntFS fs = ord (headFS fs)
153 indexFS :: FastString -> Int -> Char
154 indexFS f i@(I# i#) =
157 | l# ># 0# && l# ># i# -> C# (indexCharArray# ba# i#)
158 | otherwise -> error (msg (I# l#))
159 UnicodeStr _ s -> chr (s!!i)
161 msg l = "indexFS: out of range: " ++ show (l,i)
163 tailFS :: FastString -> FastString
164 tailFS (FastString _ l# ba#) = mkFastSubStringBA# ba# 1# (l# -# 1#)
165 tailFS fs = mkFastStringInt (tail (unpackIntFS fs))
167 consFS :: Char -> FastString -> FastString
168 consFS c fs = mkFastStringInt (ord c : unpackIntFS fs)
170 uniqueOfFS :: FastString -> Int#
171 uniqueOfFS (FastString u# _ _) = u#
172 uniqueOfFS (UnicodeStr u# _) = u#
174 nilFS = mkFastString ""
177 Internally, the compiler will maintain a fast string symbol
178 table, providing sharing and fast comparison. Creation of
179 new @FastString@s then covertly does a lookup, re-using the
180 @FastString@ if there was a hit.
182 Caution: mkFastStringUnicode assumes that if the string is in the
183 table, it sits under the UnicodeStr constructor. Other mkFastString
184 variants analogously assume the FastString constructor.
187 data FastStringTable =
190 (MutableArray# RealWorld [FastString])
192 type FastStringTableVar = IORef FastStringTable
194 string_table :: FastStringTableVar
197 stToIO (newSTArray (0::Int,hASH_TBL_SIZE) [])
198 >>= \ (STArray _ _ arr#) ->
199 newIORef (FastStringTable 0# arr#))
201 lookupTbl :: FastStringTable -> Int# -> IO [FastString]
202 lookupTbl (FastStringTable _ arr#) i# =
204 readArray# arr# i# s#)
206 updTbl :: FastStringTableVar -> FastStringTable -> Int# -> [FastString] -> IO ()
207 updTbl fs_table_var (FastStringTable uid# arr#) i# ls =
208 IO (\ s# -> case writeArray# arr# i# ls s# of { s2# ->
210 writeIORef fs_table_var (FastStringTable (uid# +# 1#) arr#)
212 mkFastString# :: Addr# -> FastString
214 case strLength (Ptr a#) of { (I# len#) -> mkFastStringLen# a# len# }
216 mkFastStringLen# :: Addr# -> Int# -> FastString
217 mkFastStringLen# a# len# =
219 readIORef string_table >>= \ ft@(FastStringTable uid# tbl#) ->
223 -- _trace ("hashed: "++show (I# h)) $
224 lookupTbl ft h >>= \ lookup_result ->
225 case lookup_result of
227 -- no match, add it to table by copying out the
228 -- the string into a ByteArray
229 -- _trace "empty bucket" $
230 case copyPrefixStr a# (I# len#) of
232 let f_str = FastString uid# len# barr# in
233 updTbl string_table ft h [f_str] >>
234 ({- _trace ("new: " ++ show f_str) $ -} return f_str)
236 -- non-empty `bucket', scan the list looking
237 -- entry with same length and compare byte by byte.
238 -- _trace ("non-empty bucket"++show ls) $
239 case bucket_match ls len# a# of
241 case copyPrefixStr a# (I# len#) of
243 let f_str = FastString uid# len# barr# in
244 updTbl string_table ft h (f_str:ls) >>
245 ( {- _trace ("new: " ++ show f_str) $ -} return f_str)
246 Just v -> {- _trace ("re-use: "++show v) $ -} return v)
248 bucket_match [] _ _ = Nothing
249 bucket_match (v@(FastString _ l# ba#):ls) len# a# =
250 if len# ==# l# && eqStrPrefix a# ba# l# then
253 bucket_match ls len# a#
254 bucket_match (UnicodeStr _ _ : ls) len# a# =
255 bucket_match ls len# a#
257 mkFastSubStringBA# :: ByteArray# -> Int# -> Int# -> FastString
258 mkFastSubStringBA# barr# start# len# =
260 readIORef string_table >>= \ ft@(FastStringTable uid# tbl#) ->
262 h = hashSubStrBA barr# start# len#
264 -- _trace ("hashed(b): "++show (I# h)) $
265 lookupTbl ft h >>= \ lookup_result ->
266 case lookup_result of
268 -- no match, add it to table by copying out the
269 -- the string into a ByteArray
270 -- _trace "empty bucket(b)" $
271 case copySubStrBA (BA barr#) (I# start#) (I# len#) of
273 let f_str = FastString uid# len# ba# in
274 updTbl string_table ft h [f_str] >>
275 -- _trace ("new(b): " ++ show f_str) $
278 -- non-empty `bucket', scan the list looking
279 -- entry with same length and compare byte by byte.
280 -- _trace ("non-empty bucket(b)"++show ls) $
281 case bucket_match ls start# len# barr# of
283 case copySubStrBA (BA barr#) (I# start#) (I# len#) of
285 let f_str = FastString uid# len# ba# in
286 updTbl string_table ft h (f_str:ls) >>
287 -- _trace ("new(b): " ++ show f_str) $
290 -- _trace ("re-use(b): "++show v) $
294 bucket_match [] _ _ _ = Nothing
295 bucket_match (v:ls) start# len# ba# =
297 FastString _ l# barr# ->
298 if len# ==# l# && eqStrPrefixBA barr# ba# start# len# then
301 bucket_match ls start# len# ba#
302 UnicodeStr _ _ -> bucket_match ls start# len# ba#
304 mkFastStringUnicode :: [Int] -> FastString
305 mkFastStringUnicode s =
307 readIORef string_table >>= \ ft@(FastStringTable uid# tbl#) ->
311 -- _trace ("hashed(b): "++show (I# h)) $
312 lookupTbl ft h >>= \ lookup_result ->
313 case lookup_result of
315 -- no match, add it to table by copying out the
316 -- the string into a [Int]
317 let f_str = UnicodeStr uid# s in
318 updTbl string_table ft h [f_str] >>
319 -- _trace ("new(b): " ++ show f_str) $
322 -- non-empty `bucket', scan the list looking
323 -- entry with same length and compare byte by byte.
324 -- _trace ("non-empty bucket(b)"++show ls) $
325 case bucket_match ls of
327 let f_str = UnicodeStr uid# s in
328 updTbl string_table ft h (f_str:ls) >>
329 -- _trace ("new(b): " ++ show f_str) $
332 -- _trace ("re-use(b): "++show v) $
336 bucket_match [] = Nothing
337 bucket_match (v@(UnicodeStr _ s'):ls) =
338 if s' == s then Just v else bucket_match ls
339 bucket_match (FastString _ _ _ : ls) = bucket_match ls
341 mkFastStringNarrow :: String -> FastString
342 mkFastStringNarrow str =
343 case packString str of { (I# len#, BA frozen#) ->
344 mkFastSubStringBA# frozen# 0# len#
346 {- 0-indexed array, len# == index to one beyond end of string,
347 i.e., (0,1) => empty string. -}
349 mkFastString :: String -> FastString
350 mkFastString str = if all good str
351 then mkFastStringNarrow str
352 else mkFastStringUnicode (map ord str)
354 good c = c >= '\1' && c <= '\xFF'
356 mkFastStringInt :: [Int] -> FastString
357 mkFastStringInt str = if all good str
358 then mkFastStringNarrow (map chr str)
359 else mkFastStringUnicode str
361 good c = c >= 1 && c <= 0xFF
363 mkFastSubString :: Addr# -> Int -> Int -> FastString
364 mkFastSubString a# (I# start#) (I# len#) =
365 mkFastStringLen# (a# `plusAddr#` start#) len#
369 hashStr :: Addr# -> Int# -> Int#
370 -- use the Addr to produce a hash value between 0 & m (inclusive)
374 1# -> ((ord# c0 *# 631#) +# len#) `remInt#` hASH_TBL_SIZE#
375 2# -> ((ord# c0 *# 631#) +# (ord# c1 *# 217#) +# len#) `remInt#` hASH_TBL_SIZE#
376 _ -> ((ord# c0 *# 631#) +# (ord# c1 *# 217#) +# (ord# c2 *# 43#) +# len#) `remInt#` hASH_TBL_SIZE#
378 c0 = indexCharOffAddr# a# 0#
379 c1 = indexCharOffAddr# a# (len# `quotInt#` 2# -# 1#)
380 c2 = indexCharOffAddr# a# (len# -# 1#)
382 c1 = indexCharOffAddr# a# 1#
383 c2 = indexCharOffAddr# a# 2#
386 hashSubStrBA :: ByteArray# -> Int# -> Int# -> Int#
387 -- use the byte array to produce a hash value between 0 & m (inclusive)
388 hashSubStrBA ba# start# len# =
391 1# -> ((ord# c0 *# 631#) +# len#) `remInt#` hASH_TBL_SIZE#
392 2# -> ((ord# c0 *# 631#) +# (ord# c1 *# 217#) +# len#) `remInt#` hASH_TBL_SIZE#
393 _ -> ((ord# c0 *# 631#) +# (ord# c1 *# 217#) +# (ord# c2 *# 43#) +# len#) `remInt#` hASH_TBL_SIZE#
395 c0 = indexCharArray# ba# 0#
396 c1 = indexCharArray# ba# (len# `quotInt#` 2# -# 1#)
397 c2 = indexCharArray# ba# (len# -# 1#)
399 -- c1 = indexCharArray# ba# 1#
400 -- c2 = indexCharArray# ba# 2#
402 hashUnicode :: [Int] -> Int#
403 -- use the Addr to produce a hash value between 0 & m (inclusive)
405 hashUnicode [I# c0] = ((c0 *# 631#) +# 1#) `remInt#` hASH_TBL_SIZE#
406 hashUnicode [I# c0, I# c1] = ((c0 *# 631#) +# (c1 *# 217#) +# 2#) `remInt#` hASH_TBL_SIZE#
407 hashUnicode s = ((c0 *# 631#) +# (c1 *# 217#) +# (c2 *# 43#) +# len#) `remInt#` hASH_TBL_SIZE#
411 I# c1 = s !! (I# (len# `quotInt#` 2# -# 1#))
412 I# c2 = s !! (I# (len# -# 1#))
417 cmpFS :: FastString -> FastString -> Ordering
418 cmpFS (UnicodeStr u1# s1) (UnicodeStr u2# s2) = if u1# ==# u2# then EQ
420 cmpFS (UnicodeStr _ s1) s2 = compare s1 (unpackIntFS s2)
421 cmpFS s1 (UnicodeStr _ s2) = compare (unpackIntFS s1) s2
422 cmpFS (FastString u1# _ b1#) (FastString u2# _ b2#) = -- assume non-null chars
427 strcmp b1# b2# >>= \ (I# res) ->
430 else if res ==# 0# then EQ
434 foreign import ccall "strcmp" unsafe
435 strcmp :: ByteArray# -> ByteArray# -> IO Int
437 -- -----------------------------------------------------------------------------
438 -- Outputting 'FastString's
440 #if __GLASGOW_HASKELL__ >= 504
442 -- this is our own version of hPutBuf for FastStrings, because in
443 -- 5.04+ we don't have mutable byte arrays and therefore hPutBufBA.
444 -- The closest is hPutArray in Data.Array.IO, but that does some extra
445 -- range checks that we want to avoid here.
447 foreign import ccall unsafe "__hscore_memcpy_dst_off"
448 memcpy_baoff_ba :: RawBuffer -> Int -> RawBuffer -> CSize -> IO (Ptr ())
450 hPutFS handle (FastString _ l# ba#)
451 | l# ==# 0# = return ()
453 = do wantWritableHandle "hPutFS" handle $
454 \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=stream } -> do
456 old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size }
460 raw = unsafeCoerce# ba# :: MutableByteArray# RealWorld
462 -- enough room in handle buffer?
463 if (size - w > count)
464 -- There's enough room in the buffer:
465 -- just copy the data in and update bufWPtr.
466 then do memcpy_baoff_ba old_raw w raw (fromIntegral count)
467 writeIORef ref old_buf{ bufWPtr = w + count }
470 -- else, we have to flush
471 else do flushed_buf <- flushWriteBuffer fd stream old_buf
472 writeIORef ref flushed_buf
474 Buffer{ bufBuf=raw, bufState=WriteBuffer,
475 bufRPtr=0, bufWPtr=count, bufSize=count }
476 flushWriteBuffer fd stream this_buf
481 hPutFS :: Handle -> FastString -> IO ()
482 hPutFS handle (FastString _ l# ba#)
483 | l# ==# 0# = return ()
484 | otherwise = do mba <- stToIO $ unsafeThawByteArray (ByteArray (bot::Int) bot ba#)
485 hPutBufBAFull handle mba (I# l#)
487 bot = error "hPutFS.ba"
491 -- ONLY here for debugging the NCG (so -ddump-stix works for string
492 -- literals); no idea if this is really necessary. JRS, 010131
493 hPutFS handle (UnicodeStr _ is)
494 = hPutStr handle ("(UnicodeStr " ++ show is ++ ")")
496 -- -----------------------------------------------------------------------------
497 -- LitStrings, here for convenience only.
499 type LitString = Ptr ()
500 -- ToDo: make it a Ptr when we don't have to support 4.08 any more
502 mkLitString# :: Addr# -> LitString
503 mkLitString# a# = Ptr a#