X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Futils%2FFastString.lhs;h=c6dac8ff428d083c2a38a73ec28bd0dd30862993;hp=ca7c2c71af80f0a4d8ca05094762de99262fbca6;hb=edc0bafd3fcd01b85a2e8894e5dfe149eb0e0857;hpb=7fc749a43b4b6b85d234fa95d4928648259584f4 diff --git a/compiler/utils/FastString.lhs b/compiler/utils/FastString.lhs index ca7c2c7..c6dac8f 100644 --- a/compiler/utils/FastString.lhs +++ b/compiler/utils/FastString.lhs @@ -2,92 +2,116 @@ % (c) The University of Glasgow, 1997-2006 % \begin{code} -{-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details +{-# LANGUAGE BangPatterns #-} +{-# OPTIONS -fno-warn-unused-imports #-} +-- XXX GHC 6.9 seems to be confused by unpackCString# being used only in +-- a RULE -{- -FastString: A compact, hash-consed, representation of character strings. - Comparison is O(1), and you can get a Unique from them. - Generated by the FSLIT macro - Turn into SDoc with Outputable.ftext - -LitString: Just a wrapper for the Addr# of a C string (Ptr CChar). - Practically no operations - Outputing them is fast - Generated by the SLIT macro - Turn into SDoc with Outputable.ptext - -Use LitString unless you want the facilities of FastString --} +{-# OPTIONS_GHC -O -funbox-strict-fields #-} +-- We always optimise this, otherwise performance of a non-optimised +-- compiler is severely affected + +-- | +-- There are two principal string types used internally by GHC: +-- +-- 'FastString': +-- * A compact, hash-consed, representation of character strings. +-- * Comparison is O(1), and you can get a 'Unique.Unique' from them. +-- * Generated by 'fsLit'. +-- * Turn into 'Outputable.SDoc' with 'Outputable.ftext'. +-- +-- 'LitString': +-- * Just a wrapper for the @Addr#@ of a C string (@Ptr CChar@). +-- * Practically no operations. +-- * Outputing them is fast. +-- * Generated by 'sLit'. +-- * Turn into 'Outputable.SDoc' with 'Outputable.ptext' +-- +-- Use 'LitString' unless you want the facilities of 'FastString'. module FastString ( - -- * FastStrings - FastString(..), -- not abstract, for now. + -- * FastStrings + FastString(..), -- not abstract, for now. - -- ** Construction + -- ** Construction + fsLit, mkFastString, - mkFastStringBytes, + mkFastStringBytes, mkFastStringByteList, - mkFastStringForeignPtr, - mkFastString#, - mkZFastString, - mkZFastStringBytes, + mkFastStringForeignPtr, +#if defined(__GLASGOW_HASKELL__) + mkFastString#, +#endif + mkZFastString, + mkZFastStringBytes, - -- ** Deconstruction - unpackFS, -- :: FastString -> String - bytesFS, -- :: FastString -> [Word8] + -- ** Deconstruction + unpackFS, -- :: FastString -> String + bytesFS, -- :: FastString -> [Word8] - -- ** Encoding - isZEncoded, - zEncodeFS, + -- ** Encoding + isZEncoded, + zEncodeFS, - -- ** Operations + -- ** Operations uniqueOfFS, - lengthFS, - nullFS, - appendFS, + lengthFS, + nullFS, + appendFS, headFS, tailFS, - concatFS, + concatFS, consFS, - nilFS, + nilFS, - -- ** Outputing + -- ** Outputing hPutFS, - -- ** Internal - getFastStringTable, - hasZEncoding, - - -- * LitStrings - LitString, - mkLitString#, - strLength + -- ** Internal + getFastStringTable, + hasZEncoding, + + -- * LitStrings + LitString, + + -- ** Construction + sLit, +#if defined(__GLASGOW_HASKELL__) + mkLitString#, +#endif + mkLitString, + + -- ** Deconstruction + unpackLitString, + + -- ** Operations + lengthLS ) where --- This #define suppresses the "import FastString" that --- HsVersions otherwise produces -#define COMPILING_FAST_STRING #include "HsVersions.h" import Encoding +import FastTypes +import FastFunctions +import Panic +import Util -import Foreign +import Foreign hiding ( unsafePerformIO ) import Foreign.C import GHC.Exts +import System.IO import System.IO.Unsafe ( unsafePerformIO ) -import Control.Monad.ST ( stToIO ) -import Data.IORef ( IORef, newIORef, readIORef, writeIORef ) -import System.IO ( hPutBuf ) -import Data.Maybe ( isJust ) +import Data.Data +import Data.IORef ( IORef, newIORef, readIORef, writeIORef ) +import Data.Maybe ( isJust ) +import Data.Char ( ord ) -import GHC.ST -import GHC.IOBase ( IO(..) ) -import GHC.Ptr ( Ptr(..) ) +import GHC.IO ( IO(..) ) + +import GHC.Ptr ( Ptr(..) ) +#if defined(__GLASGOW_HASKELL__) +import GHC.Base ( unpackCString# ) +#endif #define hASH_TBL_SIZE 4091 #define hASH_TBL_SIZE_UNBOXED 4091# @@ -103,37 +127,43 @@ Z-encoding used by the compiler internally. -} data FastString = FastString { - uniq :: {-# UNPACK #-} !Int, -- unique id - n_bytes :: {-# UNPACK #-} !Int, -- number of bytes - n_chars :: {-# UNPACK #-} !Int, -- number of chars + uniq :: {-# UNPACK #-} !Int, -- unique id + n_bytes :: {-# UNPACK #-} !Int, -- number of bytes + n_chars :: {-# UNPACK #-} !Int, -- number of chars buf :: {-# UNPACK #-} !(ForeignPtr Word8), enc :: FSEncoding - } + } deriving Typeable data FSEncoding + -- including strings that don't need any encoding = ZEncoded - -- including strings that don't need any encoding + -- A UTF-8 string with a memoized Z-encoding | UTF8Encoded {-# UNPACK #-} !(IORef (Maybe FastString)) - -- A UTF-8 string with a memoized Z-encoding instance Eq FastString where f1 == f2 = uniq f1 == uniq f2 instance Ord FastString where - -- Compares lexicographically, not by unique + -- Compares lexicographically, not by unique a <= b = case cmpFS a b of { LT -> True; EQ -> True; GT -> False } - a < b = case cmpFS a b of { LT -> True; EQ -> False; GT -> False } + a < b = case cmpFS a b of { LT -> True; EQ -> False; GT -> False } a >= b = case cmpFS a b of { LT -> False; EQ -> True; GT -> True } - a > b = case cmpFS a b of { LT -> False; EQ -> False; GT -> True } - max x y | x >= y = x - | otherwise = y - min x y | x <= y = x - | otherwise = y + a > b = case cmpFS a b of { LT -> False; EQ -> False; GT -> True } + max x y | x >= y = x + | otherwise = y + min x y | x <= y = x + | otherwise = y compare a b = cmpFS a b instance Show FastString where show fs = show (unpackFS fs) +instance Data FastString where + -- don't traverse? + toConstr _ = abstractConstr "FastString" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "FastString" + cmpFS :: FastString -> FastString -> Ordering cmpFS (FastString u1 l1 _ buf1 _) (FastString u2 l2 _ buf2 _) = if u1 == u2 then EQ else @@ -150,7 +180,7 @@ unsafeMemcmp buf1 buf2 l = memcmp p1 p2 l #ifndef __HADDOCK__ -foreign import ccall unsafe "ghc_memcmp" +foreign import ccall unsafe "ghc_memcmp" memcmp :: Ptr a -> Ptr b -> Int -> IO Int #endif @@ -164,14 +194,14 @@ new @FastString@s then covertly does a lookup, re-using the @FastString@ if there was a hit. -} -data FastStringTable = +data FastStringTable = FastStringTable {-# UNPACK #-} !Int (MutableArray# RealWorld [FastString]) {-# NOINLINE string_table #-} string_table :: IORef FastStringTable -string_table = +string_table = unsafePerformIO $ do tab <- IO $ \s1# -> case newArray# hASH_TBL_SIZE_UNBOXED [] s1# of (# s2#, arr# #) -> @@ -188,19 +218,19 @@ updTbl fs_table_var (FastStringTable uid arr#) (I# i#) ls = do writeIORef fs_table_var (FastStringTable (uid+1) arr#) mkFastString# :: Addr# -> FastString -mkFastString# a# = mkFastStringBytes ptr (strLength ptr) +mkFastString# a# = mkFastStringBytes ptr (ptrStrLength ptr) where ptr = Ptr a# mkFastStringBytes :: Ptr Word8 -> Int -> FastString mkFastStringBytes ptr len = unsafePerformIO $ do - ft@(FastStringTable uid tbl#) <- readIORef string_table + ft@(FastStringTable uid _) <- readIORef string_table let h = hashStr ptr len add_it ls = do - fs <- copyNewFastString uid ptr len - updTbl string_table ft h (fs:ls) - {- _trace ("new: " ++ show f_str) $ -} - return fs + fs <- copyNewFastString uid ptr len + updTbl string_table ft h (fs:ls) + {- _trace ("new: " ++ show f_str) $ -} + return fs -- lookup_result <- lookupTbl ft h case lookup_result of @@ -208,19 +238,19 @@ mkFastStringBytes ptr len = unsafePerformIO $ do ls -> do b <- bucket_match ls len ptr case b of - Nothing -> add_it ls - Just v -> {- _trace ("re-use: "++show v) $ -} return v + Nothing -> add_it ls + Just v -> {- _trace ("re-use: "++show v) $ -} return v mkZFastStringBytes :: Ptr Word8 -> Int -> FastString mkZFastStringBytes ptr len = unsafePerformIO $ do - ft@(FastStringTable uid tbl#) <- readIORef string_table + ft@(FastStringTable uid _) <- readIORef string_table let h = hashStr ptr len add_it ls = do - fs <- copyNewZFastString uid ptr len - updTbl string_table ft h (fs:ls) - {- _trace ("new: " ++ show f_str) $ -} - return fs + fs <- copyNewZFastString uid ptr len + updTbl string_table ft h (fs:ls) + {- _trace ("new: " ++ show f_str) $ -} + return fs -- lookup_result <- lookupTbl ft h case lookup_result of @@ -228,23 +258,23 @@ mkZFastStringBytes ptr len = unsafePerformIO $ do ls -> do b <- bucket_match ls len ptr case b of - Nothing -> add_it ls - Just v -> {- _trace ("re-use: "++show v) $ -} return v + Nothing -> add_it ls + Just v -> {- _trace ("re-use: "++show v) $ -} return v -- | Create a 'FastString' from an existing 'ForeignPtr'; the difference -- between this and 'mkFastStringBytes' is that we don't have to copy -- the bytes if the string is new to the table. mkFastStringForeignPtr :: Ptr Word8 -> ForeignPtr Word8 -> Int -> IO FastString mkFastStringForeignPtr ptr fp len = do - ft@(FastStringTable uid tbl#) <- readIORef string_table + ft@(FastStringTable uid _) <- readIORef string_table -- _trace ("hashed: "++show (I# h)) $ let h = hashStr ptr len add_it ls = do - fs <- mkNewFastString uid ptr fp len - updTbl string_table ft h (fs:ls) - {- _trace ("new: " ++ show f_str) $ -} - return fs + fs <- mkNewFastString uid ptr fp len + updTbl string_table ft h (fs:ls) + {- _trace ("new: " ++ show f_str) $ -} + return fs -- lookup_result <- lookupTbl ft h case lookup_result of @@ -252,20 +282,20 @@ mkFastStringForeignPtr ptr fp len = do ls -> do b <- bucket_match ls len ptr case b of - Nothing -> add_it ls - Just v -> {- _trace ("re-use: "++show v) $ -} return v + Nothing -> add_it ls + Just v -> {- _trace ("re-use: "++show v) $ -} return v mkZFastStringForeignPtr :: Ptr Word8 -> ForeignPtr Word8 -> Int -> IO FastString mkZFastStringForeignPtr ptr fp len = do - ft@(FastStringTable uid tbl#) <- readIORef string_table + ft@(FastStringTable uid _) <- readIORef string_table -- _trace ("hashed: "++show (I# h)) $ let h = hashStr ptr len add_it ls = do - fs <- mkNewZFastString uid ptr fp len - updTbl string_table ft h (fs:ls) - {- _trace ("new: " ++ show f_str) $ -} - return fs + fs <- mkNewZFastString uid ptr fp len + updTbl string_table ft h (fs:ls) + {- _trace ("new: " ++ show f_str) $ -} + return fs -- lookup_result <- lookupTbl ft h case lookup_result of @@ -273,69 +303,75 @@ mkZFastStringForeignPtr ptr fp len = do ls -> do b <- bucket_match ls len ptr case b of - Nothing -> add_it ls - Just v -> {- _trace ("re-use: "++show v) $ -} return v + Nothing -> add_it ls + Just v -> {- _trace ("re-use: "++show v) $ -} return v -- | Creates a UTF-8 encoded 'FastString' from a 'String' mkFastString :: String -> FastString -mkFastString str = +mkFastString str = inlinePerformIO $ do let l = utf8EncodedLength str buf <- mallocForeignPtrBytes l withForeignPtr buf $ \ptr -> do utf8EncodeString ptr str - mkFastStringForeignPtr ptr buf l + mkFastStringForeignPtr ptr buf l -- | Creates a 'FastString' from a UTF-8 encoded @[Word8]@ mkFastStringByteList :: [Word8] -> FastString -mkFastStringByteList str = +mkFastStringByteList str = inlinePerformIO $ do let l = Prelude.length str buf <- mallocForeignPtrBytes l withForeignPtr buf $ \ptr -> do pokeArray (castPtr ptr) str - mkFastStringForeignPtr ptr buf l + mkFastStringForeignPtr ptr buf l -- | Creates a Z-encoded 'FastString' from a 'String' mkZFastString :: String -> FastString -mkZFastString str = +mkZFastString str = inlinePerformIO $ do let l = Prelude.length str buf <- mallocForeignPtrBytes l withForeignPtr buf $ \ptr -> do pokeCAString (castPtr ptr) str - mkZFastStringForeignPtr ptr buf l + mkZFastStringForeignPtr ptr buf l +bucket_match :: [FastString] -> Int -> Ptr Word8 -> IO (Maybe FastString) bucket_match [] _ _ = return Nothing bucket_match (v@(FastString _ l _ buf _):ls) len ptr | len == l = do - b <- cmpStringPrefix ptr buf len - if b then return (Just v) - else bucket_match ls len ptr - | otherwise = - bucket_match ls len ptr - + b <- cmpStringPrefix ptr buf len + if b then return (Just v) + else bucket_match ls len ptr + | otherwise = + bucket_match ls len ptr + +mkNewFastString :: Int -> Ptr Word8 -> ForeignPtr Word8 -> Int + -> IO FastString mkNewFastString uid ptr fp len = do ref <- newIORef Nothing n_chars <- countUTF8Chars ptr len return (FastString uid len n_chars fp (UTF8Encoded ref)) -mkNewZFastString uid ptr fp len = do +mkNewZFastString :: Int -> Ptr Word8 -> ForeignPtr Word8 -> Int + -> IO FastString +mkNewZFastString uid _ fp len = do return (FastString uid len len fp ZEncoded) - +copyNewFastString :: Int -> Ptr Word8 -> Int -> IO FastString copyNewFastString uid ptr len = do fp <- copyBytesToForeignPtr ptr len ref <- newIORef Nothing n_chars <- countUTF8Chars ptr len return (FastString uid len n_chars fp (UTF8Encoded ref)) +copyNewZFastString :: Int -> Ptr Word8 -> Int -> IO FastString copyNewZFastString uid ptr len = do fp <- copyBytesToForeignPtr ptr len return (FastString uid len len fp ZEncoded) - +copyBytesToForeignPtr :: Ptr Word8 -> Int -> IO (ForeignPtr Word8) copyBytesToForeignPtr ptr len = do fp <- mallocForeignPtrBytes len withForeignPtr fp $ \ptr' -> copyBytes ptr' ptr len @@ -351,11 +387,12 @@ cmpStringPrefix ptr fp len = hashStr :: Ptr Word8 -> Int -> Int -- use the Addr to produce a hash value between 0 & m (inclusive) hashStr (Ptr a#) (I# len#) = loop 0# 0# - where - loop h n | n ==# len# = I# h - | otherwise = loop h2 (n +# 1#) - where c = ord# (indexCharOffAddr# a# n) - h2 = (c +# (h *# 128#)) `remInt#` hASH_TBL_SIZE# + where + loop h n | n GHC.Exts.==# len# = I# h + | otherwise = loop h2 (n GHC.Exts.+# 1#) + where !c = ord# (indexCharOffAddr# a# n) + !h2 = (c GHC.Exts.+# (h GHC.Exts.*# 128#)) `remInt#` + hASH_TBL_SIZE# -- ----------------------------------------------------------------------------- -- Operations @@ -364,91 +401,105 @@ hashStr (Ptr a#) (I# len#) = loop 0# 0# lengthFS :: FastString -> Int lengthFS f = n_chars f --- | Returns 'True' if the 'FastString' is Z-encoded +-- | Returns @True@ if the 'FastString' is Z-encoded isZEncoded :: FastString -> Bool isZEncoded fs | ZEncoded <- enc fs = True - | otherwise = False + | otherwise = False --- | Returns 'True' if this 'FastString' is not Z-encoded but already has +-- | Returns @True@ if this 'FastString' is not Z-encoded but already has -- a Z-encoding cached (used in producing stats). hasZEncoding :: FastString -> Bool -hasZEncoding fs@(FastString uid n_bytes _ fp enc) = +hasZEncoding (FastString _ _ _ _ enc) = case enc of ZEncoded -> False UTF8Encoded ref -> inlinePerformIO $ do m <- readIORef ref - return (isJust m) + return (isJust m) --- | Returns 'True' if the 'FastString' is empty +-- | Returns @True@ if the 'FastString' is empty nullFS :: FastString -> Bool nullFS f = n_bytes f == 0 --- | unpacks and decodes the FastString +-- | Unpacks and decodes the FastString unpackFS :: FastString -> String -unpackFS (FastString _ n_bytes _ buf enc) = +unpackFS (FastString _ n_bytes _ buf enc) = inlinePerformIO $ withForeignPtr buf $ \ptr -> case enc of - ZEncoded -> peekCAStringLen (castPtr ptr,n_bytes) - UTF8Encoded _ -> utf8DecodeString ptr n_bytes + ZEncoded -> peekCAStringLen (castPtr ptr,n_bytes) + UTF8Encoded _ -> utf8DecodeString ptr n_bytes bytesFS :: FastString -> [Word8] -bytesFS (FastString _ n_bytes _ buf enc) = +bytesFS (FastString _ n_bytes _ buf _) = inlinePerformIO $ withForeignPtr buf $ \ptr -> peekArray n_bytes ptr --- | returns a Z-encoded version of a 'FastString'. This might be the +-- | Returns a Z-encoded version of a 'FastString'. This might be the -- original, if it was already Z-encoded. The first time this -- function is applied to a particular 'FastString', the results are -- memoized. -- zEncodeFS :: FastString -> FastString -zEncodeFS fs@(FastString uid n_bytes _ fp enc) = +zEncodeFS fs@(FastString _ _ _ _ enc) = case enc of ZEncoded -> fs UTF8Encoded ref -> inlinePerformIO $ do m <- readIORef ref case m of - Just fs -> return fs - Nothing -> do + Just fs -> return fs + Nothing -> do let efs = mkZFastString (zEncodeString (unpackFS fs)) - writeIORef ref (Just efs) - return efs + writeIORef ref (Just efs) + return efs appendFS :: FastString -> FastString -> FastString -appendFS fs1 fs2 = mkFastString (unpackFS fs1 ++ unpackFS fs2) +appendFS fs1 fs2 = + inlinePerformIO $ do + r <- mallocForeignPtrBytes len + withForeignPtr r $ \ r' -> do + withForeignPtr (buf fs1) $ \ fs1Ptr -> do + withForeignPtr (buf fs2) $ \ fs2Ptr -> do + copyBytes r' fs1Ptr len1 + copyBytes (advancePtr r' len1) fs2Ptr len2 + mkFastStringForeignPtr r' r len + where len = len1 + len2 + len1 = lengthFS fs1 + len2 = lengthFS fs2 concatFS :: [FastString] -> FastString concatFS ls = mkFastString (Prelude.concat (map unpackFS ls)) -- ToDo: do better headFS :: FastString -> Char -headFS (FastString _ n_bytes _ buf enc) = +headFS (FastString _ 0 _ _ _) = panic "headFS: Empty FastString" +headFS (FastString _ _ _ buf enc) = inlinePerformIO $ withForeignPtr buf $ \ptr -> do case enc of - ZEncoded -> do - w <- peek (castPtr ptr) - return (castCCharToChar w) - UTF8Encoded _ -> - return (fst (utf8DecodeChar ptr)) + ZEncoded -> do + w <- peek (castPtr ptr) + return (castCCharToChar w) + UTF8Encoded _ -> + return (fst (utf8DecodeChar ptr)) tailFS :: FastString -> FastString -tailFS (FastString _ n_bytes _ buf enc) = +tailFS (FastString _ 0 _ _ _) = panic "tailFS: Empty FastString" +tailFS (FastString _ n_bytes _ buf enc) = inlinePerformIO $ withForeignPtr buf $ \ptr -> do case enc of ZEncoded -> do - return $! mkZFastStringBytes (ptr `plusPtr` 1) (n_bytes - 1) + return $! mkZFastStringBytes (ptr `plusPtr` 1) (n_bytes - 1) UTF8Encoded _ -> do - let (_,ptr') = utf8DecodeChar ptr - let off = ptr' `minusPtr` ptr - return $! mkFastStringBytes (ptr `plusPtr` off) (n_bytes - off) + let (_,ptr') = utf8DecodeChar ptr + let off = ptr' `minusPtr` ptr + return $! mkFastStringBytes (ptr `plusPtr` off) (n_bytes - off) consFS :: Char -> FastString -> FastString consFS c fs = mkFastString (c : unpackFS fs) -uniqueOfFS :: FastString -> Int# -uniqueOfFS (FastString (I# u#) _ _ _ _) = u# +uniqueOfFS :: FastString -> FastInt +uniqueOfFS (FastString u _ _ _ _) = iUnbox u +nilFS :: FastString nilFS = mkFastString "" -- ----------------------------------------------------------------------------- @@ -465,6 +516,7 @@ getFastStringTable = do -- |Outputs a 'FastString' with /no decoding at all/, that is, you -- get the actual bytes in the 'FastString' written to the 'Handle'. +hPutFS :: Handle -> FastString -> IO () hPutFS handle (FastString _ len _ fp _) | len == 0 = return () | otherwise = do withForeignPtr fp $ \ptr -> hPutBuf handle ptr len @@ -475,32 +527,97 @@ hPutFS handle (FastString _ len _ fp _) -- ----------------------------------------------------------------------------- -- LitStrings, here for convenience only. -type LitString = Ptr () +-- hmm, not unboxed (or rather FastPtr), interesting +--a.k.a. Ptr CChar, Ptr Word8, Ptr (), hmph. We don't +--really care about C types in naming, where we can help it. +type LitString = Ptr Word8 +--Why do we recalculate length every time it's requested? +--If it's commonly needed, we should perhaps have +--data LitString = LitString {-#UNPACK#-}!(FastPtr Word8) {-#UNPACK#-}!FastInt +#if defined(__GLASGOW_HASKELL__) mkLitString# :: Addr# -> LitString mkLitString# a# = Ptr a# +#endif +--can/should we use FastTypes here? +--Is this likely to be memory-preserving if only used on constant strings? +--should we inline it? If lucky, that would make a CAF that wouldn't +--be computationally repeated... although admittedly we're not +--really intending to use mkLitString when __GLASGOW_HASKELL__... +--(I wonder, is unicode / multi-byte characters allowed in LitStrings +-- at all?) +{-# INLINE mkLitString #-} +mkLitString :: String -> LitString +mkLitString s = + unsafePerformIO (do + p <- mallocBytes (length s + 1) + let + loop :: Int -> String -> IO () + loop n cs | n `seq` null cs = pokeByteOff p n (0 :: Word8) + loop n (c:cs) = do + pokeByteOff p n (fromIntegral (ord c) :: Word8) + loop (1+n) cs + -- XXX GHC isn't smart enough to know that we have already covered + -- this case. + loop _ [] = panic "mkLitString" + loop 0 s + return p + ) + +unpackLitString :: LitString -> String +unpackLitString p_ = case pUnbox p_ of + p -> unpack (_ILIT(0)) + where + unpack n = case indexWord8OffFastPtrAsFastChar p n of + ch -> if ch `eqFastChar` _CLIT('\0') + then [] else cBox ch : unpack (n +# _ILIT(1)) + +lengthLS :: LitString -> Int +lengthLS = ptrStrLength + +-- for now, use a simple String representation +--no, let's not do that right now - it's work in other places +#if 0 +type LitString = String + +mkLitString :: String -> LitString +mkLitString = id + +unpackLitString :: LitString -> String +unpackLitString = id + +lengthLS :: LitString -> Int +lengthLS = length -foreign import ccall unsafe "ghc_strlen" - strLength :: Ptr () -> Int +#endif -- ----------------------------------------------------------------------------- -- under the carpet --- Just like unsafePerformIO, but we inline it. -{-# INLINE inlinePerformIO #-} -inlinePerformIO :: IO a -> a -inlinePerformIO (IO m) = case m realWorld# of (# _, r #) -> r +foreign import ccall unsafe "ghc_strlen" + ptrStrLength :: Ptr Word8 -> Int -- NB. does *not* add a '\0'-terminator. +-- We only use CChar here to be parallel to the imported +-- peekC(A)StringLen. pokeCAString :: Ptr CChar -> String -> IO () pokeCAString ptr str = let - go [] n = return () - go (c:cs) n = do pokeElemOff ptr n (castCharToCChar c); go cs (n+1) + go [] _ = return () + go (c:cs) n = do pokeElemOff ptr n (castCharToCChar c); go cs (n+1) in go str 0 -#if __GLASGOW_HASKELL__ <= 602 -peekCAStringLen = peekCStringLen -#endif +{-# NOINLINE sLit #-} +sLit :: String -> LitString +sLit x = mkLitString x + +{-# NOINLINE fsLit #-} +fsLit :: String -> FastString +fsLit x = mkFastString x + +{-# RULES "slit" + forall x . sLit (unpackCString# x) = mkLitString# x #-} +{-# RULES "fslit" + forall x . fsLit (unpackCString# x) = mkFastString# x #-} \end{code}