2 % (c) The University of Glasgow, 1997-2006
5 {-# LANGUAGE BangPatterns #-}
6 {-# OPTIONS -fno-warn-unused-imports #-}
7 -- XXX GHC 6.9 seems to be confused by unpackCString# being used only in
10 {-# OPTIONS_GHC -O -funbox-strict-fields #-}
11 -- We always optimise this, otherwise performance of a non-optimised
12 -- compiler is severely affected
15 -- There are two principal string types used internally by GHC:
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'.
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'
30 -- Use 'LitString' unless you want the facilities of 'FastString'.
34 FastString(..), -- not abstract, for now.
41 mkFastStringForeignPtr,
42 #if defined(__GLASGOW_HASKELL__)
49 unpackFS, -- :: FastString -> String
50 bytesFS, -- :: FastString -> [Word8]
79 #if defined(__GLASGOW_HASKELL__)
91 #include "HsVersions.h"
99 import Foreign hiding ( unsafePerformIO )
103 import System.IO.Unsafe ( unsafePerformIO )
105 import Data.IORef ( IORef, newIORef, readIORef, writeIORef )
106 import Data.Maybe ( isJust )
107 import Data.Char ( ord )
109 #if __GLASGOW_HASKELL__ >= 611
110 import GHC.IO ( IO(..) )
112 import GHC.IOBase ( IO(..) )
115 import GHC.Ptr ( Ptr(..) )
116 #if defined(__GLASGOW_HASKELL__)
117 import GHC.Base ( unpackCString# )
120 #define hASH_TBL_SIZE 4091
121 #define hASH_TBL_SIZE_UNBOXED 4091#
125 A 'FastString' is an array of bytes, hashed to support fast O(1)
126 comparison. It is also associated with a character encoding, so that
127 we know how to convert a 'FastString' to the local encoding, or to the
128 Z-encoding used by the compiler internally.
130 'FastString's support a memoized conversion to the Z-encoding via zEncodeFS.
133 data FastString = FastString {
134 uniq :: {-# UNPACK #-} !Int, -- unique id
135 n_bytes :: {-# UNPACK #-} !Int, -- number of bytes
136 n_chars :: {-# UNPACK #-} !Int, -- number of chars
137 buf :: {-# UNPACK #-} !(ForeignPtr Word8),
142 -- including strings that don't need any encoding
144 -- A UTF-8 string with a memoized Z-encoding
145 | UTF8Encoded {-# UNPACK #-} !(IORef (Maybe FastString))
147 instance Eq FastString where
148 f1 == f2 = uniq f1 == uniq f2
150 instance Ord FastString where
151 -- Compares lexicographically, not by unique
152 a <= b = case cmpFS a b of { LT -> True; EQ -> True; GT -> False }
153 a < b = case cmpFS a b of { LT -> True; EQ -> False; GT -> False }
154 a >= b = case cmpFS a b of { LT -> False; EQ -> True; GT -> True }
155 a > b = case cmpFS a b of { LT -> False; EQ -> False; GT -> True }
160 compare a b = cmpFS a b
162 instance Show FastString where
163 show fs = show (unpackFS fs)
165 instance Data FastString where
167 toConstr _ = abstractConstr "FastString"
168 gunfold _ _ = error "gunfold"
169 dataTypeOf _ = mkNoRepType "FastString"
171 cmpFS :: FastString -> FastString -> Ordering
172 cmpFS (FastString u1 l1 _ buf1 _) (FastString u2 l2 _ buf2 _) =
173 if u1 == u2 then EQ else
174 case unsafeMemcmp buf1 buf2 (min l1 l2) `compare` 0 of
179 unsafeMemcmp :: ForeignPtr a -> ForeignPtr b -> Int -> Int
180 unsafeMemcmp buf1 buf2 l =
182 withForeignPtr buf1 $ \p1 ->
183 withForeignPtr buf2 $ \p2 ->
187 foreign import ccall unsafe "ghc_memcmp"
188 memcmp :: Ptr a -> Ptr b -> Int -> IO Int
191 -- -----------------------------------------------------------------------------
195 Internally, the compiler will maintain a fast string symbol
196 table, providing sharing and fast comparison. Creation of
197 new @FastString@s then covertly does a lookup, re-using the
198 @FastString@ if there was a hit.
201 data FastStringTable =
204 (MutableArray# RealWorld [FastString])
206 {-# NOINLINE string_table #-}
207 string_table :: IORef FastStringTable
210 tab <- IO $ \s1# -> case newArray# hASH_TBL_SIZE_UNBOXED [] s1# of
212 (# s2#, FastStringTable 0 arr# #)
215 lookupTbl :: FastStringTable -> Int -> IO [FastString]
216 lookupTbl (FastStringTable _ arr#) (I# i#) =
217 IO $ \ s# -> readArray# arr# i# s#
219 updTbl :: IORef FastStringTable -> FastStringTable -> Int -> [FastString] -> IO ()
220 updTbl fs_table_var (FastStringTable uid arr#) (I# i#) ls = do
221 (IO $ \ s# -> case writeArray# arr# i# ls s# of { s2# -> (# s2#, () #) })
222 writeIORef fs_table_var (FastStringTable (uid+1) arr#)
224 mkFastString# :: Addr# -> FastString
225 mkFastString# a# = mkFastStringBytes ptr (ptrStrLength ptr)
228 mkFastStringBytes :: Ptr Word8 -> Int -> FastString
229 mkFastStringBytes ptr len = unsafePerformIO $ do
230 ft@(FastStringTable uid _) <- readIORef string_table
234 fs <- copyNewFastString uid ptr len
235 updTbl string_table ft h (fs:ls)
236 {- _trace ("new: " ++ show f_str) $ -}
239 lookup_result <- lookupTbl ft h
240 case lookup_result of
243 b <- bucket_match ls len ptr
246 Just v -> {- _trace ("re-use: "++show v) $ -} return v
248 mkZFastStringBytes :: Ptr Word8 -> Int -> FastString
249 mkZFastStringBytes ptr len = unsafePerformIO $ do
250 ft@(FastStringTable uid _) <- readIORef string_table
254 fs <- copyNewZFastString uid ptr len
255 updTbl string_table ft h (fs:ls)
256 {- _trace ("new: " ++ show f_str) $ -}
259 lookup_result <- lookupTbl ft h
260 case lookup_result of
263 b <- bucket_match ls len ptr
266 Just v -> {- _trace ("re-use: "++show v) $ -} return v
268 -- | Create a 'FastString' from an existing 'ForeignPtr'; the difference
269 -- between this and 'mkFastStringBytes' is that we don't have to copy
270 -- the bytes if the string is new to the table.
271 mkFastStringForeignPtr :: Ptr Word8 -> ForeignPtr Word8 -> Int -> IO FastString
272 mkFastStringForeignPtr ptr fp len = do
273 ft@(FastStringTable uid _) <- readIORef string_table
274 -- _trace ("hashed: "++show (I# h)) $
278 fs <- mkNewFastString uid ptr fp len
279 updTbl string_table ft h (fs:ls)
280 {- _trace ("new: " ++ show f_str) $ -}
283 lookup_result <- lookupTbl ft h
284 case lookup_result of
287 b <- bucket_match ls len ptr
290 Just v -> {- _trace ("re-use: "++show v) $ -} return v
292 mkZFastStringForeignPtr :: Ptr Word8 -> ForeignPtr Word8 -> Int -> IO FastString
293 mkZFastStringForeignPtr ptr fp len = do
294 ft@(FastStringTable uid _) <- readIORef string_table
295 -- _trace ("hashed: "++show (I# h)) $
299 fs <- mkNewZFastString uid ptr fp len
300 updTbl string_table ft h (fs:ls)
301 {- _trace ("new: " ++ show f_str) $ -}
304 lookup_result <- lookupTbl ft h
305 case lookup_result of
308 b <- bucket_match ls len ptr
311 Just v -> {- _trace ("re-use: "++show v) $ -} return v
314 -- | Creates a UTF-8 encoded 'FastString' from a 'String'
315 mkFastString :: String -> FastString
318 let l = utf8EncodedLength str
319 buf <- mallocForeignPtrBytes l
320 withForeignPtr buf $ \ptr -> do
321 utf8EncodeString ptr str
322 mkFastStringForeignPtr ptr buf l
324 -- | Creates a 'FastString' from a UTF-8 encoded @[Word8]@
325 mkFastStringByteList :: [Word8] -> FastString
326 mkFastStringByteList str =
328 let l = Prelude.length str
329 buf <- mallocForeignPtrBytes l
330 withForeignPtr buf $ \ptr -> do
331 pokeArray (castPtr ptr) str
332 mkFastStringForeignPtr ptr buf l
334 -- | Creates a Z-encoded 'FastString' from a 'String'
335 mkZFastString :: String -> FastString
338 let l = Prelude.length str
339 buf <- mallocForeignPtrBytes l
340 withForeignPtr buf $ \ptr -> do
341 pokeCAString (castPtr ptr) str
342 mkZFastStringForeignPtr ptr buf l
344 bucket_match :: [FastString] -> Int -> Ptr Word8 -> IO (Maybe FastString)
345 bucket_match [] _ _ = return Nothing
346 bucket_match (v@(FastString _ l _ buf _):ls) len ptr
348 b <- cmpStringPrefix ptr buf len
349 if b then return (Just v)
350 else bucket_match ls len ptr
352 bucket_match ls len ptr
354 mkNewFastString :: Int -> Ptr Word8 -> ForeignPtr Word8 -> Int
356 mkNewFastString uid ptr fp len = do
357 ref <- newIORef Nothing
358 n_chars <- countUTF8Chars ptr len
359 return (FastString uid len n_chars fp (UTF8Encoded ref))
361 mkNewZFastString :: Int -> Ptr Word8 -> ForeignPtr Word8 -> Int
363 mkNewZFastString uid _ fp len = do
364 return (FastString uid len len fp ZEncoded)
366 copyNewFastString :: Int -> Ptr Word8 -> Int -> IO FastString
367 copyNewFastString uid ptr len = do
368 fp <- copyBytesToForeignPtr ptr len
369 ref <- newIORef Nothing
370 n_chars <- countUTF8Chars ptr len
371 return (FastString uid len n_chars fp (UTF8Encoded ref))
373 copyNewZFastString :: Int -> Ptr Word8 -> Int -> IO FastString
374 copyNewZFastString uid ptr len = do
375 fp <- copyBytesToForeignPtr ptr len
376 return (FastString uid len len fp ZEncoded)
378 copyBytesToForeignPtr :: Ptr Word8 -> Int -> IO (ForeignPtr Word8)
379 copyBytesToForeignPtr ptr len = do
380 fp <- mallocForeignPtrBytes len
381 withForeignPtr fp $ \ptr' -> copyBytes ptr' ptr len
384 cmpStringPrefix :: Ptr Word8 -> ForeignPtr Word8 -> Int -> IO Bool
385 cmpStringPrefix ptr fp len =
386 withForeignPtr fp $ \ptr' -> do
387 r <- memcmp ptr ptr' len
391 hashStr :: Ptr Word8 -> Int -> Int
392 -- use the Addr to produce a hash value between 0 & m (inclusive)
393 hashStr (Ptr a#) (I# len#) = loop 0# 0#
395 loop h n | n GHC.Exts.==# len# = I# h
396 | otherwise = loop h2 (n GHC.Exts.+# 1#)
397 where !c = ord# (indexCharOffAddr# a# n)
398 !h2 = (c GHC.Exts.+# (h GHC.Exts.*# 128#)) `remInt#`
401 -- -----------------------------------------------------------------------------
404 -- | Returns the length of the 'FastString' in characters
405 lengthFS :: FastString -> Int
406 lengthFS f = n_chars f
408 -- | Returns @True@ if the 'FastString' is Z-encoded
409 isZEncoded :: FastString -> Bool
410 isZEncoded fs | ZEncoded <- enc fs = True
413 -- | Returns @True@ if this 'FastString' is not Z-encoded but already has
414 -- a Z-encoding cached (used in producing stats).
415 hasZEncoding :: FastString -> Bool
416 hasZEncoding (FastString _ _ _ _ enc) =
424 -- | Returns @True@ if the 'FastString' is empty
425 nullFS :: FastString -> Bool
426 nullFS f = n_bytes f == 0
428 -- | Unpacks and decodes the FastString
429 unpackFS :: FastString -> String
430 unpackFS (FastString _ n_bytes _ buf enc) =
431 inlinePerformIO $ withForeignPtr buf $ \ptr ->
433 ZEncoded -> peekCAStringLen (castPtr ptr,n_bytes)
434 UTF8Encoded _ -> utf8DecodeString ptr n_bytes
436 bytesFS :: FastString -> [Word8]
437 bytesFS (FastString _ n_bytes _ buf _) =
438 inlinePerformIO $ withForeignPtr buf $ \ptr ->
439 peekArray n_bytes ptr
441 -- | Returns a Z-encoded version of a 'FastString'. This might be the
442 -- original, if it was already Z-encoded. The first time this
443 -- function is applied to a particular 'FastString', the results are
446 zEncodeFS :: FastString -> FastString
447 zEncodeFS fs@(FastString _ _ _ _ enc) =
456 let efs = mkZFastString (zEncodeString (unpackFS fs))
457 writeIORef ref (Just efs)
460 appendFS :: FastString -> FastString -> FastString
463 r <- mallocForeignPtrBytes len
464 withForeignPtr r $ \ r' -> do
465 withForeignPtr (buf fs1) $ \ fs1Ptr -> do
466 withForeignPtr (buf fs2) $ \ fs2Ptr -> do
467 copyBytes r' fs1Ptr len1
468 copyBytes (advancePtr r' len1) fs2Ptr len2
469 mkFastStringForeignPtr r' r len
470 where len = len1 + len2
474 concatFS :: [FastString] -> FastString
475 concatFS ls = mkFastString (Prelude.concat (map unpackFS ls)) -- ToDo: do better
477 headFS :: FastString -> Char
478 headFS (FastString _ 0 _ _ _) = panic "headFS: Empty FastString"
479 headFS (FastString _ _ _ buf enc) =
480 inlinePerformIO $ withForeignPtr buf $ \ptr -> do
483 w <- peek (castPtr ptr)
484 return (castCCharToChar w)
486 return (fst (utf8DecodeChar ptr))
488 tailFS :: FastString -> FastString
489 tailFS (FastString _ 0 _ _ _) = panic "tailFS: Empty FastString"
490 tailFS (FastString _ n_bytes _ buf enc) =
491 inlinePerformIO $ withForeignPtr buf $ \ptr -> do
494 return $! mkZFastStringBytes (ptr `plusPtr` 1) (n_bytes - 1)
496 let (_,ptr') = utf8DecodeChar ptr
497 let off = ptr' `minusPtr` ptr
498 return $! mkFastStringBytes (ptr `plusPtr` off) (n_bytes - off)
500 consFS :: Char -> FastString -> FastString
501 consFS c fs = mkFastString (c : unpackFS fs)
503 uniqueOfFS :: FastString -> FastInt
504 uniqueOfFS (FastString u _ _ _ _) = iUnbox u
507 nilFS = mkFastString ""
509 -- -----------------------------------------------------------------------------
512 getFastStringTable :: IO [[FastString]]
513 getFastStringTable = do
514 tbl <- readIORef string_table
515 buckets <- mapM (lookupTbl tbl) [0 .. hASH_TBL_SIZE]
518 -- -----------------------------------------------------------------------------
519 -- Outputting 'FastString's
521 -- |Outputs a 'FastString' with /no decoding at all/, that is, you
522 -- get the actual bytes in the 'FastString' written to the 'Handle'.
523 hPutFS :: Handle -> FastString -> IO ()
524 hPutFS handle (FastString _ len _ fp _)
525 | len == 0 = return ()
526 | otherwise = do withForeignPtr fp $ \ptr -> hPutBuf handle ptr len
528 -- ToDo: we'll probably want an hPutFSLocal, or something, to output
529 -- in the current locale's encoding (for error messages and suchlike).
531 -- -----------------------------------------------------------------------------
532 -- LitStrings, here for convenience only.
534 -- hmm, not unboxed (or rather FastPtr), interesting
535 --a.k.a. Ptr CChar, Ptr Word8, Ptr (), hmph. We don't
536 --really care about C types in naming, where we can help it.
537 type LitString = Ptr Word8
538 --Why do we recalculate length every time it's requested?
539 --If it's commonly needed, we should perhaps have
540 --data LitString = LitString {-#UNPACK#-}!(FastPtr Word8) {-#UNPACK#-}!FastInt
542 #if defined(__GLASGOW_HASKELL__)
543 mkLitString# :: Addr# -> LitString
544 mkLitString# a# = Ptr a#
546 --can/should we use FastTypes here?
547 --Is this likely to be memory-preserving if only used on constant strings?
548 --should we inline it? If lucky, that would make a CAF that wouldn't
549 --be computationally repeated... although admittedly we're not
550 --really intending to use mkLitString when __GLASGOW_HASKELL__...
551 --(I wonder, is unicode / multi-byte characters allowed in LitStrings
553 {-# INLINE mkLitString #-}
554 mkLitString :: String -> LitString
557 p <- mallocBytes (length s + 1)
559 loop :: Int -> String -> IO ()
560 loop n cs | n `seq` null cs = pokeByteOff p n (0 :: Word8)
562 pokeByteOff p n (fromIntegral (ord c) :: Word8)
564 -- XXX GHC isn't smart enough to know that we have already covered
566 loop _ [] = panic "mkLitString"
571 unpackLitString :: LitString -> String
572 unpackLitString p_ = case pUnbox p_ of
573 p -> unpack (_ILIT(0))
575 unpack n = case indexWord8OffFastPtrAsFastChar p n of
576 ch -> if ch `eqFastChar` _CLIT('\0')
577 then [] else cBox ch : unpack (n +# _ILIT(1))
579 lengthLS :: LitString -> Int
580 lengthLS = ptrStrLength
582 -- for now, use a simple String representation
583 --no, let's not do that right now - it's work in other places
585 type LitString = String
587 mkLitString :: String -> LitString
590 unpackLitString :: LitString -> String
593 lengthLS :: LitString -> Int
598 -- -----------------------------------------------------------------------------
601 foreign import ccall unsafe "ghc_strlen"
602 ptrStrLength :: Ptr Word8 -> Int
604 -- NB. does *not* add a '\0'-terminator.
605 -- We only use CChar here to be parallel to the imported
606 -- peekC(A)StringLen.
607 pokeCAString :: Ptr CChar -> String -> IO ()
608 pokeCAString ptr str =
611 go (c:cs) n = do pokeElemOff ptr n (castCharToCChar c); go cs (n+1)
615 {-# NOINLINE sLit #-}
616 sLit :: String -> LitString
617 sLit x = mkLitString x
619 {-# NOINLINE fsLit #-}
620 fsLit :: String -> FastString
621 fsLit x = mkFastString x
624 forall x . sLit (unpackCString# x) = mkLitString# x #-}
626 forall x . fsLit (unpackCString# x) = mkFastString# x #-}