From 738f70785e381ca2f43413a1d8efa4d5929b8231 Mon Sep 17 00:00:00 2001 From: Thomas Schilling Date: Mon, 24 Aug 2009 18:22:52 +0000 Subject: [PATCH] Make FastString thread-safe. This is needed both for per-session parallelism and for allowing multiple concurrent sessions in the same process. With the help of atomicModifyIORef and unsafePerformIO it is also quite fast--an MVar would most likely be slower. On a full compilation of Cabal's head branch it was about 1-2 percent slower, but then overall compilation times varied by about 4 percent, so I think it's worth it. --- compiler/utils/FastString.lhs | 129 ++++++++++++++--------------------------- 1 file changed, 45 insertions(+), 84 deletions(-) diff --git a/compiler/utils/FastString.lhs b/compiler/utils/FastString.lhs index 29c7788..60a5191 100644 --- a/compiler/utils/FastString.lhs +++ b/compiler/utils/FastString.lhs @@ -99,7 +99,7 @@ import Foreign.C import GHC.Exts import System.IO import System.IO.Unsafe ( unsafePerformIO ) -import Data.IORef ( IORef, newIORef, readIORef, writeIORef ) +import Data.IORef ( IORef, newIORef, readIORef, atomicModifyIORef ) import Data.Maybe ( isJust ) import Data.Char ( ord ) @@ -207,100 +207,61 @@ lookupTbl :: FastStringTable -> Int -> IO [FastString] lookupTbl (FastStringTable _ arr#) (I# i#) = IO $ \ s# -> readArray# arr# i# s# -updTbl :: IORef FastStringTable -> FastStringTable -> Int -> [FastString] -> IO () -updTbl fs_table_var (FastStringTable uid arr#) (I# i#) ls = do +updTbl :: FastStringTable -> Int -> [FastString] -> IO FastStringTable +updTbl (FastStringTable uid arr#) (I# i#) ls = do (IO $ \ s# -> case writeArray# arr# i# ls s# of { s2# -> (# s2#, () #) }) - writeIORef fs_table_var (FastStringTable (uid+1) arr#) + 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 mkFastString# :: Addr# -> FastString mkFastString# a# = mkFastStringBytes ptr (ptrStrLength ptr) where ptr = Ptr a# mkFastStringBytes :: Ptr Word8 -> Int -> FastString -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 +mkFastStringBytes ptr len = inlinePerformIO $ do + mkFSInternal ptr len (\uid -> copyNewFastString uid ptr len) mkZFastStringBytes :: Ptr Word8 -> Int -> FastString -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 +mkZFastStringBytes ptr len = inlinePerformIO $ do + mkFSInternal ptr len (\uid -> copyNewZFastString uid ptr len) -- | 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 _) <- 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 + mkFSInternal ptr len (\uid -> mkNewFastString uid ptr fp len) mkZFastStringForeignPtr :: Ptr Word8 -> ForeignPtr Word8 -> Int -> IO FastString mkZFastStringForeignPtr ptr fp len = do - 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 - + mkFSInternal ptr len (\uid -> mkNewZFastString uid ptr fp len) -- | Creates a UTF-8 encoded 'FastString' from a 'String' mkFastString :: String -> FastString @@ -440,13 +401,13 @@ zEncodeFS fs@(FastString _ _ _ _ enc) = ZEncoded -> fs UTF8Encoded ref -> inlinePerformIO $ do - m <- readIORef ref - case m of - Just fs -> return fs - Nothing -> do - let efs = mkZFastString (zEncodeString (unpackFS fs)) - writeIORef ref (Just efs) - return efs + 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 appendFS :: FastString -> FastString -> FastString appendFS fs1 fs2 = mkFastString (unpackFS fs1 ++ unpackFS fs2) -- 1.7.10.4