Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Alex D
GHC
Commits
9c18ad74
Commit
9c18ad74
authored
Sep 09, 2013
by
parcs
Browse files
Merge branch 'ghc-parmake-gsoc' (#910)
parents
c62a0b99
783ca393
Changes
14
Expand all
Hide whitespace changes
Inline
Side-by-side
compiler/basicTypes/UniqSupply.lhs
View file @
9c18ad74
...
...
@@ -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
View file @
9c18ad74
...
...
@@ -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
View file @
9c18ad74
...
...
@@ -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
View file @
9c18ad74
...
...
@@ -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/GhcMake.hs
View file @
9c18ad74
This diff is collapsed.
Click to expand it.
compiler/main/SysTools.lhs
View file @
9c18ad74
...
...
@@ -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
--
r
eturn our temporary directory within tmp_dir, creating one if we
-- don't have one yet
--
R
eturn 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
View file @
9c18ad74
...
...
@@ -58,7 +58,7 @@ import qualified ErrUtils as Err
import Control.Monad
import Data.Function
import Data.List ( sortBy )
import Data.IORef (
readIORef, write
IORef )
import Data.IORef (
atomicModify
IORef )
\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
View file @
9c18ad74
...
...
@@ -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
View file @
9c18ad74
...
...
@@ -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
View file @
9c18ad74
...
...
@@ -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
View file @
9c18ad74
...
...
@@ -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,
write
IORef )
import Data.IORef ( IORef, newIORef, readIORef,
atomicModify
IORef )
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
<