Commit 9c18ad74 authored by parcs's avatar parcs

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

parents c62a0b99 783ca393
...@@ -29,7 +29,7 @@ module UniqSupply ( ...@@ -29,7 +29,7 @@ module UniqSupply (
import Unique import Unique
import FastTypes import FastTypes
import GHC.IO (unsafeDupableInterleaveIO) import GHC.IO
import MonadUtils import MonadUtils
import Control.Monad import Control.Monad
...@@ -80,7 +80,8 @@ mkSplitUniqSupply c ...@@ -80,7 +80,8 @@ mkSplitUniqSupply c
-- This is one of the most hammered bits in the whole compiler -- This is one of the most hammered bits in the whole compiler
mk_supply mk_supply
= unsafeDupableInterleaveIO ( -- NB: Use unsafeInterleaveIO for thread-safety.
= unsafeInterleaveIO (
genSym >>= \ u_ -> case iUnbox u_ of { u -> ( genSym >>= \ u_ -> case iUnbox u_ of { u -> (
mk_supply >>= \ s1 -> mk_supply >>= \ s1 ->
mk_supply >>= \ s2 -> mk_supply >>= \ s2 ->
......
...@@ -4,6 +4,14 @@ ...@@ -4,6 +4,14 @@
static HsInt GenSymCounter = 0; static HsInt GenSymCounter = 0;
HsInt genSym(void) { HsInt genSym(void) {
#if defined(THREADED_RTS)
if (n_capabilities == 1) {
return GenSymCounter++;
} else {
return atomic_inc((StgWord *)&GenSymCounter, 1);
}
#else
return GenSymCounter++; return GenSymCounter++;
#endif
} }
...@@ -309,6 +309,12 @@ compiler_stage1_CONFIGURE_OPTS += --flags=stage1 ...@@ -309,6 +309,12 @@ compiler_stage1_CONFIGURE_OPTS += --flags=stage1
compiler_stage2_CONFIGURE_OPTS += --flags=stage2 compiler_stage2_CONFIGURE_OPTS += --flags=stage2
compiler_stage3_CONFIGURE_OPTS += --flags=stage3 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" ifeq "$(GhcWithNativeCodeGen)" "YES"
compiler_stage1_CONFIGURE_OPTS += --flags=ncg compiler_stage1_CONFIGURE_OPTS += --flags=ncg
compiler_stage2_CONFIGURE_OPTS += --flags=ncg compiler_stage2_CONFIGURE_OPTS += --flags=ncg
......
...@@ -584,6 +584,10 @@ data DynFlags = DynFlags { ...@@ -584,6 +584,10 @@ data DynFlags = DynFlags {
ruleCheck :: Maybe String, ruleCheck :: Maybe String,
strictnessBefore :: [Int], -- ^ Additional demand analysis 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 maxRelevantBinds :: Maybe Int, -- ^ Maximum number of bindings from the type envt
-- to show in type error messages -- to show in type error messages
simplTickFactor :: Int, -- ^ Multiplier for simplifier ticks simplTickFactor :: Int, -- ^ Multiplier for simplifier ticks
...@@ -691,7 +695,8 @@ data DynFlags = DynFlags { ...@@ -691,7 +695,8 @@ data DynFlags = DynFlags {
filesToClean :: IORef [FilePath], filesToClean :: IORef [FilePath],
dirsToClean :: IORef (Map FilePath FilePath), dirsToClean :: IORef (Map FilePath FilePath),
filesToNotIntermediateClean :: IORef [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 -- 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 -- track which ones we need to truncate because it's our first run
...@@ -755,7 +760,7 @@ data DynFlags = DynFlags { ...@@ -755,7 +760,7 @@ data DynFlags = DynFlags {
llvmVersion :: IORef Int, llvmVersion :: IORef Int,
nextWrapperNum :: IORef Int, nextWrapperNum :: IORef (ModuleEnv Int),
-- | Machine dependant flags (-m<blah> stuff) -- | Machine dependant flags (-m<blah> stuff)
sseVersion :: Maybe (Int, Int), -- (major, minor) sseVersion :: Maybe (Int, Int), -- (major, minor)
...@@ -1226,13 +1231,14 @@ initDynFlags dflags = do ...@@ -1226,13 +1231,14 @@ initDynFlags dflags = do
platformCanGenerateDynamicToo platformCanGenerateDynamicToo
= platformOS (targetPlatform dflags) /= OSMinGW32 = platformOS (targetPlatform dflags) /= OSMinGW32
refCanGenerateDynamicToo <- newIORef platformCanGenerateDynamicToo refCanGenerateDynamicToo <- newIORef platformCanGenerateDynamicToo
refNextTempSuffix <- newIORef 0
refFilesToClean <- newIORef [] refFilesToClean <- newIORef []
refDirsToClean <- newIORef Map.empty refDirsToClean <- newIORef Map.empty
refFilesToNotIntermediateClean <- newIORef [] refFilesToNotIntermediateClean <- newIORef []
refGeneratedDumps <- newIORef Set.empty refGeneratedDumps <- newIORef Set.empty
refLlvmVersion <- newIORef 28 refLlvmVersion <- newIORef 28
refRtldFlags <- newIORef Nothing refRtldFlags <- newIORef Nothing
wrapperNum <- newIORef 0 wrapperNum <- newIORef emptyModuleEnv
canUseUnicodeQuotes <- do let enc = localeEncoding canUseUnicodeQuotes <- do let enc = localeEncoding
str = "‛’" str = "‛’"
(withCString enc str $ \cstr -> (withCString enc str $ \cstr ->
...@@ -1241,6 +1247,7 @@ initDynFlags dflags = do ...@@ -1241,6 +1247,7 @@ initDynFlags dflags = do
`catchIOError` \_ -> return False `catchIOError` \_ -> return False
return dflags{ return dflags{
canGenerateDynamicToo = refCanGenerateDynamicToo, canGenerateDynamicToo = refCanGenerateDynamicToo,
nextTempSuffix = refNextTempSuffix,
filesToClean = refFilesToClean, filesToClean = refFilesToClean,
dirsToClean = refDirsToClean, dirsToClean = refDirsToClean,
filesToNotIntermediateClean = refFilesToNotIntermediateClean, filesToNotIntermediateClean = refFilesToNotIntermediateClean,
...@@ -1276,6 +1283,8 @@ defaultDynFlags mySettings = ...@@ -1276,6 +1283,8 @@ defaultDynFlags mySettings =
historySize = 20, historySize = 20,
strictnessBefore = [], strictnessBefore = [],
parMakeCount = Just 1,
cmdlineHcIncludes = [], cmdlineHcIncludes = [],
importPaths = ["."], importPaths = ["."],
mainModIs = mAIN, mainModIs = mAIN,
...@@ -1335,6 +1344,7 @@ defaultDynFlags mySettings = ...@@ -1335,6 +1344,7 @@ defaultDynFlags mySettings =
depExcludeMods = [], depExcludeMods = [],
depSuffixes = [], depSuffixes = [],
-- end of ghc -M values -- end of ghc -M values
nextTempSuffix = panic "defaultDynFlags: No nextTempSuffix",
filesToClean = panic "defaultDynFlags: No filesToClean", filesToClean = panic "defaultDynFlags: No filesToClean",
dirsToClean = panic "defaultDynFlags: No dirsToClean", dirsToClean = panic "defaultDynFlags: No dirsToClean",
filesToNotIntermediateClean = panic "defaultDynFlags: No filesToNotIntermediateClean", filesToNotIntermediateClean = panic "defaultDynFlags: No filesToNotIntermediateClean",
...@@ -2033,6 +2043,8 @@ dynamic_flags = [ ...@@ -2033,6 +2043,8 @@ dynamic_flags = [
addWarn "-#include and INCLUDE pragmas are deprecated: They no longer have any effect")) addWarn "-#include and INCLUDE pragmas are deprecated: They no longer have any effect"))
, Flag "v" (OptIntSuffix setVerbosity) , Flag "v" (OptIntSuffix setVerbosity)
, Flag "j" (OptIntSuffix (\n -> upd (\d -> d {parMakeCount = n})))
------- ways -------------------------------------------------------- ------- ways --------------------------------------------------------
, Flag "prof" (NoArg (addWay WayProf)) , Flag "prof" (NoArg (addWay WayProf))
, Flag "eventlog" (NoArg (addWay WayEventLog)) , Flag "eventlog" (NoArg (addWay WayEventLog))
...@@ -3456,6 +3468,7 @@ compilerInfo dflags ...@@ -3456,6 +3468,7 @@ compilerInfo dflags
("Tables next to code", cGhcEnableTablesNextToCode), ("Tables next to code", cGhcEnableTablesNextToCode),
("RTS ways", cGhcRTSWays), ("RTS ways", cGhcRTSWays),
("Support dynamic-too", "YES"), ("Support dynamic-too", "YES"),
("Support parallel --make", "YES"),
("Dynamic by default", if dYNAMIC_BY_DEFAULT dflags ("Dynamic by default", if dYNAMIC_BY_DEFAULT dflags
then "YES" else "NO"), then "YES" else "NO"),
("GHC Dynamic", if cDYNAMIC_GHC_PROGRAMS ("GHC Dynamic", if cDYNAMIC_GHC_PROGRAMS
......
This diff is collapsed.
...@@ -825,75 +825,98 @@ readElfSection _dflags section exe = do ...@@ -825,75 +825,98 @@ readElfSection _dflags section exe = do
cleanTempDirs :: DynFlags -> IO () cleanTempDirs :: DynFlags -> IO ()
cleanTempDirs dflags cleanTempDirs dflags
= unless (gopt Opt_KeepTmpFiles dflags) = unless (gopt Opt_KeepTmpFiles dflags)
$ mask_
$ do let ref = dirsToClean dflags $ do let ref = dirsToClean dflags
ds <- readIORef ref ds <- atomicModifyIORef ref $ \ds -> (Map.empty, ds)
removeTmpDirs dflags (Map.elems ds) removeTmpDirs dflags (Map.elems ds)
writeIORef ref Map.empty
cleanTempFiles :: DynFlags -> IO () cleanTempFiles :: DynFlags -> IO ()
cleanTempFiles dflags cleanTempFiles dflags
= unless (gopt Opt_KeepTmpFiles dflags) = unless (gopt Opt_KeepTmpFiles dflags)
$ mask_
$ do let ref = filesToClean dflags $ do let ref = filesToClean dflags
fs <- readIORef ref fs <- atomicModifyIORef ref $ \fs -> ([],fs)
removeTmpFiles dflags fs removeTmpFiles dflags fs
writeIORef ref []
cleanTempFilesExcept :: DynFlags -> [FilePath] -> IO () cleanTempFilesExcept :: DynFlags -> [FilePath] -> IO ()
cleanTempFilesExcept dflags dont_delete cleanTempFilesExcept dflags dont_delete
= unless (gopt Opt_KeepTmpFiles dflags) = unless (gopt Opt_KeepTmpFiles dflags)
$ mask_
$ do let ref = filesToClean dflags $ do let ref = filesToClean dflags
files <- readIORef ref to_delete <- atomicModifyIORef ref $ \files ->
let (to_keep, to_delete) = partition (`elem` dont_delete) files let (to_keep,to_delete) = partition (`elem` dont_delete) files
writeIORef ref to_keep in (to_keep,to_delete)
removeTmpFiles dflags 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 :: DynFlags -> Suffix -> IO FilePath
newTempName dflags extn newTempName dflags extn
= do d <- getTempDir dflags = do d <- getTempDir dflags
x <- getProcessID x <- getProcessID
findTempName (d </> "ghc" ++ show x ++ "_") 0 findTempName (d </> "ghc" ++ show x ++ "_")
where where
findTempName :: FilePath -> Integer -> IO FilePath findTempName :: FilePath -> IO FilePath
findTempName prefix x findTempName prefix
= do let filename = (prefix ++ show x) <.> extn = do n <- newTempSuffix dflags
b <- doesFileExist filename let filename = prefix ++ show n <.> extn
if b then findTempName prefix (x+1) b <- doesFileExist filename
if b then findTempName prefix
else do -- clean it up later else do -- clean it up later
consIORef (filesToClean dflags) filename consIORef (filesToClean dflags) filename
return filename return filename
-- return our temporary directory within tmp_dir, creating one if we -- Return our temporary directory within tmp_dir, creating one if we
-- don't have one yet -- don't have one yet.
getTempDir :: DynFlags -> IO FilePath getTempDir :: DynFlags -> IO FilePath
getTempDir dflags getTempDir dflags = do
= do let ref = dirsToClean dflags mapping <- readIORef dir_ref
tmp_dir = tmpDir dflags case Map.lookup tmp_dir mapping of
mapping <- readIORef ref Nothing -> do
case Map.lookup tmp_dir mapping of pid <- getProcessID
Nothing -> let prefix = tmp_dir </> "ghc" ++ show pid ++ "_"
do x <- getProcessID mask_ $ mkTempDir prefix
let prefix = tmp_dir </> "ghc" ++ show x ++ "_" Just dir -> return dir
let where
mkTempDir :: Integer -> IO FilePath tmp_dir = tmpDir dflags
mkTempDir x dir_ref = dirsToClean dflags
= let dirname = prefix ++ show x
in do createDirectory dirname mkTempDir :: FilePath -> IO FilePath
let mapping' = Map.insert tmp_dir dirname mapping mkTempDir prefix = do
writeIORef ref mapping' n <- newTempSuffix dflags
debugTraceMsg dflags 2 (ptext (sLit "Created temporary directory:") <+> text dirname) let our_dir = prefix ++ show n
return dirname
`catchIO` \e -> -- 1. Speculatively create our new directory.
if isAlreadyExistsError e createDirectory our_dir
then mkTempDir (x+1)
else ioError e -- 2. Update the dirsToClean mapping unless an entry already exists
mkTempDir 0 -- (i.e. unless another thread beat us to it).
Just d -> return d 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 () addFilesToClean :: DynFlags -> [FilePath] -> IO ()
-- May include wildcards [used by DriverPipeline.run_phase SplitMangle] -- 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 :: DynFlags -> [FilePath] -> IO ()
removeTmpDirs dflags ds removeTmpDirs dflags ds
......
...@@ -58,7 +58,7 @@ import qualified ErrUtils as Err ...@@ -58,7 +58,7 @@ import qualified ErrUtils as Err
import Control.Monad import Control.Monad
import Data.Function import Data.Function
import Data.List ( sortBy ) import Data.List ( sortBy )
import Data.IORef ( readIORef, writeIORef ) import Data.IORef ( atomicModifyIORef )
\end{code} \end{code}
...@@ -852,9 +852,7 @@ tidyTopName mod nc_var maybe_ref occ_env id ...@@ -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: -- 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 -- we have to update the name cache in a nice atomic fashion
| local && internal = do { nc <- readIORef nc_var | local && internal = do { new_local_name <- atomicModifyIORef nc_var mk_new_local
; let (nc', new_local_name) = mk_new_local nc
; writeIORef nc_var nc'
; return (occ_env', new_local_name) } ; return (occ_env', new_local_name) }
-- Even local, internal names must get a unique occurrence, because -- Even local, internal names must get a unique occurrence, because
-- if we do -split-objs we externalise the name later, in the code generator -- 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 ...@@ -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 -- Similarly, we must make sure it has a system-wide Unique, because
-- the byte-code generator builds a system-wide Name->BCO symbol table -- the byte-code generator builds a system-wide Name->BCO symbol table
| local && external = do { nc <- readIORef nc_var | local && external = do { new_external_name <- atomicModifyIORef nc_var mk_new_external
; let (nc', new_external_name) = mk_new_external nc
; writeIORef nc_var nc'
; return (occ_env', new_external_name) } ; return (occ_env', new_external_name) }
| otherwise = panic "tidyTopName" | otherwise = panic "tidyTopName"
......
...@@ -781,8 +781,10 @@ mkWrapperName what nameBase ...@@ -781,8 +781,10 @@ mkWrapperName what nameBase
wrapperRef = nextWrapperNum dflags wrapperRef = nextWrapperNum dflags
pkg = packageIdString (modulePackageId thisMod) pkg = packageIdString (modulePackageId thisMod)
mod = moduleNameString (moduleName thisMod) mod = moduleNameString (moduleName thisMod)
wrapperNum <- liftIO $ readIORef wrapperRef wrapperNum <- liftIO $ atomicModifyIORef wrapperRef $ \mod_env ->
liftIO $ writeIORef wrapperRef (wrapperNum + 1) 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] let components = [what, show wrapperNum, pkg, mod, nameBase]
return $ mkFastString $ zEncodeString $ intercalate ":" components return $ mkFastString $ zEncodeString $ intercalate ":" components
...@@ -795,6 +797,9 @@ generate are external names. This means that if a call to them ends up ...@@ -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 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 unique randomly changes from one compile to another then we get a
spurious ABI change (#4012). 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} \end{code}
...@@ -844,4 +849,4 @@ This is really a staging error, because we can't run code involving 'x'. ...@@ -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 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 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. report something missing from the type env as a staging error.
See Trac #5752 and #5795. See Trac #5752 and #5795.
\ No newline at end of file
...@@ -1266,7 +1266,11 @@ forkM_maybe :: SDoc -> IfL a -> IfL (Maybe a) ...@@ -1266,7 +1266,11 @@ forkM_maybe :: SDoc -> IfL a -> IfL (Maybe a)
-- signatures, which is pretty benign -- signatures, which is pretty benign
forkM_maybe doc thing_inside 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) do { traceIf (text "Starting fork {" <+> doc)
; mb_res <- tryM $ ; mb_res <- tryM $
updLclEnv (\env -> env { if_loc = if_loc env $$ doc }) $ updLclEnv (\env -> env { if_loc = if_loc env $$ doc }) $
......
...@@ -20,7 +20,6 @@ module Binary ...@@ -20,7 +20,6 @@ module Binary
{-type-} BinHandle, {-type-} BinHandle,
SymbolTable, Dictionary, SymbolTable, Dictionary,
openBinIO, openBinIO_,
openBinMem, openBinMem,
-- closeBin, -- closeBin,
...@@ -108,15 +107,6 @@ data BinHandle ...@@ -108,15 +107,6 @@ data BinHandle
-- XXX: should really store a "high water mark" for dumping out -- XXX: should really store a "high water mark" for dumping out
-- the binary data to a file. -- 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 :: BinHandle -> UserData
getUserData bh = bh_usr bh getUserData bh = bh_usr bh
...@@ -155,15 +145,6 @@ putAt bh p x = do seekBin bh p; put_ bh x; return () ...@@ -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 :: Binary a => BinHandle -> Bin a -> IO a
getAt bh p = do seekBin bh p; get bh 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 :: Int -> IO BinHandle
openBinMem size openBinMem size
| size <= 0 = error "Data.Binary.openBinMem: size must be >= 0" | size <= 0 = error "Data.Binary.openBinMem: size must be >= 0"
...@@ -177,13 +158,9 @@ openBinMem size ...@@ -177,13 +158,9 @@ openBinMem size
return (BinMem noUserData ix_r sz_r arr_r) return (BinMem noUserData ix_r sz_r arr_r)
tellBin :: BinHandle -> IO (Bin a) 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) tellBin (BinMem _ r _ _) = do ix <- readFastMutInt r; return (BinPtr ix)
seekBin :: BinHandle -> Bin a -> IO () 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 seekBin h@(BinMem _ ix_r sz_r _) (BinPtr p) = do
sz <- readFastMutInt sz_r sz <- readFastMutInt sz_r
if (p >= sz) if (p >= sz)
...@@ -191,11 +168,6 @@ seekBin h@(BinMem _ ix_r sz_r _) (BinPtr p) = do ...@@ -191,11 +168,6 @@ seekBin h@(BinMem _ ix_r sz_r _) (BinPtr p) = do
else writeFastMutInt ix_r p else writeFastMutInt ix_r p
seekBy :: BinHandle -> Int -> IO () 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 seekBy h@(BinMem _ ix_r sz_r _) off = do
sz <- readFastMutInt sz_r sz <- readFastMutInt sz_r
ix <- readFastMutInt ix_r ix <- readFastMutInt ix_r
...@@ -209,10 +181,8 @@ isEOFBin (BinMem _ ix_r sz_r _) = do ...@@ -209,10 +181,8 @@ isEOFBin (BinMem _ ix_r sz_r _) = do
ix <- readFastMutInt ix_r ix <- readFastMutInt ix_r
sz <- readFastMutInt sz_r sz <- readFastMutInt sz_r
return (ix >= sz) return (ix >= sz)
isEOFBin (BinIO _ _ h) = hIsEOF h
writeBinMem :: BinHandle -> FilePath -> IO () writeBinMem :: BinHandle -> FilePath -> IO ()
writeBinMem (BinIO _ _ _) _ = error "Data.Binary.writeBinMem: not a memory handle"
writeBinMem (BinMem _ ix_r _ arr_r) fn = do writeBinMem (BinMem _ ix_r _ arr_r) fn = do
h <- openBinaryFile fn WriteMode h <- openBinaryFile fn WriteMode
arr <- readIORef arr_r arr <- readIORef arr_r
...@@ -239,7 +209,6 @@ readBinMem filename = do ...@@ -239,7 +209,6 @@ readBinMem filename = do
return (BinMem noUserData ix_r sz_r arr_r) return (BinMem noUserData ix_r sz_r arr_r)
fingerprintBinMem :: BinHandle -> IO Fingerprint fingerprintBinMem :: BinHandle -> IO Fingerprint
fingerprintBinMem (BinIO _ _ _) = error "Binary.md5BinMem: not a memory handle"
fingerprintBinMem (BinMem _ ix_r _ arr_r) = do fingerprintBinMem (BinMem _ ix_r _ arr_r) = do
arr <- readIORef arr_r arr <- readIORef arr_r
ix <- readFastMutInt ix_r ix <- readFastMutInt ix_r
...@@ -268,8 +237,6 @@ expandBin (BinMem _ _ sz_r arr_r) off = do ...@@ -268,8 +237,6 @@ expandBin (BinMem _ _ sz_r arr_r) off = do
copyBytes new old sz copyBytes new old sz
writeFastMutInt sz_r sz' writeFastMutInt sz_r sz'
writeIORef arr_r arr' 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 -- Low-level reading/writing of bytes
...@@ -286,11 +253,6 @@ putWord8 h@(BinMem _ ix_r sz_r arr_r) w = do ...@@ -286,11 +253,6 @@ putWord8 h@(BinMem _ ix_r sz_r arr_r) w = do
withForeignPtr arr $ \p -> pokeByteOff p ix w withForeignPtr arr $ \p -> pokeByteOff p ix w
writeFastMutInt ix_r (ix+1) writeFastMutInt ix_r (ix+1)
return () 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 :: BinHandle -> IO Word8
getWord8 (BinMem _ ix_r sz_r arr_r) = do getWord8 (BinMem _ ix_r sz_r arr_r) = do
...@@ -302,11 +264,6 @@ 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 w <- withForeignPtr arr $ \p -> peekByteOff p ix
writeFastMutInt ix_r (ix+1) writeFastMutInt ix_r (ix+1)
return w 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 :: BinHandle -> Word8 -> IO ()
putByte bh w = put_ bh w putByte bh w = put_ bh w
...@@ -639,7 +596,11 @@ lazyGet :: Binary a => BinHandle -> IO a ...@@ -639,7 +596,11 @@ lazyGet :: Binary a => BinHandle -> IO a
lazyGet bh = do lazyGet bh = do
p <- get bh -- a BinPtr p <- get bh -- a BinPtr
p_a <- tellBin bh 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 seekBin bh p -- skip over the object for now
return a return a
......