[project @ 1997-08-25 22:25:28 by sof]
[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 (hash-cons'ish).
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 #if __GLASGOW_HASKELL__ >= 206
61 import PackBase
62 #endif
63 #endif
64
65 import PrimPacked
66
67 #define hASH_TBL_SIZE 993
68
69 \end{code} 
70
71 @FastString@s are packed representations of strings
72 with a unique id for fast comparisons. The unique id
73 is assigned when creating the @FastString@, using
74 a hash table to map from the character string representation
75 to the unique ID.
76
77 \begin{code}
78 data FastString
79   = FastString   -- packed repr. on the heap.
80       Int#       -- unique id
81                  --  0 => string literal, comparison
82                  --  will
83       Int#       -- length
84       ByteArray# -- stuff
85
86   | CharStr      -- external C string
87       Addr#      -- pointer to the (null-terminated) bytes in C land.
88       Int#       -- length  (cached)
89
90 instance Eq FastString where
91   a == b = case tagCmpFS a b of { _LT -> False; _EQ -> True;  _GT -> False }
92   a /= b = case tagCmpFS a b of { _LT -> True;  _EQ -> False; _GT -> True  }
93
94 {-
95  (FastString u1# _ _) == (FastString u2# _ _) = u1# ==# u2#
96 -}
97
98 instance Uniquable FastString where
99  uniqueOf (FastString u# _ _) = mkUniqueGrimily u#
100  uniqueOf (CharStr a# l#) =
101    {-
102      [A somewhat moby hack]: to avoid entering all sorts
103      of junk into the hash table, all C char strings
104      are by default left out. The benefit of being in
105      the table is that string comparisons are lightning fast,
106      just an Int# comparison.
107    
108      But, if you want to get the Unique of a CharStr, we 
109      enter it into the table and return that unique. This
110      works, but causes the CharStr to be looked up in the hash
111      table each time it is accessed..
112    -}
113    mkUniqueGrimily (case mkFastString# a# l# of { FastString u# _ _ -> u#}) -- Ugh!
114
115 instance Uniquable Int where
116  uniqueOf (I# i#) = mkUniqueGrimily i#
117
118 instance Text FastString  where
119     showsPrec p ps@(FastString u# _ _) r = showsPrec p (unpackFS ps) r
120     showsPrec p ps r = showsPrec p (unpackFS ps) r
121
122 getByteArray# :: FastString -> ByteArray#
123 getByteArray# (FastString _ _ ba#) = ba#
124
125 getByteArray :: FastString -> _ByteArray Int
126 getByteArray (FastString _ l# ba#) = _ByteArray (0,I# l#) ba#
127
128 lengthFS :: FastString -> Int
129 lengthFS (FastString _ l# _) = I# l#
130 lengthFS (CharStr a# l#) = I# l#
131
132 nullFastString :: FastString -> Bool
133 nullFastString (FastString _ l# _) = l# ==# 0#
134 nullFastString (CharStr _ l#) = l# ==# 0#
135
136 unpackFS :: FastString -> String
137 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 205
138 unpackFS (FastString _ l# ba#) = byteArrayToString (_ByteArray (0,I# l#) ba#)
139 #else
140 unpackFS (FastString _ l# ba#) = unpackCStringBA# l# ba#
141 #endif
142 unpackFS (CharStr addr len#) =
143  unpack 0#
144  where
145     unpack nh
146       | nh ==# len# = []
147       | otherwise   = C# ch : unpack (nh +# 1#)
148       where
149         ch = indexCharOffAddr# addr nh
150
151 appendFS :: FastString -> FastString -> FastString
152 appendFS fs1 fs2 = mkFastString (unpackFS fs1 ++ unpackFS fs2)
153
154 concatFS :: [FastString] -> FastString
155 concatFS ls = mkFastString (concat (map (unpackFS) ls)) -- ToDo: do better
156
157 headFS :: FastString -> Char
158 headFS f@(FastString _ l# ba#) = 
159  if l# ># 0# then C# (indexCharArray# ba# 0#) else error ("headFS: empty FS: " ++ unpackFS f)
160 headFS f@(CharStr a# l#) = 
161  if l# ># 0# then C# (indexCharOffAddr# a# 0#) else error ("headFS: empty FS: " ++ unpackFS f)
162
163 tailFS :: FastString -> FastString
164 tailFS (FastString _ l# ba#) = mkFastSubStringBA# ba# 1# (l# -# 1#)
165
166 consFS :: Char -> FastString -> FastString
167 consFS c fs = mkFastString (c:unpackFS fs)
168
169 \end{code}
170
171 Internally, the compiler will maintain a fast string symbol
172 table, providing sharing and fast comparison. Creation of
173 new @FastString@s then covertly does a lookup, re-using the
174 @FastString@ if there was a hit.
175
176 \begin{code}
177 data FastStringTable = 
178  FastStringTable
179     Int#
180     (MutableArray# _RealWorld [FastString])
181
182 type FastStringTableVar = MutableVar _RealWorld FastStringTable
183
184 string_table :: FastStringTableVar
185 string_table = 
186  unsafePerformPrimIO (
187    newArray (0::Int,hASH_TBL_SIZE) [] `thenPrimIO` \ (_MutableArray _ arr#) ->
188    newVar (FastStringTable 0# arr#))
189
190 lookupTbl :: FastStringTable -> Int# -> PrimIO [FastString]
191 lookupTbl (FastStringTable _ arr#) i# =
192   MkST ( \ (S# s#) ->
193   case readArray# arr# i# s# of { StateAndPtr# s2# r ->
194     (r, S# s2#) })
195
196 updTbl :: FastStringTableVar -> FastStringTable -> Int# -> [FastString] -> PrimIO ()
197 updTbl (_MutableArray _ var#) (FastStringTable uid# arr#) i# ls =
198  MkST ( \ (S# s#) ->
199  case writeArray# arr# i# ls s# of { s2# ->
200  case writeArray# var# 0# (FastStringTable (uid# +# 1#) arr#) s2# of { s3# ->
201   ((), S# s3#) }})
202
203 mkFastString# :: Addr# -> Int# -> FastString
204 mkFastString# a# len# =
205  unsafePerformPrimIO  (
206   readVar string_table `thenPrimIO` \ ft@(FastStringTable uid# tbl#) ->
207   let
208    h = hashStr a# len#
209   in
210 --  _trace ("hashed: "++show (I# h)) $
211   lookupTbl ft h        `thenPrimIO` \ lookup_result ->
212   case lookup_result of
213     [] -> 
214        -- no match, add it to table by copying out the
215        -- the string into a ByteArray
216        -- _trace "empty bucket" $
217        case copyPrefixStr (A# a#) (I# len#) of
218          (_ByteArray _ barr#) ->  
219            let f_str = FastString uid# len# barr# in
220            updTbl string_table ft h [f_str] `seqPrimIO`
221            ({- _trace ("new: " ++ show f_str)   $ -} returnPrimIO f_str)
222     ls -> 
223        -- non-empty `bucket', scan the list looking
224        -- entry with same length and compare byte by byte.
225        -- _trace ("non-empty bucket"++show ls) $
226        case bucket_match ls len# a# of
227          Nothing -> 
228            case copyPrefixStr (A# a#) (I# len#) of
229             (_ByteArray _ barr#) ->  
230               let f_str = FastString uid# len# barr# in
231               updTbl string_table ft h (f_str:ls) `seqPrimIO`
232               ( {- _trace ("new: " ++ show f_str)  $ -} returnPrimIO f_str)
233          Just v  -> {- _trace ("re-use: "++show v) $ -} returnPrimIO v)
234   where
235    bucket_match [] _ _ = Nothing
236    bucket_match (v@(FastString _ l# ba#):ls) len# a# =
237       if len# ==# l# && eqStrPrefix a# ba# l# then
238          Just v
239       else
240          bucket_match ls len# a#
241
242 mkFastSubString# :: Addr# -> Int# -> Int# -> FastString
243 mkFastSubString# a# start# len# = mkFastCharString2 (A# (addrOffset# a# start#)) (I# len#)
244
245 mkFastSubStringFO# :: ForeignObj# -> Int# -> Int# -> FastString
246 mkFastSubStringFO# fo# start# len# =
247  unsafePerformPrimIO  (
248   readVar string_table `thenPrimIO` \ ft@(FastStringTable uid# tbl#) ->
249   let
250    h = hashSubStrFO fo# start# len#
251   in
252   lookupTbl ft h        `thenPrimIO` \ lookup_result ->
253   case lookup_result of
254     [] -> 
255        -- no match, add it to table by copying out the
256        -- the string into a ByteArray
257        case copySubStrFO (_ForeignObj fo#) (I# start#) (I# len#) of
258          (_ByteArray _ barr#) ->  
259            let f_str = FastString uid# len# barr# in
260            updTbl string_table ft h [f_str]       `seqPrimIO`
261            returnPrimIO f_str
262     ls -> 
263        -- non-empty `bucket', scan the list looking
264        -- entry with same length and compare byte by byte.
265        case bucket_match ls start# len# fo# of
266          Nothing -> 
267            case copySubStrFO (_ForeignObj fo#) (I# start#) (I# len#) of
268              (_ByteArray _ barr#) ->  
269               let f_str = FastString uid# len# barr# in
270               updTbl string_table ft  h (f_str:ls) `seqPrimIO`
271               ( {- _trace ("new: " ++ show f_str) $ -} returnPrimIO f_str)
272          Just v  -> {- _trace ("re-use: "++show v) $ -} returnPrimIO v)
273   where
274    bucket_match [] _ _ _ = Nothing
275    bucket_match (v@(FastString _ l# barr#):ls) start# len# fo# =
276       if len# ==# l# && eqStrPrefixFO fo# barr# start# len# then
277          Just v
278       else
279          bucket_match ls start# len# fo#
280
281
282 mkFastSubStringBA# :: ByteArray# -> Int# -> Int# -> FastString
283 mkFastSubStringBA# barr# start# len# =
284  unsafePerformPrimIO  (
285   readVar string_table `thenPrimIO` \ ft@(FastStringTable uid# tbl#) ->
286   let
287    h = hashSubStrBA barr# start# len#
288   in
289 --  _trace ("hashed(b): "++show (I# h)) $
290   lookupTbl ft h        `thenPrimIO` \ lookup_result ->
291   case lookup_result of
292     [] -> 
293        -- no match, add it to table by copying out the
294        -- the string into a ByteArray
295        -- _trace "empty bucket(b)" $
296        case copySubStrBA (_ByteArray btm barr#) (I# start#) (I# len#) of
297          (_ByteArray _ ba#) ->  
298           let f_str = FastString uid# len# ba# in
299           updTbl string_table ft h [f_str]     `seqPrimIO`
300           -- _trace ("new(b): " ++ show f_str)   $
301           returnPrimIO f_str
302     ls -> 
303        -- non-empty `bucket', scan the list looking
304        -- entry with same length and compare byte by byte. 
305        -- _trace ("non-empty bucket(b)"++show ls) $
306        case bucket_match ls start# len# barr# of
307          Nothing -> 
308           case copySubStrBA (_ByteArray (error "") barr#) (I# start#) (I# len#) of
309             (_ByteArray _ ba#) ->  
310               let f_str = FastString uid# len# ba# in
311               updTbl string_table ft h (f_str:ls) `seqPrimIO`
312               -- _trace ("new(b): " ++ show f_str)   $
313               returnPrimIO f_str
314          Just v  -> 
315               -- _trace ("re-use(b): "++show v) $
316               returnPrimIO v
317   )
318  where
319    btm = error ""
320
321    bucket_match [] _ _ _ = Nothing
322    bucket_match (v:ls) start# len# ba# =
323     case v of
324      FastString _ l# barr# ->
325       if len# ==# l# && eqStrPrefixBA barr# ba# start# len# then
326          Just v
327       else
328          bucket_match ls start# len# ba#
329
330 mkFastCharString :: _Addr -> FastString
331 mkFastCharString a@(A# a#) = 
332  case strLength a of{ (I# len#) -> CharStr a# len# }
333
334 mkFastCharString2 :: _Addr -> Int -> FastString
335 mkFastCharString2 a@(A# a#) (I# len#) = CharStr a# len#
336
337 mkFastString :: String -> FastString
338 mkFastString str = 
339 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 205
340  case stringToByteArray str of
341 #else
342  case packString str of
343 #endif
344   (_ByteArray (_,I# len#) frozen#) -> 
345     mkFastSubStringBA# frozen# 0# len#
346     {- 0-indexed array, len# == index to one beyond end of string,
347        i.e., (0,1) => empty string.    -}
348
349 mkFastSubString :: _Addr -> Int -> Int -> FastString
350 mkFastSubString (A# a#) (I# start#) (I# len#) =
351  mkFastString# (addrOffset# a# start#) len#
352
353 mkFastSubStringFO :: _ForeignObj -> Int -> Int -> FastString
354 mkFastSubStringFO (_ForeignObj fo#) (I# start#) (I# len#) =
355  mkFastSubStringFO# fo# start# len#
356
357 \end{code}
358
359 \begin{code}
360 hashStr  :: Addr# -> Int# -> Int#
361  -- use the Addr to produce a hash value between 0 & m (inclusive)
362 hashStr a# len# =
363   case len# of
364    0# -> 0#
365    1# -> ((ord# c0 *# 631#) +# len#) `remInt#` hASH_TBL_SIZE#
366    2# -> ((ord# c0 *# 631#) +# (ord# c1 *# 217#) +# len#) `remInt#` hASH_TBL_SIZE#
367    _  -> ((ord# c0 *# 631#) +# (ord# c1 *# 217#) +# (ord# c2 *# 43#) +# len#) `remInt#` hASH_TBL_SIZE#
368   where
369     c0 = indexCharOffAddr# a# 0#
370     c1 = indexCharOffAddr# a# (len# `quotInt#` 2# -# 1#)
371     c2 = indexCharOffAddr# a# (len# -# 1#)
372 {-
373     c1 = indexCharOffAddr# a# 1#
374     c2 = indexCharOffAddr# a# 2#
375 -}
376
377 hashSubStrFO  :: ForeignObj# -> Int# -> Int# -> Int#
378  -- use the FO to produce a hash value between 0 & m (inclusive)
379 hashSubStrFO fo# start# len# =
380   case len# of
381    0# -> 0#
382    1# -> ((ord# c0 *# 631#) +# len#) `remInt#` hASH_TBL_SIZE#
383    2# -> ((ord# c0 *# 631#) +# (ord# c1 *# 217#) +# len#) `remInt#` hASH_TBL_SIZE#
384    _  -> ((ord# c0 *# 631#) +# (ord# c1 *# 217#) +# (ord# c2 *# 43#) +# len#) `remInt#` hASH_TBL_SIZE#
385   where
386     c0 = indexCharOffFO# fo# 0#
387     c1 = indexCharOffFO# fo# (len# `quotInt#` 2# -# 1#)
388     c2 = indexCharOffFO# fo# (len# -# 1#)
389
390 --    c1 = indexCharOffFO# fo# 1#
391 --    c2 = indexCharOffFO# fo# 2#
392
393
394 hashSubStrBA  :: ByteArray# -> Int# -> Int# -> Int#
395  -- use the byte array to produce a hash value between 0 & m (inclusive)
396 hashSubStrBA ba# start# len# =
397   case len# of
398    0# -> 0#
399    1# -> ((ord# c0 *# 631#) +# len#) `remInt#` hASH_TBL_SIZE#
400    2# -> ((ord# c0 *# 631#) +# (ord# c1 *# 217#) +# len#) `remInt#` hASH_TBL_SIZE#
401    _  -> ((ord# c0 *# 631#) +# (ord# c1 *# 217#) +# (ord# c2 *# 43#) +# len#) `remInt#` hASH_TBL_SIZE#
402   where
403     c0 = indexCharArray# ba# 0#
404     c1 = indexCharArray# ba# (len# `quotInt#` 2# -# 1#)
405     c2 = indexCharArray# ba# (len# -# 1#)
406
407 --    c1 = indexCharArray# ba# 1#
408 --    c2 = indexCharArray# ba# 2#
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}