Merge branch 'ghc-parmake-gsoc' (#910)

compiler/basicTypes/UniqSupply.lhs

@@ -29,7 +29,7 @@ module UniqSupply (
 import Unique
 import FastTypes
 
-import GHC.IO (unsafeDupableInterleaveIO)
+import GHC.IO
 
 import MonadUtils
 import Control.Monad
@@ -80,7 +80,8 @@ mkSplitUniqSupply c
 
         -- This is one of the most hammered bits in the whole compiler
         mk_supply
-          = unsafeDupableInterleaveIO (
+          -- NB: Use unsafeInterleaveIO for thread-safety.
+          = unsafeInterleaveIO (
                 genSym      >>= \ u_ -> case iUnbox u_ of { u -> (
                 mk_supply   >>= \ s1 ->
                 mk_supply   >>= \ s2 ->

compiler/cbits/genSym.c

@@ -4,6 +4,14 @@
 static HsInt GenSymCounter = 0;
 
 HsInt genSym(void) {
+#if defined(THREADED_RTS)
+    if (n_capabilities == 1) {
+        return GenSymCounter++;
+    } else {
+        return atomic_inc((StgWord *)&GenSymCounter, 1);
+    }
+#else
     return GenSymCounter++;
+#endif
 }
 

compiler/ghc.mk

@@ -309,6 +309,12 @@ compiler_stage1_CONFIGURE_OPTS += --flags=stage1
 compiler_stage2_CONFIGURE_OPTS += --flags=stage2
 compiler_stage3_CONFIGURE_OPTS += --flags=stage3
 
+ifeq "$(GhcThreaded)" "YES"
+# We pass THREADED_RTS to the stage2 C files so that cbits/genSym.c will bring
+# the threaded version of atomic_inc() into scope.
+compiler_stage2_CONFIGURE_OPTS += --ghc-option=-optc-DTHREADED_RTS
+endif
+
 ifeq "$(GhcWithNativeCodeGen)" "YES"
 compiler_stage1_CONFIGURE_OPTS += --flags=ncg
 compiler_stage2_CONFIGURE_OPTS += --flags=ncg

compiler/main/DynFlags.hs

@@ -584,6 +584,10 @@ data DynFlags = DynFlags {
   ruleCheck             :: Maybe String,
   strictnessBefore      :: [Int],       -- ^ Additional demand analysis
 
+  parMakeCount          :: Maybe Int,   -- ^ The number of modules to compile in parallel
+                                        --   in --make mode, where Nothing ==> compile as
+                                        --   many in parallel as there are CPUs.
+
   maxRelevantBinds      :: Maybe Int,   -- ^ Maximum number of bindings from the type envt
                                         --   to show in type error messages
   simplTickFactor       :: Int,         -- ^ Multiplier for simplifier ticks
@@ -691,7 +695,8 @@ data DynFlags = DynFlags {
   filesToClean          :: IORef [FilePath],
   dirsToClean           :: IORef (Map FilePath FilePath),
   filesToNotIntermediateClean :: IORef [FilePath],
-
+  -- The next available suffix to uniquely name a temp file, updated atomically
+  nextTempSuffix        :: IORef Int,
 
   -- Names of files which were generated from -ddump-to-file; used to
   -- track which ones we need to truncate because it's our first run
@@ -755,7 +760,7 @@ data DynFlags = DynFlags {
 
   llvmVersion           :: IORef Int,
 
-  nextWrapperNum        :: IORef Int,
+  nextWrapperNum        :: IORef (ModuleEnv Int),
 
   -- | Machine dependant flags (-m<blah> stuff)
   sseVersion            :: Maybe (Int, Int),  -- (major, minor)
@@ -1226,13 +1231,14 @@ initDynFlags dflags = do
      platformCanGenerateDynamicToo
          = platformOS (targetPlatform dflags) /= OSMinGW32
  refCanGenerateDynamicToo <- newIORef platformCanGenerateDynamicToo
+ refNextTempSuffix <- newIORef 0
  refFilesToClean <- newIORef []
  refDirsToClean <- newIORef Map.empty
  refFilesToNotIntermediateClean <- newIORef []
  refGeneratedDumps <- newIORef Set.empty
  refLlvmVersion <- newIORef 28
  refRtldFlags <- newIORef Nothing
- wrapperNum <- newIORef 0
+ wrapperNum <- newIORef emptyModuleEnv
  canUseUnicodeQuotes <- do let enc = localeEncoding
                                str = "‛’"
                            (withCString enc str $ \cstr ->
@@ -1241,6 +1247,7 @@ initDynFlags dflags = do
                                `catchIOError` \_ -> return False
  return dflags{
         canGenerateDynamicToo = refCanGenerateDynamicToo,
+        nextTempSuffix = refNextTempSuffix,
         filesToClean   = refFilesToClean,
         dirsToClean    = refDirsToClean,
         filesToNotIntermediateClean = refFilesToNotIntermediateClean,
@@ -1276,6 +1283,8 @@ defaultDynFlags mySettings =
         historySize             = 20,
         strictnessBefore        = [],
 
+        parMakeCount            = Just 1,
+
         cmdlineHcIncludes       = [],
         importPaths             = ["."],
         mainModIs               = mAIN,
@@ -1335,6 +1344,7 @@ defaultDynFlags mySettings =
         depExcludeMods    = [],
         depSuffixes       = [],
         -- end of ghc -M values
+        nextTempSuffix = panic "defaultDynFlags: No nextTempSuffix",
         filesToClean   = panic "defaultDynFlags: No filesToClean",
         dirsToClean    = panic "defaultDynFlags: No dirsToClean",
         filesToNotIntermediateClean = panic "defaultDynFlags: No filesToNotIntermediateClean",
@@ -2033,6 +2043,8 @@ dynamic_flags = [
                            addWarn "-#include and INCLUDE pragmas are deprecated: They no longer have any effect"))
   , Flag "v"        (OptIntSuffix setVerbosity)
 
+  , Flag "j"        (OptIntSuffix (\n -> upd (\d -> d {parMakeCount = n})))
+
         ------- ways --------------------------------------------------------
   , Flag "prof"           (NoArg (addWay WayProf))
   , Flag "eventlog"       (NoArg (addWay WayEventLog))
@@ -3456,6 +3468,7 @@ compilerInfo dflags
        ("Tables next to code",         cGhcEnableTablesNextToCode),
        ("RTS ways",                    cGhcRTSWays),
        ("Support dynamic-too",         "YES"),
+       ("Support parallel --make",     "YES"),
        ("Dynamic by default",          if dYNAMIC_BY_DEFAULT dflags
                                        then "YES" else "NO"),
        ("GHC Dynamic",                 if cDYNAMIC_GHC_PROGRAMS

compiler/main/SysTools.lhs

@@ -825,75 +825,98 @@ readElfSection _dflags section exe = do
 cleanTempDirs :: DynFlags -> IO ()
 cleanTempDirs dflags
    = unless (gopt Opt_KeepTmpFiles dflags)
+   $ mask_
    $ do let ref = dirsToClean dflags
-        ds <- readIORef ref
+        ds <- atomicModifyIORef ref $ \ds -> (Map.empty, ds)
         removeTmpDirs dflags (Map.elems ds)
-        writeIORef ref Map.empty
 
 cleanTempFiles :: DynFlags -> IO ()
 cleanTempFiles dflags
    = unless (gopt Opt_KeepTmpFiles dflags)
+   $ mask_
    $ do let ref = filesToClean dflags
-        fs <- readIORef ref
+        fs <- atomicModifyIORef ref $ \fs -> ([],fs)
         removeTmpFiles dflags fs
-        writeIORef ref []
 
 cleanTempFilesExcept :: DynFlags -> [FilePath] -> IO ()
 cleanTempFilesExcept dflags dont_delete
    = unless (gopt Opt_KeepTmpFiles dflags)
+   $ mask_
    $ do let ref = filesToClean dflags
-        files <- readIORef ref
-        let (to_keep, to_delete) = partition (`elem` dont_delete) files
-        writeIORef ref to_keep
+        to_delete <- atomicModifyIORef ref $ \files ->
+            let (to_keep,to_delete) = partition (`elem` dont_delete) files
+            in  (to_keep,to_delete)
         removeTmpFiles dflags to_delete
 
 
--- find a temporary name that doesn't already exist.
+-- Return a unique numeric temp file suffix
+newTempSuffix :: DynFlags -> IO Int
+newTempSuffix dflags = atomicModifyIORef (nextTempSuffix dflags) $ \n -> (n+1,n)
+
+-- Find a temporary name that doesn't already exist.
 newTempName :: DynFlags -> Suffix -> IO FilePath
 newTempName dflags extn
   = do d <- getTempDir dflags
        x <- getProcessID
-       findTempName (d </> "ghc" ++ show x ++ "_") 0
+       findTempName (d </> "ghc" ++ show x ++ "_")
   where
-    findTempName :: FilePath -> Integer -> IO FilePath
-    findTempName prefix x
-      = do let filename = (prefix ++ show x) <.> extn
-           b  <- doesFileExist filename
-           if b then findTempName prefix (x+1)
+    findTempName :: FilePath -> IO FilePath
+    findTempName prefix
+      = do n <- newTempSuffix dflags
+           let filename = prefix ++ show n <.> extn
+           b <- doesFileExist filename
+           if b then findTempName prefix
                 else do -- clean it up later
                         consIORef (filesToClean dflags) filename
                         return filename
 
--- return our temporary directory within tmp_dir, creating one if we
--- don't have one yet
+-- Return our temporary directory within tmp_dir, creating one if we
+-- don't have one yet.
 getTempDir :: DynFlags -> IO FilePath
-getTempDir dflags
-  = do let ref = dirsToClean dflags
-           tmp_dir = tmpDir dflags
-       mapping <- readIORef ref
-       case Map.lookup tmp_dir mapping of
-           Nothing ->
-               do x <- getProcessID
-                  let prefix = tmp_dir </> "ghc" ++ show x ++ "_"
-                  let
-                      mkTempDir :: Integer -> IO FilePath
-                      mkTempDir x
-                       = let dirname = prefix ++ show x
-                         in do createDirectory dirname
-                               let mapping' = Map.insert tmp_dir dirname mapping
-                               writeIORef ref mapping'
-                               debugTraceMsg dflags 2 (ptext (sLit "Created temporary directory:") <+> text dirname)
-                               return dirname
-                            `catchIO` \e ->
-                                    if isAlreadyExistsError e
-                                    then mkTempDir (x+1)
-                                    else ioError e
-                  mkTempDir 0
-           Just d -> return d
+getTempDir dflags = do
+    mapping <- readIORef dir_ref
+    case Map.lookup tmp_dir mapping of
+        Nothing -> do
+            pid <- getProcessID
+            let prefix = tmp_dir </> "ghc" ++ show pid ++ "_"
+            mask_ $ mkTempDir prefix
+        Just dir -> return dir
+  where
+    tmp_dir = tmpDir dflags
+    dir_ref = dirsToClean dflags
+
+    mkTempDir :: FilePath -> IO FilePath
+    mkTempDir prefix = do
+        n <- newTempSuffix dflags
+        let our_dir = prefix ++ show n
+
+        -- 1. Speculatively create our new directory.
+        createDirectory our_dir
+
+        -- 2. Update the dirsToClean mapping unless an entry already exists
+        -- (i.e. unless another thread beat us to it).
+        their_dir <- atomicModifyIORef dir_ref $ \mapping ->
+            case Map.lookup tmp_dir mapping of
+                Just dir -> (mapping, Just dir)
+                Nothing  -> (Map.insert tmp_dir our_dir mapping, Nothing)
+
+        -- 3. If there was an existing entry, return it and delete the
+        -- directory we created.  Otherwise return the directory we created.
+        case their_dir of
+            Nothing  -> do
+                debugTraceMsg dflags 2 $
+                    text "Created temporary directory:" <+> text our_dir
+                return our_dir
+            Just dir -> do
+                removeDirectory our_dir
+                return dir
+      `catchIO` \e -> if isAlreadyExistsError e || isDoesNotExistError e
+                      then mkTempDir prefix else ioError e
 
 addFilesToClean :: DynFlags -> [FilePath] -> IO ()
 -- May include wildcards [used by DriverPipeline.run_phase SplitMangle]
-addFilesToClean dflags files = mapM_ (consIORef (filesToClean dflags)) files
+addFilesToClean dflags new_files
+    = atomicModifyIORef (filesToClean dflags) $ \files -> (new_files++files, ())
 
 removeTmpDirs :: DynFlags -> [FilePath] -> IO ()
 removeTmpDirs dflags ds

compiler/main/TidyPgm.lhs

@@ -58,7 +58,7 @@ import qualified ErrUtils as Err
 import Control.Monad
 import Data.Function
 import Data.List        ( sortBy )
-import Data.IORef       ( readIORef, writeIORef )
+import Data.IORef       ( atomicModifyIORef )
 \end{code}
 
 
@@ -852,9 +852,7 @@ tidyTopName mod nc_var maybe_ref occ_env id
   -- Now we get to the real reason that all this is in the IO Monad:
   -- we have to update the name cache in a nice atomic fashion
 
-  | local  && internal = do { nc <- readIORef nc_var
-                            ; let (nc', new_local_name) = mk_new_local nc
-                            ; writeIORef nc_var nc'
+  | local  && internal = do { new_local_name <- atomicModifyIORef nc_var mk_new_local
                             ; return (occ_env', new_local_name) }
         -- Even local, internal names must get a unique occurrence, because
         -- if we do -split-objs we externalise the name later, in the code generator
@@ -862,9 +860,7 @@ tidyTopName mod nc_var maybe_ref occ_env id
         -- Similarly, we must make sure it has a system-wide Unique, because
         -- the byte-code generator builds a system-wide Name->BCO symbol table
 
-  | local  && external = do { nc <- readIORef nc_var
-                            ; let (nc', new_external_name) = mk_new_external nc
-                            ; writeIORef nc_var nc'
+  | local  && external = do { new_external_name <- atomicModifyIORef nc_var mk_new_external
                             ; return (occ_env', new_external_name) }
 
   | otherwise = panic "tidyTopName"

compiler/typecheck/TcEnv.lhs

@@ -781,8 +781,10 @@ mkWrapperName what nameBase
              wrapperRef = nextWrapperNum dflags
              pkg = packageIdString  (modulePackageId thisMod)
              mod = moduleNameString (moduleName      thisMod)
-         wrapperNum <- liftIO $ readIORef wrapperRef
-         liftIO $ writeIORef wrapperRef (wrapperNum + 1)
+         wrapperNum <- liftIO $ atomicModifyIORef wrapperRef $ \mod_env ->
+             let num = lookupWithDefaultModuleEnv mod_env 0 thisMod
+                 mod_env' = extendModuleEnv mod_env thisMod (num+1)
+             in (mod_env', num)
          let components = [what, show wrapperNum, pkg, mod, nameBase]
          return $ mkFastString $ zEncodeString $ intercalate ":" components
 
@@ -795,6 +797,9 @@ generate are external names. This means that if a call to them ends up
 in an unfolding, then we can't alpha-rename them, and thus if the
 unique randomly changes from one compile to another then we get a
 spurious ABI change (#4012).
+
+The wrapper counter has to be per-module, not global, so that the number we end
+up using is not dependent on the modules compiled before the current one.
 -}
 \end{code}
 
@@ -844,4 +849,4 @@ This is really a staging error, because we can't run code involving 'x'.
 But in fact the type checker processes types first, so 'x' won't even be
 in the type envt when we look for it in $(foo x).  So inside splices we
 report something missing from the type env as a staging error.
-See Trac #5752 and #5795.
\ No newline at end of file
+See Trac #5752 and #5795.

compiler/typecheck/TcRnMonad.lhs

@@ -1266,7 +1266,11 @@ forkM_maybe :: SDoc -> IfL a -> IfL (Maybe a)
 -- signatures, which is pretty benign
 
 forkM_maybe doc thing_inside
- = do { unsafeInterleaveM $
+ -- NB: Don't share the mutable env_us with the interleaved thread since env_us
+ --     does not get updated atomically (e.g. in newUnique and newUniqueSupply).
+ = do { child_us <- newUniqueSupply
+      ; child_env_us <- newMutVar child_us
+      ; unsafeInterleaveM $ updEnv (\env -> env { env_us = child_env_us }) $
         do { traceIf (text "Starting fork {" <+> doc)
            ; mb_res <- tryM $
                        updLclEnv (\env -> env { if_loc = if_loc env $$ doc }) $

compiler/utils/Binary.hs

@@ -20,7 +20,6 @@ module Binary
     {-type-}  BinHandle,
     SymbolTable, Dictionary,
 
-   openBinIO, openBinIO_,
    openBinMem,
 --   closeBin,
 
@@ -108,15 +107,6 @@ data BinHandle
         -- XXX: should really store a "high water mark" for dumping out
         -- the binary data to a file.
 
-  | BinIO {                     -- binary data stored in a file
-     bh_usr :: UserData,
-     _off_r :: !FastMutInt,     -- the current offset (cached)
-     _hdl   :: !IO.Handle       -- the file handle (must be seekable)
-   }
-        -- cache the file ptr in BinIO; using hTell is too expensive
-        -- to call repeatedly.  If anyone else is modifying this Handle
-        -- at the same time, we'll be screwed.
-
 getUserData :: BinHandle -> UserData
 getUserData bh = bh_usr bh
 
@@ -155,15 +145,6 @@ putAt bh p x = do seekBin bh p; put_ bh x; return ()
 getAt  :: Binary a => BinHandle -> Bin a -> IO a
 getAt bh p = do seekBin bh p; get bh
 
-openBinIO_ :: IO.Handle -> IO BinHandle
-openBinIO_ h = openBinIO h
-
-openBinIO :: IO.Handle -> IO BinHandle
-openBinIO h = do
-  r <- newFastMutInt
-  writeFastMutInt r 0
-  return (BinIO noUserData r h)
-
 openBinMem :: Int -> IO BinHandle
 openBinMem size
  | size <= 0 = error "Data.Binary.openBinMem: size must be >= 0"
@@ -177,13 +158,9 @@ openBinMem size
    return (BinMem noUserData ix_r sz_r arr_r)
 
 tellBin :: BinHandle -> IO (Bin a)
-tellBin (BinIO  _ r _)   = do ix <- readFastMutInt r; return (BinPtr ix)
 tellBin (BinMem _ r _ _) = do ix <- readFastMutInt r; return (BinPtr ix)
 
 seekBin :: BinHandle -> Bin a -> IO ()
-seekBin (BinIO _ ix_r h) (BinPtr p) = do
-  writeFastMutInt ix_r p
-  hSeek h AbsoluteSeek (fromIntegral p)
 seekBin h@(BinMem _ ix_r sz_r _) (BinPtr p) = do
   sz <- readFastMutInt sz_r
   if (p >= sz)
@@ -191,11 +168,6 @@ seekBin h@(BinMem _ ix_r sz_r _) (BinPtr p) = do
         else writeFastMutInt ix_r p
 
 seekBy :: BinHandle -> Int -> IO ()
-seekBy (BinIO _ ix_r h) off = do
-  ix <- readFastMutInt ix_r
-  let ix' = ix + off
-  writeFastMutInt ix_r ix'
-  hSeek h AbsoluteSeek (fromIntegral ix')
 seekBy h@(BinMem _ ix_r sz_r _) off = do
   sz <- readFastMutInt sz_r
   ix <- readFastMutInt ix_r
@@ -209,10 +181,8 @@ isEOFBin (BinMem _ ix_r sz_r _) = do
   ix <- readFastMutInt ix_r
   sz <- readFastMutInt sz_r
   return (ix >= sz)
-isEOFBin (BinIO _ _ h) = hIsEOF h
 
 writeBinMem :: BinHandle -> FilePath -> IO ()
-writeBinMem (BinIO _ _ _) _ = error "Data.Binary.writeBinMem: not a memory handle"
 writeBinMem (BinMem _ ix_r _ arr_r) fn = do
   h <- openBinaryFile fn WriteMode
   arr <- readIORef arr_r
@@ -239,7 +209,6 @@ readBinMem filename = do
   return (BinMem noUserData ix_r sz_r arr_r)
 
 fingerprintBinMem :: BinHandle -> IO Fingerprint
-fingerprintBinMem (BinIO _ _ _) = error "Binary.md5BinMem: not a memory handle"
 fingerprintBinMem (BinMem _ ix_r _ arr_r) = do
   arr <- readIORef arr_r
   ix <- readFastMutInt ix_r
@@ -268,8 +237,6 @@ expandBin (BinMem _ _ sz_r arr_r) off = do
        copyBytes new old sz 
    writeFastMutInt sz_r sz'
    writeIORef arr_r arr'
-expandBin (BinIO _ _ _) _ = return ()
--- no need to expand a file, we'll assume they expand by themselves.
 
 -- -----------------------------------------------------------------------------
 -- Low-level reading/writing of bytes
@@ -286,11 +253,6 @@ putWord8 h@(BinMem _ ix_r sz_r arr_r) w = do
                 withForeignPtr arr $ \p -> pokeByteOff p ix w
                 writeFastMutInt ix_r (ix+1)
                 return ()
-putWord8 (BinIO _ ix_r h) w = do
-    ix <- readFastMutInt ix_r
-    hPutChar h (chr (fromIntegral w)) -- XXX not really correct
-    writeFastMutInt ix_r (ix+1)
-    return ()
 
 getWord8 :: BinHandle -> IO Word8
 getWord8 (BinMem _ ix_r sz_r arr_r) = do
@@ -302,11 +264,6 @@ getWord8 (BinMem _ ix_r sz_r arr_r) = do
     w <- withForeignPtr arr $ \p -> peekByteOff p ix
     writeFastMutInt ix_r (ix+1)
     return w
-getWord8 (BinIO _ ix_r h) = do
-    ix <- readFastMutInt ix_r
-    c <- hGetChar h
-    writeFastMutInt ix_r (ix+1)
-    return $! (fromIntegral (ord c)) -- XXX not really correct
 
 putByte :: BinHandle -> Word8 -> IO ()
 putByte bh w = put_ bh w
@@ -639,7 +596,11 @@ lazyGet :: Binary a => BinHandle -> IO a
 lazyGet bh = do
     p <- get bh -- a BinPtr
     p_a <- tellBin bh
-    a <- unsafeInterleaveIO (getAt bh p_a)
+    a <- unsafeInterleaveIO $ do
+        -- NB: Use a fresh off_r variable in the child thread, for thread
+        -- safety.
+        off_r <- newFastMutInt
+        getAt bh { _off_r = off_r } p_a
     seekBin bh p -- skip over the object for now
     return a
 

compiler/utils/FastString.lhs

@@ -102,6 +102,7 @@ import FastFunctions
 import Panic
 import Util
 
+import Control.Monad
 import Data.ByteString (ByteString)
 import qualified Data.ByteString          as BS
 import qualified Data.ByteString.Char8    as BSC
@@ -112,11 +113,12 @@ import GHC.Exts
 import System.IO
 import System.IO.Unsafe ( unsafePerformIO )
 import Data.Data
-import Data.IORef       ( IORef, newIORef, readIORef, writeIORef )
+import Data.IORef       ( IORef, newIORef, readIORef, atomicModifyIORef )
 import Data.Maybe       ( isJust )
 import Data.Char
+import Data.List        ( elemIndex )
 
-import GHC.IO           ( IO(..) )
+import GHC.IO           ( IO(..), unsafeDupablePerformIO )
 
 import Foreign.Safe
 
@@ -218,30 +220,37 @@ foreign import ccall unsafe "ghc_memcmp"
 -- Construction
 
 {-
-Internally, the compiler will maintain a fast string symbol
-table, providing sharing and fast comparison. Creation of
-new @FastString@s then covertly does a lookup, re-using the
-@FastString@ if there was a hit.
--}
+Internally, the compiler will maintain a fast string symbol table, providing
+sharing and fast comparison. Creation of new @FastString@s then covertly does a
+lookup, re-using the @FastString@ if there was a hit.
+
+The design of the FastString hash table allows for lockless concurrent reads
+and updates to multiple buckets with low synchronization overhead.
 
+See Note [Updating the FastString table] on how it's updated.
+-}
 data FastStringTable =
  FastStringTable
-    {-# UNPACK #-} !Int
-    (MutableArray# RealWorld [FastString])
+    {-# UNPACK #-} !(IORef Int)  -- the unique ID counter shared with all buckets
+    (MutableArray# RealWorld (IORef [FastString])) -- the array of mutable buckets
 
-string_table :: IORef FastStringTable
+string_table :: FastStringTable
 {-# NOINLINE string_table #-}
 string_table = unsafePerformIO $ do
-  tab <- IO $ \s1# -> case newArray# hASH_TBL_SIZE_UNBOXED [] s1# of
+  uid <- newIORef 0
+  tab <- IO $ \s1# -> case newArray# hASH_TBL_SIZE_UNBOXED (panic "string_table") s1# of
                           (# s2#, arr# #) ->
-                              (# s2#, FastStringTable 0 arr# #)
-  ref <- newIORef tab
+                              (# s2#, FastStringTable uid arr# #)
+  forM_ [0..hASH_TBL_SIZE-1] $ \i -> do
+     bucket <- newIORef []
+     updTbl tab i bucket
+
   -- use the support wired into the RTS to share this CAF among all images of
   -- libHSghc
 #if STAGE < 2
-  return ref
+  return tab
 #else
-  sharedCAF ref getOrSetLibHSghcFastStringTable
+  sharedCAF tab getOrSetLibHSghcFastStringTable
 
 -- from the RTS; thus we cannot use this mechanism when STAGE<2; the previous
 -- RTS might not have this symbol
@@ -287,87 +296,92 @@ lower-level `sharedCAF` mechanism that relies on Globals.c.
 
 -}
 
-lookupTbl :: FastStringTable -> Int -> IO [FastString]
+lookupTbl :: FastStringTable -> Int -> IO (IORef [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 -> IORef [FastString] -> IO ()
+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#)
 
 mkFastString# :: Addr# -> FastString
 mkFastString# a# = mkFastStringBytes ptr (ptrStrLength ptr)
   where ptr = Ptr a#
 
+{- Note [Updating the FastString table]
+
+The procedure goes like this:
+
+1. Read the relevant bucket and perform a look up of the string.
+2. If it exists, return it.
+3. Otherwise grab a unique ID, create a new FastString and atomically attempt
+   to update the relevant bucket with this FastString:
+
+   * Double check that the string is not in the bucket. Another thread may have
+     inserted it while we were creating our string.
+   * Return the existing FastString if it exists. The one we preemptively
+     created will get GCed.
+   * Otherwise, insert and return the string we created.
+-}
+
+{- Note [Double-checking the bucket]
+
+It is not necessary to check the entire bucket the second time. We only have to
+check the strings that are new to the bucket since the last time we read it.
+-}
+
+mkFastStringWith :: (Int -> IO FastString) -> Ptr Word8 -> Int -> IO FastString
+mkFastStringWith mk_fs !ptr !len = do
+    let hash = hashStr ptr len
+    bucket <- lookupTbl string_table hash
+    ls1 <- readIORef bucket
+    res <- bucket_match ls1 len ptr
+    case res of
+        Just v  -> return v
+        Nothing -> do
+            n <- get_uid
+            new_fs <- mk_fs n
+
+            atomicModifyIORef bucket $ \ls2 ->
+                -- Note [Double-checking the bucket]
+                let delta_ls = case ls1 of
+                        []  -> ls2
+                        l:_ -> case l `elemIndex` ls2 of
+                            Nothing  -> panic "mkFastStringWith"
+                            Just idx -> take idx ls2
+
+                -- NB: Might as well use inlinePerformIO, since the call to
+                -- bucket_match doesn't perform any IO that could be floated
+                -- out of this closure or erroneously duplicated.
+                in case inlinePerformIO (bucket_match delta_ls len ptr) of
+                    Nothing -> (new_fs:ls2, new_fs)
+                    Just fs -> (ls2,fs)
+  where
+    !(FastStringTable uid _arr) = string_table
+
+    get_uid = atomicModifyIORef uid $ \n -> (n+1,n)
+
 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