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 Data.IORef ( IORef, newIORef, readIORef, atomicModifyIORef )
+import Data.Data
+import Data.IORef ( IORef, newIORef, readIORef, writeIORef )
import Data.Maybe ( isJust )
import Data.Char ( ord )
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
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
lookupTbl (FastStringTable _ arr#) (I# i#) =
IO $ \ s# -> readArray# arr# i# s#
-updTbl :: FastStringTable -> Int -> [FastString] -> IO FastStringTable
-updTbl (FastStringTable uid arr#) (I# i#) ls = do
+updTbl :: IORef FastStringTable -> FastStringTable -> Int -> [FastString] -> IO ()
+updTbl fs_table_var (FastStringTable uid arr#) (I# i#) ls = do
(IO $ \ s# -> case writeArray# arr# i# ls s# of { s2# -> (# s2#, () #) })
- return (FastStringTable (uid+1) arr#)
-
--- | Helper function for various forms of fast string constructors.
-mkFSInternal :: Ptr Word8 -> Int
- -> (Int -> IO FastString)
- -> IO FastString
--- The interesting part is the use of unsafePerformIO to make the
--- argument to atomicModifyIORef pure. This is safe because any
--- effect dependencies are enforced by data dependencies.
--- Furthermore, every result is used and hence there should be no
--- space leaks.
-mkFSInternal ptr len mk_it = do
- r <- atomicModifyIORef string_table $
- \fs_tbl@(FastStringTable uid _) ->
- let h = hashStr ptr len
- add_it ls = do
- fs <- mk_it uid
- fst' <- updTbl fs_tbl h (fs:ls)
- fs `seq` fst' `seq` return (fst', fs)
- in unsafePerformIO $ do
- lookup_result <- lookupTbl fs_tbl h
- case lookup_result of
- [] -> add_it []
- ls -> do
- b <- bucket_match ls len ptr
- case b of
- Nothing -> add_it ls
- Just v -> return (fs_tbl, v)
- r `seq` return r
+ writeIORef fs_table_var (FastStringTable (uid+1) arr#)
mkFastString# :: Addr# -> FastString
mkFastString# a# = mkFastStringBytes ptr (ptrStrLength ptr)
where ptr = Ptr a#
mkFastStringBytes :: Ptr Word8 -> Int -> FastString
-mkFastStringBytes ptr len = inlinePerformIO $ do
- mkFSInternal ptr len (\uid -> copyNewFastString uid ptr len)
+mkFastStringBytes ptr len = unsafePerformIO $ do
+ 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
+ --
+ lookup_result <- lookupTbl ft h
+ case lookup_result of
+ [] -> add_it []
+ ls -> do
+ b <- bucket_match ls len ptr
+ case b of
+ Nothing -> add_it ls
+ Just v -> {- _trace ("re-use: "++show v) $ -} return v
mkZFastStringBytes :: Ptr Word8 -> Int -> FastString
-mkZFastStringBytes ptr len = inlinePerformIO $ do
- mkFSInternal ptr len (\uid -> copyNewZFastString uid ptr len)
+mkZFastStringBytes ptr len = unsafePerformIO $ do
+ 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
+ --
+ lookup_result <- lookupTbl ft h
+ case lookup_result of
+ [] -> add_it []
+ ls -> do
+ b <- bucket_match ls len ptr
+ case b of
+ 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
- mkFSInternal ptr len (\uid -> mkNewFastString uid ptr fp len)
+ 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
+ --
+ lookup_result <- lookupTbl ft h
+ case lookup_result of
+ [] -> add_it []
+ ls -> do
+ b <- bucket_match ls len ptr
+ case b of
+ 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
- mkFSInternal ptr len (\uid -> mkNewZFastString uid ptr fp len)
+ 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
+ --
+ lookup_result <- lookupTbl ft h
+ case lookup_result of
+ [] -> add_it []
+ ls -> do
+ b <- bucket_match ls len ptr
+ case b of
+ 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
ZEncoded -> fs
UTF8Encoded ref ->
inlinePerformIO $ do
- r <- atomicModifyIORef ref $ \m ->
- case m of
- Just fs -> (m, fs)
- Nothing ->
- let efs = mkZFastString (zEncodeString (unpackFS fs)) in
- efs `seq` (Just efs, efs)
- r `seq` return r
+ m <- readIORef ref
+ case m of
+ Just fs -> return fs
+ Nothing -> do
+ let efs = mkZFastString (zEncodeString (unpackFS fs))
+ 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