c6dac8ff428d083c2a38a73ec28bd0dd30862993
[ghc-hetmet.git] / compiler / utils / FastString.lhs
1 %
2 % (c) The University of Glasgow, 1997-2006
3 %
4 \begin{code}
5 {-# LANGUAGE BangPatterns #-}
6 {-# OPTIONS -fno-warn-unused-imports #-}
7 -- XXX GHC 6.9 seems to be confused by unpackCString# being used only in
8 --     a RULE
9
10 {-# OPTIONS_GHC -O -funbox-strict-fields #-}
11 -- We always optimise this, otherwise performance of a non-optimised
12 -- compiler is severely affected
13
14 -- |
15 -- There are two principal string types used internally by GHC:
16 --
17 -- 'FastString':
18 --               * A compact, hash-consed, representation of character strings.
19 --               * Comparison is O(1), and you can get a 'Unique.Unique' from them.
20 --               * Generated by 'fsLit'.
21 --               * Turn into 'Outputable.SDoc' with 'Outputable.ftext'.
22 --
23 -- 'LitString':
24 --               * Just a wrapper for the @Addr#@ of a C string (@Ptr CChar@).
25 --               * Practically no operations.
26 --               * Outputing them is fast.
27 --               * Generated by 'sLit'.
28 --               * Turn into 'Outputable.SDoc' with 'Outputable.ptext'
29 --
30 -- Use 'LitString' unless you want the facilities of 'FastString'.
31 module FastString
32        (
33         -- * FastStrings
34         FastString(..),     -- not abstract, for now.
35
36         -- ** Construction
37         fsLit,
38         mkFastString,
39         mkFastStringBytes,
40         mkFastStringByteList,
41         mkFastStringForeignPtr,
42 #if defined(__GLASGOW_HASKELL__)
43         mkFastString#,
44 #endif
45         mkZFastString,
46         mkZFastStringBytes,
47
48         -- ** Deconstruction
49         unpackFS,           -- :: FastString -> String
50         bytesFS,            -- :: FastString -> [Word8]
51
52         -- ** Encoding
53         isZEncoded,
54         zEncodeFS,
55
56         -- ** Operations
57         uniqueOfFS,
58         lengthFS,
59         nullFS,
60         appendFS,
61         headFS,
62         tailFS,
63         concatFS,
64         consFS,
65         nilFS,
66
67         -- ** Outputing
68         hPutFS,
69
70         -- ** Internal
71         getFastStringTable,
72         hasZEncoding,
73
74         -- * LitStrings
75         LitString,
76         
77         -- ** Construction
78         sLit,
79 #if defined(__GLASGOW_HASKELL__)
80         mkLitString#,
81 #endif
82         mkLitString,
83         
84         -- ** Deconstruction
85         unpackLitString,
86         
87         -- ** Operations
88         lengthLS
89        ) where
90
91 #include "HsVersions.h"
92
93 import Encoding
94 import FastTypes
95 import FastFunctions
96 import Panic
97 import Util
98
99 import Foreign hiding   ( unsafePerformIO )
100 import Foreign.C
101 import GHC.Exts
102 import System.IO
103 import System.IO.Unsafe ( unsafePerformIO )
104 import Data.Data
105 import Data.IORef       ( IORef, newIORef, readIORef, writeIORef )
106 import Data.Maybe       ( isJust )
107 import Data.Char        ( ord )
108
109 import GHC.IO ( IO(..) )
110
111 import GHC.Ptr          ( Ptr(..) )
112 #if defined(__GLASGOW_HASKELL__)
113 import GHC.Base         ( unpackCString# )
114 #endif
115
116 #define hASH_TBL_SIZE          4091
117 #define hASH_TBL_SIZE_UNBOXED  4091#
118
119
120 {-|
121 A 'FastString' is an array of bytes, hashed to support fast O(1)
122 comparison.  It is also associated with a character encoding, so that
123 we know how to convert a 'FastString' to the local encoding, or to the
124 Z-encoding used by the compiler internally.
125
126 'FastString's support a memoized conversion to the Z-encoding via zEncodeFS.
127 -}
128
129 data FastString = FastString {
130       uniq    :: {-# UNPACK #-} !Int, -- unique id
131       n_bytes :: {-# UNPACK #-} !Int, -- number of bytes
132       n_chars :: {-# UNPACK #-} !Int, -- number of chars
133       buf     :: {-# UNPACK #-} !(ForeignPtr Word8),
134       enc     :: FSEncoding
135   } deriving Typeable
136
137 data FSEncoding
138     -- including strings that don't need any encoding
139   = ZEncoded
140     -- A UTF-8 string with a memoized Z-encoding
141   | UTF8Encoded {-# UNPACK #-} !(IORef (Maybe FastString))
142
143 instance Eq FastString where
144   f1 == f2  =  uniq f1 == uniq f2
145
146 instance Ord FastString where
147     -- Compares lexicographically, not by unique
148     a <= b = case cmpFS a b of { LT -> True;  EQ -> True;  GT -> False }
149     a <  b = case cmpFS a b of { LT -> True;  EQ -> False; GT -> False }
150     a >= b = case cmpFS a b of { LT -> False; EQ -> True;  GT -> True  }
151     a >  b = case cmpFS a b of { LT -> False; EQ -> False; GT -> True  }
152     max x y | x >= y    =  x
153             | otherwise =  y
154     min x y | x <= y    =  x
155             | otherwise =  y
156     compare a b = cmpFS a b
157
158 instance Show FastString where
159    show fs = show (unpackFS fs)
160
161 instance Data FastString where
162   -- don't traverse?
163   toConstr _   = abstractConstr "FastString"
164   gunfold _ _  = error "gunfold"
165   dataTypeOf _ = mkNoRepType "FastString"
166
167 cmpFS :: FastString -> FastString -> Ordering
168 cmpFS (FastString u1 l1 _ buf1 _) (FastString u2 l2 _ buf2 _) =
169   if u1 == u2 then EQ else
170   case unsafeMemcmp buf1 buf2 (min l1 l2) `compare` 0 of
171      LT -> LT
172      EQ -> compare l1 l2
173      GT -> GT
174
175 unsafeMemcmp :: ForeignPtr a -> ForeignPtr b -> Int -> Int
176 unsafeMemcmp buf1 buf2 l =
177       inlinePerformIO $
178         withForeignPtr buf1 $ \p1 ->
179         withForeignPtr buf2 $ \p2 ->
180           memcmp p1 p2 l
181
182 #ifndef __HADDOCK__
183 foreign import ccall unsafe "ghc_memcmp"
184   memcmp :: Ptr a -> Ptr b -> Int -> IO Int
185 #endif
186
187 -- -----------------------------------------------------------------------------
188 -- Construction
189
190 {-
191 Internally, the compiler will maintain a fast string symbol
192 table, providing sharing and fast comparison. Creation of
193 new @FastString@s then covertly does a lookup, re-using the
194 @FastString@ if there was a hit.
195 -}
196
197 data FastStringTable =
198  FastStringTable
199     {-# UNPACK #-} !Int
200     (MutableArray# RealWorld [FastString])
201
202 {-# NOINLINE string_table #-}
203 string_table :: IORef FastStringTable
204 string_table =
205  unsafePerformIO $ do
206    tab <- IO $ \s1# -> case newArray# hASH_TBL_SIZE_UNBOXED [] s1# of
207                            (# s2#, arr# #) ->
208                                (# s2#, FastStringTable 0 arr# #)
209    newIORef tab
210
211 lookupTbl :: FastStringTable -> Int -> IO [FastString]
212 lookupTbl (FastStringTable _ arr#) (I# i#) =
213   IO $ \ s# -> readArray# arr# i# s#
214
215 updTbl :: IORef FastStringTable -> FastStringTable -> Int -> [FastString] -> IO ()
216 updTbl fs_table_var (FastStringTable uid arr#) (I# i#) ls = do
217   (IO $ \ s# -> case writeArray# arr# i# ls s# of { s2# -> (# s2#, () #) })
218   writeIORef fs_table_var (FastStringTable (uid+1) arr#)
219
220 mkFastString# :: Addr# -> FastString
221 mkFastString# a# = mkFastStringBytes ptr (ptrStrLength ptr)
222   where ptr = Ptr a#
223
224 mkFastStringBytes :: Ptr Word8 -> Int -> FastString
225 mkFastStringBytes ptr len = unsafePerformIO $ do
226   ft@(FastStringTable uid _) <- readIORef string_table
227   let
228    h = hashStr ptr len
229    add_it ls = do
230         fs <- copyNewFastString uid ptr len
231         updTbl string_table ft h (fs:ls)
232         {- _trace ("new: " ++ show f_str)   $ -}
233         return fs
234   --
235   lookup_result <- lookupTbl ft h
236   case lookup_result of
237     [] -> add_it []
238     ls -> do
239        b <- bucket_match ls len ptr
240        case b of
241          Nothing -> add_it ls
242          Just v  -> {- _trace ("re-use: "++show v) $ -} return v
243
244 mkZFastStringBytes :: Ptr Word8 -> Int -> FastString
245 mkZFastStringBytes ptr len = unsafePerformIO $ do
246   ft@(FastStringTable uid _) <- readIORef string_table
247   let
248    h = hashStr ptr len
249    add_it ls = do
250         fs <- copyNewZFastString uid ptr len
251         updTbl string_table ft h (fs:ls)
252         {- _trace ("new: " ++ show f_str)   $ -}
253         return fs
254   --
255   lookup_result <- lookupTbl ft h
256   case lookup_result of
257     [] -> add_it []
258     ls -> do
259        b <- bucket_match ls len ptr
260        case b of
261          Nothing -> add_it ls
262          Just v  -> {- _trace ("re-use: "++show v) $ -} return v
263
264 -- | Create a 'FastString' from an existing 'ForeignPtr'; the difference
265 -- between this and 'mkFastStringBytes' is that we don't have to copy
266 -- the bytes if the string is new to the table.
267 mkFastStringForeignPtr :: Ptr Word8 -> ForeignPtr Word8 -> Int -> IO FastString
268 mkFastStringForeignPtr ptr fp len = do
269   ft@(FastStringTable uid _) <- readIORef string_table
270 --  _trace ("hashed: "++show (I# h)) $
271   let
272     h = hashStr ptr len
273     add_it ls = do
274         fs <- mkNewFastString uid ptr fp len
275         updTbl string_table ft h (fs:ls)
276         {- _trace ("new: " ++ show f_str)   $ -}
277         return fs
278   --
279   lookup_result <- lookupTbl ft h
280   case lookup_result of
281     [] -> add_it []
282     ls -> do
283        b <- bucket_match ls len ptr
284        case b of
285          Nothing -> add_it ls
286          Just v  -> {- _trace ("re-use: "++show v) $ -} return v
287
288 mkZFastStringForeignPtr :: Ptr Word8 -> ForeignPtr Word8 -> Int -> IO FastString
289 mkZFastStringForeignPtr ptr fp len = do
290   ft@(FastStringTable uid _) <- readIORef string_table
291 --  _trace ("hashed: "++show (I# h)) $
292   let
293     h = hashStr ptr len
294     add_it ls = do
295         fs <- mkNewZFastString uid ptr fp len
296         updTbl string_table ft h (fs:ls)
297         {- _trace ("new: " ++ show f_str)   $ -}
298         return fs
299   --
300   lookup_result <- lookupTbl ft h
301   case lookup_result of
302     [] -> add_it []
303     ls -> do
304        b <- bucket_match ls len ptr
305        case b of
306          Nothing -> add_it ls
307          Just v  -> {- _trace ("re-use: "++show v) $ -} return v
308
309
310 -- | Creates a UTF-8 encoded 'FastString' from a 'String'
311 mkFastString :: String -> FastString
312 mkFastString str =
313   inlinePerformIO $ do
314     let l = utf8EncodedLength str
315     buf <- mallocForeignPtrBytes l
316     withForeignPtr buf $ \ptr -> do
317       utf8EncodeString ptr str
318       mkFastStringForeignPtr ptr buf l
319
320 -- | Creates a 'FastString' from a UTF-8 encoded @[Word8]@
321 mkFastStringByteList :: [Word8] -> FastString
322 mkFastStringByteList str =
323   inlinePerformIO $ do
324     let l = Prelude.length str
325     buf <- mallocForeignPtrBytes l
326     withForeignPtr buf $ \ptr -> do
327       pokeArray (castPtr ptr) str
328       mkFastStringForeignPtr ptr buf l
329
330 -- | Creates a Z-encoded 'FastString' from a 'String'
331 mkZFastString :: String -> FastString
332 mkZFastString str =
333   inlinePerformIO $ do
334     let l = Prelude.length str
335     buf <- mallocForeignPtrBytes l
336     withForeignPtr buf $ \ptr -> do
337       pokeCAString (castPtr ptr) str
338       mkZFastStringForeignPtr ptr buf l
339
340 bucket_match :: [FastString] -> Int -> Ptr Word8 -> IO (Maybe FastString)
341 bucket_match [] _ _ = return Nothing
342 bucket_match (v@(FastString _ l _ buf _):ls) len ptr
343       | len == l  =  do
344          b <- cmpStringPrefix ptr buf len
345          if b then return (Just v)
346               else bucket_match ls len ptr
347       | otherwise =
348          bucket_match ls len ptr
349
350 mkNewFastString :: Int -> Ptr Word8 -> ForeignPtr Word8 -> Int
351                 -> IO FastString
352 mkNewFastString uid ptr fp len = do
353   ref <- newIORef Nothing
354   n_chars <- countUTF8Chars ptr len
355   return (FastString uid len n_chars fp (UTF8Encoded ref))
356
357 mkNewZFastString :: Int -> Ptr Word8 -> ForeignPtr Word8 -> Int
358                  -> IO FastString
359 mkNewZFastString uid _ fp len = do
360   return (FastString uid len len fp ZEncoded)
361
362 copyNewFastString :: Int -> Ptr Word8 -> Int -> IO FastString
363 copyNewFastString uid ptr len = do
364   fp <- copyBytesToForeignPtr ptr len
365   ref <- newIORef Nothing
366   n_chars <- countUTF8Chars ptr len
367   return (FastString uid len n_chars fp (UTF8Encoded ref))
368
369 copyNewZFastString :: Int -> Ptr Word8 -> Int -> IO FastString
370 copyNewZFastString uid ptr len = do
371   fp <- copyBytesToForeignPtr ptr len
372   return (FastString uid len len fp ZEncoded)
373
374 copyBytesToForeignPtr :: Ptr Word8 -> Int -> IO (ForeignPtr Word8)
375 copyBytesToForeignPtr ptr len = do
376   fp <- mallocForeignPtrBytes len
377   withForeignPtr fp $ \ptr' -> copyBytes ptr' ptr len
378   return fp
379
380 cmpStringPrefix :: Ptr Word8 -> ForeignPtr Word8 -> Int -> IO Bool
381 cmpStringPrefix ptr fp len =
382   withForeignPtr fp $ \ptr' -> do
383     r <- memcmp ptr ptr' len
384     return (r == 0)
385
386
387 hashStr  :: Ptr Word8 -> Int -> Int
388  -- use the Addr to produce a hash value between 0 & m (inclusive)
389 hashStr (Ptr a#) (I# len#) = loop 0# 0#
390    where
391     loop h n | n GHC.Exts.==# len# = I# h
392              | otherwise  = loop h2 (n GHC.Exts.+# 1#)
393           where !c = ord# (indexCharOffAddr# a# n)
394                 !h2 = (c GHC.Exts.+# (h GHC.Exts.*# 128#)) `remInt#`
395                       hASH_TBL_SIZE#
396
397 -- -----------------------------------------------------------------------------
398 -- Operations
399
400 -- | Returns the length of the 'FastString' in characters
401 lengthFS :: FastString -> Int
402 lengthFS f = n_chars f
403
404 -- | Returns @True@ if the 'FastString' is Z-encoded
405 isZEncoded :: FastString -> Bool
406 isZEncoded fs | ZEncoded <- enc fs = True
407               | otherwise          = False
408
409 -- | Returns @True@ if this 'FastString' is not Z-encoded but already has
410 -- a Z-encoding cached (used in producing stats).
411 hasZEncoding :: FastString -> Bool
412 hasZEncoding (FastString _ _ _ _ enc) =
413   case enc of
414     ZEncoded -> False
415     UTF8Encoded ref ->
416       inlinePerformIO $ do
417         m <- readIORef ref
418         return (isJust m)
419
420 -- | Returns @True@ if the 'FastString' is empty
421 nullFS :: FastString -> Bool
422 nullFS f  =  n_bytes f == 0
423
424 -- | Unpacks and decodes the FastString
425 unpackFS :: FastString -> String
426 unpackFS (FastString _ n_bytes _ buf enc) =
427   inlinePerformIO $ withForeignPtr buf $ \ptr ->
428     case enc of
429         ZEncoded      -> peekCAStringLen (castPtr ptr,n_bytes)
430         UTF8Encoded _ -> utf8DecodeString ptr n_bytes
431
432 bytesFS :: FastString -> [Word8]
433 bytesFS (FastString _ n_bytes _ buf _) =
434   inlinePerformIO $ withForeignPtr buf $ \ptr ->
435     peekArray n_bytes ptr
436
437 -- | Returns a Z-encoded version of a 'FastString'.  This might be the
438 -- original, if it was already Z-encoded.  The first time this
439 -- function is applied to a particular 'FastString', the results are
440 -- memoized.
441 --
442 zEncodeFS :: FastString -> FastString
443 zEncodeFS fs@(FastString _ _ _ _ enc) =
444   case enc of
445     ZEncoded -> fs
446     UTF8Encoded ref ->
447       inlinePerformIO $ do
448         m <- readIORef ref
449         case m of
450           Just fs -> return fs
451           Nothing -> do
452             let efs = mkZFastString (zEncodeString (unpackFS fs))
453             writeIORef ref (Just efs)
454             return efs
455
456 appendFS :: FastString -> FastString -> FastString
457 appendFS fs1 fs2 =
458   inlinePerformIO $ do
459     r <- mallocForeignPtrBytes len
460     withForeignPtr r $ \ r' -> do
461     withForeignPtr (buf fs1) $ \ fs1Ptr -> do
462     withForeignPtr (buf fs2) $ \ fs2Ptr -> do
463         copyBytes r' fs1Ptr len1
464         copyBytes (advancePtr r' len1) fs2Ptr len2
465         mkFastStringForeignPtr r' r len
466   where len  = len1 + len2
467         len1 = lengthFS fs1
468         len2 = lengthFS fs2
469
470 concatFS :: [FastString] -> FastString
471 concatFS ls = mkFastString (Prelude.concat (map unpackFS ls)) -- ToDo: do better
472
473 headFS :: FastString -> Char
474 headFS (FastString _ 0 _ _ _) = panic "headFS: Empty FastString"
475 headFS (FastString _ _ _ buf enc) =
476   inlinePerformIO $ withForeignPtr buf $ \ptr -> do
477     case enc of
478       ZEncoded -> do
479          w <- peek (castPtr ptr)
480          return (castCCharToChar w)
481       UTF8Encoded _ ->
482          return (fst (utf8DecodeChar ptr))
483
484 tailFS :: FastString -> FastString
485 tailFS (FastString _ 0 _ _ _) = panic "tailFS: Empty FastString"
486 tailFS (FastString _ n_bytes _ buf enc) =
487   inlinePerformIO $ withForeignPtr buf $ \ptr -> do
488     case enc of
489       ZEncoded -> do
490         return $! mkZFastStringBytes (ptr `plusPtr` 1) (n_bytes - 1)
491       UTF8Encoded _ -> do
492          let (_,ptr') = utf8DecodeChar ptr
493          let off = ptr' `minusPtr` ptr
494          return $! mkFastStringBytes (ptr `plusPtr` off) (n_bytes - off)
495
496 consFS :: Char -> FastString -> FastString
497 consFS c fs = mkFastString (c : unpackFS fs)
498
499 uniqueOfFS :: FastString -> FastInt
500 uniqueOfFS (FastString u _ _ _ _) = iUnbox u
501
502 nilFS :: FastString
503 nilFS = mkFastString ""
504
505 -- -----------------------------------------------------------------------------
506 -- Stats
507
508 getFastStringTable :: IO [[FastString]]
509 getFastStringTable = do
510   tbl <- readIORef string_table
511   buckets <- mapM (lookupTbl tbl) [0 .. hASH_TBL_SIZE]
512   return buckets
513
514 -- -----------------------------------------------------------------------------
515 -- Outputting 'FastString's
516
517 -- |Outputs a 'FastString' with /no decoding at all/, that is, you
518 -- get the actual bytes in the 'FastString' written to the 'Handle'.
519 hPutFS :: Handle -> FastString -> IO ()
520 hPutFS handle (FastString _ len _ fp _)
521   | len == 0  = return ()
522   | otherwise = do withForeignPtr fp $ \ptr -> hPutBuf handle ptr len
523
524 -- ToDo: we'll probably want an hPutFSLocal, or something, to output
525 -- in the current locale's encoding (for error messages and suchlike).
526
527 -- -----------------------------------------------------------------------------
528 -- LitStrings, here for convenience only.
529
530 -- hmm, not unboxed (or rather FastPtr), interesting
531 --a.k.a. Ptr CChar, Ptr Word8, Ptr (), hmph.  We don't
532 --really care about C types in naming, where we can help it.
533 type LitString = Ptr Word8
534 --Why do we recalculate length every time it's requested?
535 --If it's commonly needed, we should perhaps have
536 --data LitString = LitString {-#UNPACK#-}!(FastPtr Word8) {-#UNPACK#-}!FastInt
537
538 #if defined(__GLASGOW_HASKELL__)
539 mkLitString# :: Addr# -> LitString
540 mkLitString# a# = Ptr a#
541 #endif
542 --can/should we use FastTypes here?
543 --Is this likely to be memory-preserving if only used on constant strings?
544 --should we inline it? If lucky, that would make a CAF that wouldn't
545 --be computationally repeated... although admittedly we're not
546 --really intending to use mkLitString when __GLASGOW_HASKELL__...
547 --(I wonder, is unicode / multi-byte characters allowed in LitStrings
548 -- at all?)
549 {-# INLINE mkLitString #-}
550 mkLitString :: String -> LitString
551 mkLitString s =
552  unsafePerformIO (do
553    p <- mallocBytes (length s + 1)
554    let
555      loop :: Int -> String -> IO ()
556      loop n cs | n `seq` null cs = pokeByteOff p n (0 :: Word8)
557      loop n (c:cs) = do
558         pokeByteOff p n (fromIntegral (ord c) :: Word8)
559         loop (1+n) cs
560      -- XXX GHC isn't smart enough to know that we have already covered
561      -- this case.
562      loop _ [] = panic "mkLitString"
563    loop 0 s
564    return p
565  )
566
567 unpackLitString :: LitString -> String
568 unpackLitString p_ = case pUnbox p_ of
569  p -> unpack (_ILIT(0))
570   where
571     unpack n = case indexWord8OffFastPtrAsFastChar p n of
572       ch -> if ch `eqFastChar` _CLIT('\0')
573             then [] else cBox ch : unpack (n +# _ILIT(1))
574
575 lengthLS :: LitString -> Int
576 lengthLS = ptrStrLength
577
578 -- for now, use a simple String representation
579 --no, let's not do that right now - it's work in other places
580 #if 0
581 type LitString = String
582
583 mkLitString :: String -> LitString
584 mkLitString = id
585
586 unpackLitString :: LitString -> String
587 unpackLitString = id
588
589 lengthLS :: LitString -> Int
590 lengthLS = length
591
592 #endif
593
594 -- -----------------------------------------------------------------------------
595 -- under the carpet
596
597 foreign import ccall unsafe "ghc_strlen"
598   ptrStrLength :: Ptr Word8 -> Int
599
600 -- NB. does *not* add a '\0'-terminator.
601 -- We only use CChar here to be parallel to the imported
602 -- peekC(A)StringLen.
603 pokeCAString :: Ptr CChar -> String -> IO ()
604 pokeCAString ptr str =
605   let
606         go [] _     = return ()
607         go (c:cs) n = do pokeElemOff ptr n (castCharToCChar c); go cs (n+1)
608   in
609   go str 0
610
611 {-# NOINLINE sLit #-}
612 sLit :: String -> LitString
613 sLit x  = mkLitString x
614
615 {-# NOINLINE fsLit #-}
616 fsLit :: String -> FastString
617 fsLit x = mkFastString x
618
619 {-# RULES "slit"
620     forall x . sLit  (unpackCString# x) = mkLitString#  x #-}
621 {-# RULES "fslit"
622     forall x . fsLit (unpackCString# x) = mkFastString# x #-}
623 \end{code}