e55979c38cc250501859da78bdb35526c39e5f07
[ghc.git] / ghc / compiler / utils / FastString.lhs
1 %
2 % (c) The GRASP/AQUA Project, Glasgow University, 1997
3 %
4 \section{Fast strings}
5
6 Compact representations of character strings with
7 unique identifiers.
8
9 \begin{code}
10 #include "HsVersions.h"
11
12 module FastString
13        (
14         FastString(..),     -- not abstract, for now.
15
16          --names?
17         mkFastString,       -- :: String -> FastString
18         mkFastCharString,   -- :: _Addr -> FastString
19         mkFastCharString2,  -- :: _Addr -> Int -> FastString
20         mkFastSubString,    -- :: _Addr -> Int -> Int -> FastString
21         mkFastSubStringFO,  -- :: ForeignObj -> Int -> Int -> FastString
22
23         mkFastString#,      -- :: Addr# -> Int# -> FastString
24         mkFastSubStringBA#, -- :: ByteArray# -> Int# -> Int# -> FastString
25         mkFastSubString#,   -- :: Addr# -> Int# -> Int# -> FastString
26         mkFastSubStringFO#, -- :: ForeignObj# -> Int# -> Int# -> FastString
27        
28         lengthFS,           -- :: FastString -> Int
29         nullFastString,     -- :: FastString -> Bool
30
31         getByteArray#,      -- :: FastString -> ByteArray#
32         getByteArray,       -- :: FastString -> _ByteArray Int
33         unpackFS,           -- :: FastString -> String
34         appendFS,           -- :: FastString -> FastString -> FastString
35         headFS,             -- :: FastString -> Char
36         tailFS,             -- :: FastString -> FastString
37         concatFS,           -- :: [FastString] -> FastString
38         consFS,             -- :: Char -> FastString -> FastString
39
40         hPutFS,             -- :: Handle -> FastString -> IO ()
41         tagCmpFS            -- :: FastString -> FastString -> _CMP_TAG
42        ) where
43
44 #if __GLASGOW_HASKELL__ <= 201
45 import PreludeGlaST
46 import PreludeGlaMisc
47 import HandleHack
48 import Ubiq
49 #else
50 import GlaExts
51 import Foreign
52 import IOBase
53 import IOHandle
54 import ST
55 import STBase
56 import {-# SOURCE #-} Unique  ( mkUniqueGrimily, Unique, Uniquable(..) )
57 #if __GLASGOW_HASKELL__ == 202
58 import PrelBase ( Char (..) )
59 #endif
60 #endif
61
62 import PrimPacked
63
64 #define hASH_TBL_SIZE 993
65
66 \end{code} 
67
68 @FastString@s are packed representations of strings
69 with a unique id for fast comparisons. The unique id
70 is assigned when creating the @FastString@, using
71 a hash table to map from the character string representation
72 to the unique ID.
73
74 \begin{code}
75 data FastString
76   = FastString   -- packed repr. on the heap.
77       Int#       -- unique id
78                  --  0 => string literal, comparison
79                  --  will
80       Int#       -- length
81       ByteArray# -- stuff
82
83   | CharStr      -- external C string
84       Addr#      -- pointer to the (null-terminated) bytes in C land.
85       Int#       -- length  (cached)
86
87 instance Eq FastString where
88   a == b = case tagCmpFS a b of { _LT -> False; _EQ -> True;  _GT -> False }
89   a /= b = case tagCmpFS a b of { _LT -> True;  _EQ -> False; _GT -> True  }
90
91 {-
92  (FastString u1# _ _) == (FastString u2# _ _) = u1# ==# u2#
93 -}
94
95 instance Uniquable FastString where
96  uniqueOf (FastString u# _ _) = mkUniqueGrimily u#
97  uniqueOf (CharStr a# l#) =
98    {-
99      [A somewhat moby hack]: to avoid entering all sorts
100      of junk into the hash table, all C char strings
101      are by default left out. The benefit of being in
102      the table is that string comparisons are lightning fast,
103      just an Int# comparison.
104    
105      But, if you want to get the Unique of a CharStr, we 
106      enter it into the table and return that unique. This
107      works, but causes the CharStr to be looked up in the hash
108      table each time it is accessed..
109    -}
110    mkUniqueGrimily (case mkFastString# a# l# of { FastString u# _ _ -> u#}) -- Ugh!
111
112 instance Uniquable Int where
113  uniqueOf (I# i#) = mkUniqueGrimily i#
114
115 instance Text FastString  where
116     showsPrec p ps@(FastString u# _ _) r = showsPrec p (unpackFS ps) r
117     showsPrec p ps r = showsPrec p (unpackFS ps) r
118
119 getByteArray# :: FastString -> ByteArray#
120 getByteArray# (FastString _ _ ba#) = ba#
121
122 getByteArray :: FastString -> _ByteArray Int
123 getByteArray (FastString _ l# ba#) = _ByteArray (0,I# l#) ba#
124
125 lengthFS :: FastString -> Int
126 lengthFS (FastString _ l# _) = I# l#
127 lengthFS (CharStr a# l#) = I# l#
128
129 nullFastString :: FastString -> Bool
130 nullFastString (FastString _ l# _) = l# ==# 0#
131 nullFastString (CharStr _ l#) = l# ==# 0#
132
133 unpackFS :: FastString -> String
134 unpackFS (FastString _ l# ba#) = byteArrayToString (_ByteArray (0,I# l#) ba#)
135 unpackFS (CharStr addr len#) =
136  unpack 0#
137  where
138     unpack nh
139       | nh ==# len# = []
140       | otherwise   = C# ch : unpack (nh +# 1#)
141       where
142         ch = indexCharOffAddr# addr nh
143
144 appendFS :: FastString -> FastString -> FastString
145 appendFS fs1 fs2 = mkFastString (unpackFS fs1 ++ unpackFS fs2)
146
147 concatFS :: [FastString] -> FastString
148 concatFS ls = mkFastString (concat (map (unpackFS) ls)) -- ToDo: do better
149
150 headFS :: FastString -> Char
151 headFS f@(FastString _ l# ba#) = 
152  if l# ># 0# then C# (indexCharArray# ba# 0#) else error ("headFS: empty FS: " ++ unpackFS f)
153 headFS f@(CharStr a# l#) = 
154  if l# ># 0# then C# (indexCharOffAddr# a# 0#) else error ("headFS: empty FS: " ++ unpackFS f)
155
156 tailFS :: FastString -> FastString
157 tailFS (FastString _ l# ba#) = mkFastSubStringBA# ba# 1# (l# -# 1#)
158
159 consFS :: Char -> FastString -> FastString
160 consFS c fs = mkFastString (c:unpackFS fs)
161
162 \end{code}
163
164 Internally, the compiler will maintain a fast string symbol
165 table, providing sharing and fast comparison. Creation of
166 new @FastString@s then covertly does a lookup, re-using the
167 @FastString@ if there was a hit.
168
169 \begin{code}
170 data FastStringTable = 
171  FastStringTable
172     Int#
173     (MutableArray# _RealWorld [FastString])
174
175 type FastStringTableVar = MutableVar _RealWorld FastStringTable
176
177 string_table :: FastStringTableVar
178 string_table = 
179  unsafePerformPrimIO (
180    newArray (0::Int,hASH_TBL_SIZE) [] `thenPrimIO` \ (_MutableArray _ arr#) ->
181    newVar (FastStringTable 0# arr#))
182
183 lookupTbl :: FastStringTable -> Int# -> PrimIO [FastString]
184 lookupTbl (FastStringTable _ arr#) i# =
185   MkST ( \ (S# s#) ->
186   case readArray# arr# i# s# of { StateAndPtr# s2# r ->
187     (r, S# s2#) })
188
189 updTbl :: FastStringTableVar -> FastStringTable -> Int# -> [FastString] -> PrimIO ()
190 updTbl (_MutableArray _ var#) (FastStringTable uid# arr#) i# ls =
191  MkST ( \ (S# s#) ->
192  case writeArray# arr# i# ls s# of { s2# ->
193  case writeArray# var# 0# (FastStringTable (uid# +# 1#) arr#) s2# of { s3# ->
194   ((), S# s3#) }})
195
196 mkFastString# :: Addr# -> Int# -> FastString
197 mkFastString# a# len# =
198  unsafePerformPrimIO  (
199   readVar string_table `thenPrimIO` \ ft@(FastStringTable uid# tbl#) ->
200   let
201    h = hashStr a# len#
202   in
203 --  _trace ("hashed: "++show (I# h)) $
204   lookupTbl ft h        `thenPrimIO` \ lookup_result ->
205   case lookup_result of
206     [] -> 
207        -- no match, add it to table by copying out the
208        -- the string into a ByteArray
209        -- _trace "empty bucket" $
210        case copyPrefixStr (A# a#) (I# len#) of
211          (_ByteArray _ barr#) ->  
212            let f_str = FastString uid# len# barr# in
213            updTbl string_table ft h [f_str] `seqPrimIO`
214            ({- _trace ("new: " ++ show f_str)   $ -} returnPrimIO f_str)
215     ls -> 
216        -- non-empty `bucket', scan the list looking
217        -- entry with same length and compare byte by byte.
218        -- _trace ("non-empty bucket"++show ls) $
219        case bucket_match ls len# a# of
220          Nothing -> 
221            case copyPrefixStr (A# a#) (I# len#) of
222             (_ByteArray _ barr#) ->  
223               let f_str = FastString uid# len# barr# in
224               updTbl string_table ft h (f_str:ls) `seqPrimIO`
225               ( {- _trace ("new: " ++ show f_str)  $ -} returnPrimIO f_str)
226          Just v  -> {- _trace ("re-use: "++show v) $ -} returnPrimIO v)
227   where
228    bucket_match [] _ _ = Nothing
229    bucket_match (v@(FastString _ l# ba#):ls) len# a# =
230       if len# ==# l# && eqStrPrefix a# ba# l# then
231          Just v
232       else
233          bucket_match ls len# a#
234
235 mkFastSubString# :: Addr# -> Int# -> Int# -> FastString
236 mkFastSubString# a# start# len# = mkFastCharString2 (A# (addrOffset# a# start#)) (I# len#)
237
238 mkFastSubStringFO# :: ForeignObj# -> Int# -> Int# -> FastString
239 mkFastSubStringFO# fo# start# len# =
240  unsafePerformPrimIO  (
241   readVar string_table `thenPrimIO` \ ft@(FastStringTable uid# tbl#) ->
242   let
243    h = hashSubStrFO fo# start# len#
244   in
245   lookupTbl ft h        `thenPrimIO` \ lookup_result ->
246   case lookup_result of
247     [] -> 
248        -- no match, add it to table by copying out the
249        -- the string into a ByteArray
250        case copySubStrFO (_ForeignObj fo#) (I# start#) (I# len#) of
251          (_ByteArray _ barr#) ->  
252            let f_str = FastString uid# len# barr# in
253            updTbl string_table ft h [f_str]       `seqPrimIO`
254            returnPrimIO f_str
255     ls -> 
256        -- non-empty `bucket', scan the list looking
257        -- entry with same length and compare byte by byte.
258        case bucket_match ls start# len# fo# of
259          Nothing -> 
260            case copySubStrFO (_ForeignObj fo#) (I# start#) (I# len#) of
261              (_ByteArray _ barr#) ->  
262               let f_str = FastString uid# len# barr# in
263               updTbl string_table ft  h (f_str:ls) `seqPrimIO`
264               ( {- _trace ("new: " ++ show f_str) $ -} returnPrimIO f_str)
265          Just v  -> {- _trace ("re-use: "++show v) $ -} returnPrimIO v)
266   where
267    bucket_match [] _ _ _ = Nothing
268    bucket_match (v@(FastString _ l# barr#):ls) start# len# fo# =
269       if len# ==# l# && eqStrPrefixFO fo# barr# start# len# then
270          Just v
271       else
272          bucket_match ls start# len# fo#
273
274
275 mkFastSubStringBA# :: ByteArray# -> Int# -> Int# -> FastString
276 mkFastSubStringBA# barr# start# len# =
277  unsafePerformPrimIO  (
278   readVar string_table `thenPrimIO` \ ft@(FastStringTable uid# tbl#) ->
279   let
280    h = hashSubStrBA barr# start# len#
281   in
282 --  _trace ("hashed(b): "++show (I# h)) $
283   lookupTbl ft h        `thenPrimIO` \ lookup_result ->
284   case lookup_result of
285     [] -> 
286        -- no match, add it to table by copying out the
287        -- the string into a ByteArray
288        -- _trace "empty bucket(b)" $
289        case copySubStrBA (_ByteArray btm barr#) (I# start#) (I# len#) of
290          (_ByteArray _ ba#) ->  
291           let f_str = FastString uid# len# ba# in
292           updTbl string_table ft h [f_str]     `seqPrimIO`
293           -- _trace ("new(b): " ++ show f_str)   $
294           returnPrimIO f_str
295     ls -> 
296        -- non-empty `bucket', scan the list looking
297        -- entry with same length and compare byte by byte. 
298        -- _trace ("non-empty bucket(b)"++show ls) $
299        case bucket_match ls start# len# barr# of
300          Nothing -> 
301           case copySubStrBA (_ByteArray (error "") barr#) (I# start#) (I# len#) of
302             (_ByteArray _ ba#) ->  
303               let f_str = FastString uid# len# ba# in
304               updTbl string_table ft h (f_str:ls) `seqPrimIO`
305               -- _trace ("new(b): " ++ show f_str)   $
306               returnPrimIO f_str
307          Just v  -> 
308               -- _trace ("re-use(b): "++show v) $
309               returnPrimIO v
310   )
311  where
312    btm = error ""
313
314    bucket_match [] _ _ _ = Nothing
315    bucket_match (v:ls) start# len# ba# =
316     case v of
317      FastString _ l# barr# ->
318       if len# ==# l# && eqStrPrefixBA barr# ba# start# len# then
319          Just v
320       else
321          bucket_match ls start# len# ba#
322
323 mkFastCharString :: _Addr -> FastString
324 mkFastCharString a@(A# a#) = 
325  case strLength a of{ (I# len#) -> CharStr a# len# }
326
327 mkFastCharString2 :: _Addr -> Int -> FastString
328 mkFastCharString2 a@(A# a#) (I# len#) = CharStr a# len#
329
330 mkFastString :: String -> FastString
331 mkFastString str = 
332  case stringToByteArray str of
333   (_ByteArray (_,I# len#) frozen#) -> 
334     mkFastSubStringBA# frozen# 0# len#
335     {- 0-indexed array, len# == index to one beyond end of string,
336        i.e., (0,1) => empty string.    -}
337
338 mkFastSubString :: _Addr -> Int -> Int -> FastString
339 mkFastSubString (A# a#) (I# start#) (I# len#) =
340  mkFastString# (addrOffset# a# start#) len#
341
342 mkFastSubStringFO :: _ForeignObj -> Int -> Int -> FastString
343 mkFastSubStringFO (_ForeignObj fo#) (I# start#) (I# len#) =
344  mkFastSubStringFO# fo# start# len#
345
346 \end{code}
347
348 \begin{code}
349 hashStr  :: Addr# -> Int# -> Int#
350  -- use the Addr to produce a hash value between 0 & m (inclusive)
351 hashStr a# len# =
352   case len# of
353    0# -> 0#
354    1# -> ((ord# c0 *# 631#) +# len#) `remInt#` hASH_TBL_SIZE#
355    2# -> ((ord# c0 *# 631#) +# (ord# c1 *# 217#) +# len#) `remInt#` hASH_TBL_SIZE#
356    _  -> ((ord# c0 *# 631#) +# (ord# c1 *# 217#) +# (ord# c2 *# 43#) +# len#) `remInt#` hASH_TBL_SIZE#
357 {- Currently UNUSED:
358   if len# ==# 0# then
359      0#
360   else
361      ((ord# c0 *# 631#) +# (ord# c1 *# 217#) +# (ord# c2 *# 43#) +# len#)
362         `remInt#` hASH_TBL_SIZE#
363 -}
364   where
365     c0 = indexCharOffAddr# a# 0#
366     c1 = indexCharOffAddr# a# 1# --(len# `quotInt#` 2# -# 1#)
367     c2 = indexCharOffAddr# a# 2# --(len# -# 1#)
368
369 hashSubStrFO  :: ForeignObj# -> Int# -> Int# -> Int#
370  -- use the Addr to produce a hash value between 0 & m (inclusive)
371 hashSubStrFO fo# start# len# =
372   case len# of
373    0# -> 0#
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#
377 {-
378   if len# ==# 0# then
379      0#
380   else
381      ((ord# c0 *# 631#) +# (ord# c1 *# 217#) +# (ord# c2 *# 43#) +# len#)
382         `remInt#` hASH_TBL_SIZE#
383 -}
384   where
385     c0 = indexCharOffFO# fo# 0#
386     c1 = indexCharOffFO# fo# 1# --(len# `quotInt#` 2# -# 1#)
387     c2 = indexCharOffFO# fo# 2# --(len# -# 1#)
388
389
390 hashSubStrBA  :: ByteArray# -> Int# -> Int# -> Int#
391  -- use the Addr to produce a hash value between 0 & m (inclusive)
392 hashSubStrBA ba# start# len# =
393   case len# of
394    0# -> 0#
395    1# -> ((ord# c0 *# 631#) +# len#) `remInt#` hASH_TBL_SIZE#
396    2# -> ((ord# c0 *# 631#) +# (ord# c1 *# 217#) +# len#) `remInt#` hASH_TBL_SIZE#
397    _  -> ((ord# c0 *# 631#) +# (ord# c1 *# 217#) +# (ord# c2 *# 43#) +# len#) `remInt#` hASH_TBL_SIZE#
398 {-
399   if len# ==# 0# then
400      0#
401   else
402      ((ord# c0 *# 631#) +# (ord# c1 *# 217#) +# (ord# c2 *# 43#) +# len#)
403         `remInt#` hASH_TBL_SIZE#
404 -}
405   where
406     c0 = indexCharArray# ba# 0#
407     c1 = indexCharArray# ba# 1# --(len# `quotInt#` 2# -# 1#)
408     c2 = indexCharArray# ba# 2# --(len# -# 1#)
409
410 \end{code}
411
412 \begin{code}
413 tagCmpFS :: FastString -> FastString -> _CMP_TAG
414 tagCmpFS (FastString u1# _ b1#) (FastString u2# _ b2#) = -- assume non-null chars
415   if u1# ==# u2# then
416      _EQ
417   else
418    unsafePerformPrimIO (
419     _ccall_ strcmp (_ByteArray bottom b1#) (_ByteArray bottom b2#) `thenPrimIO` \ (I# res) ->
420     returnPrimIO (
421     if      res <#  0# then _LT
422     else if res ==# 0# then _EQ
423     else                    _GT
424     ))
425   where
426    bottom :: (Int,Int)
427    bottom = error "tagCmp"
428 tagCmpFS (CharStr bs1 len1) (CharStr bs2 len2)
429   = unsafePerformPrimIO (
430     _ccall_ strcmp ba1 ba2  `thenPrimIO` \ (I# res) ->
431     returnPrimIO (
432     if      res <#  0# then _LT
433     else if res ==# 0# then _EQ
434     else                    _GT
435     ))
436   where
437     ba1 = A# bs1
438     ba2 = A# bs2
439 tagCmpFS (FastString _ len1 bs1) (CharStr bs2 len2)
440  = unsafePerformPrimIO (
441     _ccall_ strcmp ba1 ba2 `thenPrimIO` \ (I# res) ->
442     returnPrimIO (
443      if      res <#  0# then _LT
444      else if res ==# 0# then _EQ
445      else                   _GT
446     ))
447   where
448     ba1 = _ByteArray ((error "")::(Int,Int)) bs1
449     ba2 = A# bs2
450
451 tagCmpFS a@(CharStr _ _) b@(FastString _ _ _)
452   = -- try them the other way 'round
453     case (tagCmpFS b a) of { _LT -> _GT; _EQ -> _EQ; _GT -> _LT }
454
455 instance Ord FastString where
456     a <= b = case tagCmpFS a b of { _LT -> True;  _EQ -> True;  _GT -> False }
457     a <  b = case tagCmpFS a b of { _LT -> True;  _EQ -> False; _GT -> False }
458     a >= b = case tagCmpFS a b of { _LT -> False; _EQ -> True;  _GT -> True  }
459     a >  b = case tagCmpFS a b of { _LT -> False; _EQ -> False; _GT -> True  }
460     max x y | x >= y    =  x
461             | otherwise =  y
462     min x y | x <= y    =  x
463             | otherwise =  y
464     _tagCmp a b = tagCmpFS a b
465
466 \end{code}
467
468 Outputting @FastString@s is quick, just block copying the chunk (using
469 @fwrite@).
470
471 \begin{code}
472 #if __GLASGOW_HASKELL__ >= 201
473 #define _ErrorHandle IOBase.ErrorHandle
474 #define _ReadHandle IOBase.ReadHandle
475 #define _ClosedHandle IOBase.ClosedHandle
476 #define _SemiClosedHandle IOBase.SemiClosedHandle
477 #define _constructError  IOBase.constructError
478 #define _filePtr IOHandle.filePtr
479 #define failWith fail
480 #endif
481
482 hPutFS :: Handle -> FastString -> IO ()
483 hPutFS handle (FastString _ l# ba#) =
484  if l# ==# 0# then
485     return ()
486  else
487     _readHandle handle                              >>= \ htype ->
488     case htype of 
489       _ErrorHandle ioError ->
490           _writeHandle handle htype                 >>
491           failWith ioError
492       _ClosedHandle ->
493           _writeHandle handle htype                 >>
494           failWith MkIOError(handle,IllegalOperation,"handle is closed")
495       _SemiClosedHandle _ _ ->
496           _writeHandle handle htype                 >>
497           failWith MkIOError(handle,IllegalOperation,"handle is closed")
498       _ReadHandle _ _ _ ->
499           _writeHandle handle htype                 >>
500           failWith MkIOError(handle,IllegalOperation,"handle is not open for writing")
501       other -> 
502           let fp = _filePtr htype in
503            -- here we go..
504           _ccall_ writeFile (_ByteArray ((error "")::(Int,Int)) ba#) fp (I# l#) `CCALL_THEN` \rc ->
505           if rc==0 then
506               return ()
507           else
508               _constructError "hPutFS"   `CCALL_THEN` \ err ->
509               failWith err
510 hPutFS handle (CharStr a# l#) =
511  if l# ==# 0# then
512     return ()
513  else
514     _readHandle handle                              >>= \ htype ->
515     case htype of 
516       _ErrorHandle ioError ->
517           _writeHandle handle htype                 >>
518           failWith ioError
519       _ClosedHandle ->
520           _writeHandle handle htype                 >>
521           failWith MkIOError(handle,IllegalOperation,"handle is closed")
522       _SemiClosedHandle _ _ ->
523           _writeHandle handle htype                 >>
524           failWith MkIOError(handle,IllegalOperation,"handle is closed")
525       _ReadHandle _ _ _ ->
526           _writeHandle handle htype                 >>
527           failWith MkIOError(handle,IllegalOperation,"handle is not open for writing")
528       other -> 
529           let fp = _filePtr htype in
530            -- here we go..
531           _ccall_ writeFile (A# a#) fp (I# l#) `CCALL_THEN` \rc ->
532           if rc==0 then
533               return ()
534           else
535               _constructError "hPutFS"   `CCALL_THEN` \ err ->
536               failWith err
537
538 --ToDo: avoid silly code duplic.
539 \end{code}