X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Futils%2FFastString.lhs;h=a22cae043c1f6a465dca586351789cc6462054c1;hp=26f687c40fa99b19a8b43b4baaf724242b84665d;hb=206b4dec78250efef3cd927d64dc6cbc54a16c3d;hpb=9c54ee0c9e25617b2a9ad4cdd9d3a6354e2edc0f diff --git a/compiler/utils/FastString.lhs b/compiler/utils/FastString.lhs index 26f687c..a22cae0 100644 --- a/compiler/utils/FastString.lhs +++ b/compiler/utils/FastString.lhs @@ -2,6 +2,13 @@ % (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 + {- FastString: A compact, hash-consed, representation of character strings. Comparison is O(1), and you can get a Unique from them. @@ -26,7 +33,9 @@ module FastString mkFastStringBytes, mkFastStringByteList, mkFastStringForeignPtr, +#if defined(__GLASGOW_HASKELL__) mkFastString#, +#endif mkZFastString, mkZFastStringBytes, @@ -58,8 +67,15 @@ module FastString -- * LitStrings LitString, +#if defined(__GLASGOW_HASKELL__) mkLitString#, - strLength +#else + mkLitString, +#endif + unpackLitString, + strLength, + + ptrStrLength ) where -- This #define suppresses the "import FastString" that @@ -68,6 +84,8 @@ module FastString #include "HsVersions.h" import Encoding +import FastTypes +import FastFunctions import Foreign import Foreign.C @@ -77,12 +95,14 @@ import Control.Monad.ST ( stToIO ) import Data.IORef ( IORef, newIORef, readIORef, writeIORef ) import System.IO ( hPutBuf ) import Data.Maybe ( isJust ) +import Data.Char ( ord ) -import GHC.Arr ( STArray(..), newSTArray ) +import GHC.ST import GHC.IOBase ( IO(..) ) import GHC.Ptr ( Ptr(..) ) -#define hASH_TBL_SIZE 4091 +#define hASH_TBL_SIZE 4091 +#define hASH_TBL_SIZE_UNBOXED 4091# {-| @@ -129,17 +149,17 @@ instance Show FastString where cmpFS :: FastString -> FastString -> Ordering cmpFS (FastString u1 l1 _ buf1 _) (FastString u2 l2 _ buf2 _) = if u1 == u2 then EQ else - let l = if l1 <= l2 then l1 else l2 in - inlinePerformIO $ - withForeignPtr buf1 $ \p1 -> - withForeignPtr buf2 $ \p2 -> do - res <- memcmp p1 p2 l - case () of - _ | res < 0 -> return LT - | res == 0 -> if l1 == l2 then return EQ - else if l1 < l2 then return LT - else return GT - | otherwise -> return GT + case unsafeMemcmp buf1 buf2 (min l1 l2) `compare` 0 of + LT -> LT + EQ -> compare l1 l2 + GT -> GT + +unsafeMemcmp :: ForeignPtr a -> ForeignPtr b -> Int -> Int +unsafeMemcmp buf1 buf2 l = + inlinePerformIO $ + withForeignPtr buf1 $ \p1 -> + withForeignPtr buf2 $ \p2 -> + memcmp p1 p2 l #ifndef __HADDOCK__ foreign import ccall unsafe "ghc_memcmp" @@ -161,11 +181,14 @@ data FastStringTable = {-# UNPACK #-} !Int (MutableArray# RealWorld [FastString]) +{-# NOINLINE string_table #-} string_table :: IORef FastStringTable string_table = unsafePerformIO $ do - (STArray _ _ arr#) <- stToIO (newSTArray (0::Int,hASH_TBL_SIZE) []) - newIORef (FastStringTable 0 arr#) + tab <- IO $ \s1# -> case newArray# hASH_TBL_SIZE_UNBOXED [] s1# of + (# s2#, arr# #) -> + (# s2#, FastStringTable 0 arr# #) + newIORef tab lookupTbl :: FastStringTable -> Int -> IO [FastString] lookupTbl (FastStringTable _ arr#) (I# i#) = @@ -177,7 +200,7 @@ 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 @@ -341,10 +364,10 @@ 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#) + loop h n | n GHC.Exts.==# len# = I# h + | otherwise = loop h2 (n GHC.Exts.+# 1#) where c = ord# (indexCharOffAddr# a# n) - h2 = (c +# (h *# 128#)) `remInt#` hASH_TBL_SIZE# + h2 = (c GHC.Exts.+# (h GHC.Exts.*# 128#)) `remInt#` hASH_TBL_SIZE# -- ----------------------------------------------------------------------------- -- Operations @@ -435,8 +458,8 @@ tailFS (FastString _ n_bytes _ buf enc) = 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 = mkFastString "" @@ -464,23 +487,77 @@ 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 -foreign import ccall unsafe "ghc_strlen" - strLength :: Ptr () -> Int +--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 + 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)) + +strLength :: LitString -> Int +strLength = 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 + +strLength :: LitString -> Int +strLength = length + +#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 @@ -489,21 +566,7 @@ pokeCAString ptr str = in go str 0 -#if __GLASGOW_HASKELL__ < 600 - -mallocForeignPtrBytes :: Int -> IO (ForeignPtr a) -mallocForeignPtrBytes n = do - r <- mallocBytes n - newForeignPtr r (finalizerFree r) - -foreign import ccall unsafe "stdlib.h free" - finalizerFree :: Ptr a -> IO () - +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 602 peekCAStringLen = peekCStringLen - -#elif __GLASGOW_HASKELL__ <= 602 - -peekCAStringLen = peekCStringLen - #endif \end{code}