Commit 738f7078 authored by Thomas Schilling's avatar Thomas Schilling
Browse files

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.
parent d11718fa
......@@ -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)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment