Fix warnings in utils/Maybes
[ghc-hetmet.git] / compiler / utils / FastString.lhs
1 %
2 % (c) The University of Glasgow, 1997-2006
3 %
4 \begin{code}
5 {-# OPTIONS -w #-}
6 -- The above warning supression flag is a temporary kludge.
7 -- While working on this module you are encouraged to remove it and fix
8 -- any warnings in the module. See
9 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
10 -- for details
11
12 {-
13 FastString:     A compact, hash-consed, representation of character strings.
14                 Comparison is O(1), and you can get a Unique from them.
15                 Generated by the FSLIT macro
16                 Turn into SDoc with Outputable.ftext
17
18 LitString:      Just a wrapper for the Addr# of a C string (Ptr CChar).
19                 Practically no operations
20                 Outputing them is fast
21                 Generated by the SLIT macro
22                 Turn into SDoc with Outputable.ptext
23
24 Use LitString unless you want the facilities of FastString
25 -}
26 module FastString
27        (
28         -- * FastStrings
29         FastString(..),     -- not abstract, for now.
30
31         -- ** Construction
32         mkFastString,
33         mkFastStringBytes,
34         mkFastStringByteList,
35         mkFastStringForeignPtr,
36         mkFastString#,
37         mkZFastString,
38         mkZFastStringBytes,
39
40         -- ** Deconstruction
41         unpackFS,           -- :: FastString -> String
42         bytesFS,            -- :: FastString -> [Word8]
43
44         -- ** Encoding
45         isZEncoded,
46         zEncodeFS,
47
48         -- ** Operations
49         uniqueOfFS,
50         lengthFS,
51         nullFS,
52         appendFS,
53         headFS,
54         tailFS,
55         concatFS,
56         consFS,
57         nilFS,
58
59         -- ** Outputing
60         hPutFS,
61
62         -- ** Internal
63         getFastStringTable,
64         hasZEncoding,
65
66         -- * LitStrings
67         LitString, 
68         mkLitString#,
69         strLength
70        ) where
71
72 -- This #define suppresses the "import FastString" that
73 -- HsVersions otherwise produces
74 #define COMPILING_FAST_STRING
75 #include "HsVersions.h"
76
77 import Encoding
78
79 import Foreign
80 import Foreign.C
81 import GHC.Exts
82 import System.IO.Unsafe ( unsafePerformIO )
83 import Control.Monad.ST ( stToIO )
84 import Data.IORef       ( IORef, newIORef, readIORef, writeIORef )
85 import System.IO        ( hPutBuf )
86 import Data.Maybe       ( isJust )
87
88 import GHC.ST
89 import GHC.IOBase       ( IO(..) )
90 import GHC.Ptr          ( Ptr(..) )
91
92 #define hASH_TBL_SIZE          4091
93 #define hASH_TBL_SIZE_UNBOXED  4091#
94
95
96 {-|
97 A 'FastString' is an array of bytes, hashed to support fast O(1)
98 comparison.  It is also associated with a character encoding, so that
99 we know how to convert a 'FastString' to the local encoding, or to the
100 Z-encoding used by the compiler internally.
101
102 'FastString's support a memoized conversion to the Z-encoding via zEncodeFS.
103 -}
104
105 data FastString = FastString {
106       uniq    :: {-# UNPACK #-} !Int,       -- unique id
107       n_bytes :: {-# UNPACK #-} !Int,       -- number of bytes
108       n_chars :: {-# UNPACK #-} !Int,     -- number of chars
109       buf     :: {-# UNPACK #-} !(ForeignPtr Word8),
110       enc     :: FSEncoding
111   }
112
113 data FSEncoding
114   = ZEncoded
115         -- including strings that don't need any encoding
116   | UTF8Encoded {-# UNPACK #-} !(IORef (Maybe FastString))
117         -- A UTF-8 string with a memoized Z-encoding
118
119 instance Eq FastString where
120   f1 == f2  =  uniq f1 == uniq f2
121
122 instance Ord FastString where
123         -- Compares lexicographically, not by unique
124     a <= b = case cmpFS a b of { LT -> True;  EQ -> True;  GT -> False }
125     a <  b = case cmpFS a b of { LT -> True;  EQ -> False; GT -> False }
126     a >= b = case cmpFS a b of { LT -> False; EQ -> True;  GT -> True  }
127     a >  b = case cmpFS a b of { LT -> False; EQ -> False; GT -> True  }
128     max x y | x >= y    =  x
129             | otherwise =  y
130     min x y | x <= y    =  x
131             | otherwise =  y
132     compare a b = cmpFS a b
133
134 instance Show FastString where
135    show fs = show (unpackFS fs)
136
137 cmpFS :: FastString -> FastString -> Ordering
138 cmpFS (FastString u1 l1 _ buf1 _) (FastString u2 l2 _ buf2 _) =
139   if u1 == u2 then EQ else
140   case unsafeMemcmp buf1 buf2 (min l1 l2) `compare` 0 of
141      LT -> LT
142      EQ -> compare l1 l2
143      GT -> GT
144
145 unsafeMemcmp :: ForeignPtr a -> ForeignPtr b -> Int -> Int
146 unsafeMemcmp buf1 buf2 l =
147       inlinePerformIO $
148         withForeignPtr buf1 $ \p1 ->
149         withForeignPtr buf2 $ \p2 ->
150           memcmp p1 p2 l
151
152 #ifndef __HADDOCK__
153 foreign import ccall unsafe "ghc_memcmp" 
154   memcmp :: Ptr a -> Ptr b -> Int -> IO Int
155 #endif
156
157 -- -----------------------------------------------------------------------------
158 -- Construction
159
160 {-
161 Internally, the compiler will maintain a fast string symbol
162 table, providing sharing and fast comparison. Creation of
163 new @FastString@s then covertly does a lookup, re-using the
164 @FastString@ if there was a hit.
165 -}
166
167 data FastStringTable = 
168  FastStringTable
169     {-# UNPACK #-} !Int
170     (MutableArray# RealWorld [FastString])
171
172 {-# NOINLINE string_table #-}
173 string_table :: IORef FastStringTable
174 string_table = 
175  unsafePerformIO $ do
176    tab <- IO $ \s1# -> case newArray# hASH_TBL_SIZE_UNBOXED [] s1# of
177                            (# s2#, arr# #) ->
178                                (# s2#, FastStringTable 0 arr# #)
179    newIORef tab
180
181 lookupTbl :: FastStringTable -> Int -> IO [FastString]
182 lookupTbl (FastStringTable _ arr#) (I# i#) =
183   IO $ \ s# -> readArray# arr# i# s#
184
185 updTbl :: IORef FastStringTable -> FastStringTable -> Int -> [FastString] -> IO ()
186 updTbl fs_table_var (FastStringTable uid arr#) (I# i#) ls = do
187   (IO $ \ s# -> case writeArray# arr# i# ls s# of { s2# -> (# s2#, () #) })
188   writeIORef fs_table_var (FastStringTable (uid+1) arr#)
189
190 mkFastString# :: Addr# -> FastString
191 mkFastString# a# = mkFastStringBytes ptr (strLength ptr)
192   where ptr = Ptr a#
193
194 mkFastStringBytes :: Ptr Word8 -> Int -> FastString
195 mkFastStringBytes ptr len = unsafePerformIO $ do
196   ft@(FastStringTable uid tbl#) <- readIORef string_table
197   let
198    h = hashStr ptr len
199    add_it ls = do
200         fs <- copyNewFastString uid ptr len
201         updTbl string_table ft h (fs:ls)
202         {- _trace ("new: " ++ show f_str)   $ -}
203         return fs
204   --
205   lookup_result <- lookupTbl ft h
206   case lookup_result of
207     [] -> add_it []
208     ls -> do
209        b <- bucket_match ls len ptr
210        case b of
211          Nothing -> add_it ls
212          Just v  -> {- _trace ("re-use: "++show v) $ -} return v
213
214 mkZFastStringBytes :: Ptr Word8 -> Int -> FastString
215 mkZFastStringBytes ptr len = unsafePerformIO $ do
216   ft@(FastStringTable uid tbl#) <- readIORef string_table
217   let
218    h = hashStr ptr len
219    add_it ls = do
220         fs <- copyNewZFastString uid ptr len
221         updTbl string_table ft h (fs:ls)
222         {- _trace ("new: " ++ show f_str)   $ -}
223         return fs
224   --
225   lookup_result <- lookupTbl ft h
226   case lookup_result of
227     [] -> add_it []
228     ls -> do
229        b <- bucket_match ls len ptr
230        case b of
231          Nothing -> add_it ls
232          Just v  -> {- _trace ("re-use: "++show v) $ -} return v
233
234 -- | Create a 'FastString' from an existing 'ForeignPtr'; the difference
235 -- between this and 'mkFastStringBytes' is that we don't have to copy
236 -- the bytes if the string is new to the table.
237 mkFastStringForeignPtr :: Ptr Word8 -> ForeignPtr Word8 -> Int -> IO FastString
238 mkFastStringForeignPtr ptr fp len = do
239   ft@(FastStringTable uid tbl#) <- readIORef string_table
240 --  _trace ("hashed: "++show (I# h)) $
241   let
242     h = hashStr ptr len
243     add_it ls = do
244         fs <- mkNewFastString uid ptr fp len
245         updTbl string_table ft h (fs:ls)
246         {- _trace ("new: " ++ show f_str)   $ -}
247         return fs
248   --
249   lookup_result <- lookupTbl ft h
250   case lookup_result of
251     [] -> add_it []
252     ls -> do
253        b <- bucket_match ls len ptr
254        case b of
255          Nothing -> add_it ls
256          Just v  -> {- _trace ("re-use: "++show v) $ -} return v
257
258 mkZFastStringForeignPtr :: Ptr Word8 -> ForeignPtr Word8 -> Int -> IO FastString
259 mkZFastStringForeignPtr ptr fp len = do
260   ft@(FastStringTable uid tbl#) <- readIORef string_table
261 --  _trace ("hashed: "++show (I# h)) $
262   let
263     h = hashStr ptr len
264     add_it ls = do
265         fs <- mkNewZFastString uid ptr fp len
266         updTbl string_table ft h (fs:ls)
267         {- _trace ("new: " ++ show f_str)   $ -}
268         return fs
269   --
270   lookup_result <- lookupTbl ft h
271   case lookup_result of
272     [] -> add_it []
273     ls -> do
274        b <- bucket_match ls len ptr
275        case b of
276          Nothing -> add_it ls
277          Just v  -> {- _trace ("re-use: "++show v) $ -} return v
278
279
280 -- | Creates a UTF-8 encoded 'FastString' from a 'String'
281 mkFastString :: String -> FastString
282 mkFastString str = 
283   inlinePerformIO $ do
284     let l = utf8EncodedLength str
285     buf <- mallocForeignPtrBytes l
286     withForeignPtr buf $ \ptr -> do
287       utf8EncodeString ptr str
288       mkFastStringForeignPtr ptr buf l 
289
290 -- | Creates a 'FastString' from a UTF-8 encoded @[Word8]@
291 mkFastStringByteList :: [Word8] -> FastString
292 mkFastStringByteList str = 
293   inlinePerformIO $ do
294     let l = Prelude.length str
295     buf <- mallocForeignPtrBytes l
296     withForeignPtr buf $ \ptr -> do
297       pokeArray (castPtr ptr) str
298       mkFastStringForeignPtr ptr buf l 
299
300 -- | Creates a Z-encoded 'FastString' from a 'String'
301 mkZFastString :: String -> FastString
302 mkZFastString str = 
303   inlinePerformIO $ do
304     let l = Prelude.length str
305     buf <- mallocForeignPtrBytes l
306     withForeignPtr buf $ \ptr -> do
307       pokeCAString (castPtr ptr) str
308       mkZFastStringForeignPtr ptr buf l 
309
310 bucket_match [] _ _ = return Nothing
311 bucket_match (v@(FastString _ l _ buf _):ls) len ptr
312       | len == l  =  do
313          b <- cmpStringPrefix ptr buf len
314          if b then return (Just v)
315               else bucket_match ls len ptr
316       | otherwise = 
317          bucket_match ls len ptr
318
319 mkNewFastString uid ptr fp len = do
320   ref <- newIORef Nothing
321   n_chars <- countUTF8Chars ptr len
322   return (FastString uid len n_chars fp (UTF8Encoded ref))
323
324 mkNewZFastString uid ptr fp len = do
325   return (FastString uid len len fp ZEncoded)
326
327
328 copyNewFastString uid ptr len = do
329   fp <- copyBytesToForeignPtr ptr len
330   ref <- newIORef Nothing
331   n_chars <- countUTF8Chars ptr len
332   return (FastString uid len n_chars fp (UTF8Encoded ref))
333
334 copyNewZFastString uid ptr len = do
335   fp <- copyBytesToForeignPtr ptr len
336   return (FastString uid len len fp ZEncoded)
337
338
339 copyBytesToForeignPtr ptr len = do
340   fp <- mallocForeignPtrBytes len
341   withForeignPtr fp $ \ptr' -> copyBytes ptr' ptr len
342   return fp
343
344 cmpStringPrefix :: Ptr Word8 -> ForeignPtr Word8 -> Int -> IO Bool
345 cmpStringPrefix ptr fp len =
346   withForeignPtr fp $ \ptr' -> do
347     r <- memcmp ptr ptr' len
348     return (r == 0)
349
350
351 hashStr  :: Ptr Word8 -> Int -> Int
352  -- use the Addr to produce a hash value between 0 & m (inclusive)
353 hashStr (Ptr a#) (I# len#) = loop 0# 0#
354    where 
355     loop h n | n ==# len# = I# h
356              | otherwise  = loop h2 (n +# 1#)
357           where c = ord# (indexCharOffAddr# a# n)
358                 h2 = (c +# (h *# 128#)) `remInt#` hASH_TBL_SIZE#
359
360 -- -----------------------------------------------------------------------------
361 -- Operations
362
363 -- | Returns the length of the 'FastString' in characters
364 lengthFS :: FastString -> Int
365 lengthFS f = n_chars f
366
367 -- | Returns 'True' if the 'FastString' is Z-encoded
368 isZEncoded :: FastString -> Bool
369 isZEncoded fs | ZEncoded <- enc fs = True
370                 | otherwise          = False
371
372 -- | Returns 'True' if this 'FastString' is not Z-encoded but already has
373 -- a Z-encoding cached (used in producing stats).
374 hasZEncoding :: FastString -> Bool
375 hasZEncoding fs@(FastString uid n_bytes _ fp enc) =
376   case enc of
377     ZEncoded -> False
378     UTF8Encoded ref ->
379       inlinePerformIO $ do
380         m <- readIORef ref
381         return (isJust m)
382
383 -- | Returns 'True' if the 'FastString' is empty
384 nullFS :: FastString -> Bool
385 nullFS f  =  n_bytes f == 0
386
387 -- | unpacks and decodes the FastString
388 unpackFS :: FastString -> String
389 unpackFS (FastString _ n_bytes _ buf enc) = 
390   inlinePerformIO $ withForeignPtr buf $ \ptr ->
391     case enc of
392         ZEncoded      -> peekCAStringLen (castPtr ptr,n_bytes)
393         UTF8Encoded _ -> utf8DecodeString ptr n_bytes
394
395 bytesFS :: FastString -> [Word8]
396 bytesFS (FastString _ n_bytes _ buf enc) = 
397   inlinePerformIO $ withForeignPtr buf $ \ptr ->
398     peekArray n_bytes ptr
399
400 -- | returns a Z-encoded version of a 'FastString'.  This might be the
401 -- original, if it was already Z-encoded.  The first time this
402 -- function is applied to a particular 'FastString', the results are
403 -- memoized.
404 --
405 zEncodeFS :: FastString -> FastString
406 zEncodeFS fs@(FastString uid n_bytes _ fp enc) =
407   case enc of
408     ZEncoded -> fs
409     UTF8Encoded ref ->
410       inlinePerformIO $ do
411         m <- readIORef ref
412         case m of
413           Just fs -> return fs
414           Nothing -> do
415             let efs = mkZFastString (zEncodeString (unpackFS fs))
416             writeIORef ref (Just efs)
417             return efs
418
419 appendFS :: FastString -> FastString -> FastString
420 appendFS fs1 fs2 = mkFastString (unpackFS fs1 ++ unpackFS fs2)
421
422 concatFS :: [FastString] -> FastString
423 concatFS ls = mkFastString (Prelude.concat (map unpackFS ls)) -- ToDo: do better
424
425 headFS :: FastString -> Char
426 headFS (FastString _ n_bytes _ buf enc) = 
427   inlinePerformIO $ withForeignPtr buf $ \ptr -> do
428     case enc of
429       ZEncoded -> do 
430          w <- peek (castPtr ptr)
431          return (castCCharToChar w)
432       UTF8Encoded _ -> 
433          return (fst (utf8DecodeChar ptr))
434
435 tailFS :: FastString -> FastString
436 tailFS (FastString _ n_bytes _ buf enc) = 
437   inlinePerformIO $ withForeignPtr buf $ \ptr -> do
438     case enc of
439       ZEncoded -> do
440         return $! mkZFastStringBytes (ptr `plusPtr` 1) (n_bytes - 1)
441       UTF8Encoded _ -> do
442          let (_,ptr') = utf8DecodeChar ptr
443          let off = ptr' `minusPtr` ptr
444          return $! mkFastStringBytes (ptr `plusPtr` off) (n_bytes - off)
445
446 consFS :: Char -> FastString -> FastString
447 consFS c fs = mkFastString (c : unpackFS fs)
448
449 uniqueOfFS :: FastString -> Int#
450 uniqueOfFS (FastString (I# u#) _ _ _ _) = u#
451
452 nilFS = mkFastString ""
453
454 -- -----------------------------------------------------------------------------
455 -- Stats
456
457 getFastStringTable :: IO [[FastString]]
458 getFastStringTable = do
459   tbl <- readIORef string_table
460   buckets <- mapM (lookupTbl tbl) [0 .. hASH_TBL_SIZE]
461   return buckets
462
463 -- -----------------------------------------------------------------------------
464 -- Outputting 'FastString's
465
466 -- |Outputs a 'FastString' with /no decoding at all/, that is, you
467 -- get the actual bytes in the 'FastString' written to the 'Handle'.
468 hPutFS handle (FastString _ len _ fp _)
469   | len == 0  = return ()
470   | otherwise = do withForeignPtr fp $ \ptr -> hPutBuf handle ptr len
471
472 -- ToDo: we'll probably want an hPutFSLocal, or something, to output
473 -- in the current locale's encoding (for error messages and suchlike).
474
475 -- -----------------------------------------------------------------------------
476 -- LitStrings, here for convenience only.
477
478 type LitString = Ptr ()
479
480 mkLitString# :: Addr# -> LitString
481 mkLitString# a# = Ptr a#
482
483 foreign import ccall unsafe "ghc_strlen" 
484   strLength :: Ptr () -> Int
485
486 -- -----------------------------------------------------------------------------
487 -- under the carpet
488
489 -- Just like unsafePerformIO, but we inline it.
490 {-# INLINE inlinePerformIO #-}
491 inlinePerformIO :: IO a -> a
492 inlinePerformIO (IO m) = case m realWorld# of (# _, r #)   -> r
493
494 -- NB. does *not* add a '\0'-terminator.
495 pokeCAString :: Ptr CChar -> String -> IO ()
496 pokeCAString ptr str =
497   let
498         go [] n     = return ()
499         go (c:cs) n = do pokeElemOff ptr n (castCharToCChar c); go cs (n+1)
500   in
501   go str 0
502
503 #if __GLASGOW_HASKELL__ <= 602
504 peekCAStringLen = peekCStringLen
505 #endif
506 \end{code}