Commit 9c18ad74 authored by parcs's avatar parcs
Browse files

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

parents c62a0b99 783ca393
......@@ -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 ->
......
......@@ -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
}
......@@ -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
......
......@@ -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
......
This diff is collapsed.
......@@ -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
......
......@@ -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"
......
......@@ -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.
......@@ -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 }) $
......
......@@ -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
......
......@@ -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