haskell/stackage
1
0
Fork 0
mirror of https://github.com/commercialhaskell/stackage.git synced 2026-01-23 12:41:58 +01:00
Code Issues Actions 1 Packages Projects Releases Wiki Activity

Only create log files when needed

Browse Source 
Did this for two reasons:

1. Easier to read incremental output this way
2. I believe that, with incremental builds, we were running out of file
descriptors in some cases due to so rapidly plowing through all of the
packages. I'm not certain this was the source of the errors I was
seeing, but given (1), it made sense to try this first.
This commit is contained in:
Michael Snoyman 2015-03-15 15:46:58 +02:00
parent 2aa6ecc968
commit e80a8d0acf
1 changed files with 25 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

36
Stackage/PerformBuild.hs
View File

@ -30,7 +30,7 @@ import Stackage.Prelude hiding (pi)
import System.Directory (findExecutable) import System.Directory (findExecutable)
import System.Environment (getEnvironment) import System.Environment (getEnvironment)
import System.IO (IOMode (WriteMode), import System.IO (IOMode (WriteMode),
withBinaryFile) openBinaryFile)
import System.IO.Temp (withSystemTempDirectory) import System.IO.Temp (withSystemTempDirectory)
data BuildException = BuildException (Map PackageName BuildFailure) [Text] data BuildException = BuildException (Map PackageName BuildFailure) [Text]
@ -291,11 +291,12 @@ singleBuild pb@PerformBuild {..} registeredPackages SingleBuild {..} =
, display $ ppVersion $ piPlan sbPackageInfo , display $ ppVersion $ piPlan sbPackageInfo
] ]
runIn wdir outH cmd args = runIn wdir getOutH cmd args = do
withCheckedProcess cp $ \ClosedStream UseProvidedHandle UseProvidedHandle -> outH <- getOutH
withCheckedProcess (cp outH) $ \ClosedStream UseProvidedHandle UseProvidedHandle ->
(return () :: IO ()) (return () :: IO ())
where where
cp = (proc (unpack $ asText cmd) (map (unpack . asText) args)) cp outH = (proc (unpack $ asText cmd) (map (unpack . asText) args))
{ cwd = Just $ fpToString wdir { cwd = Just $ fpToString wdir
, std_out = UseHandle outH , std_out = UseHandle outH
, std_err = UseHandle outH , std_err = UseHandle outH
@ -321,8 +322,21 @@ singleBuild pb@PerformBuild {..} registeredPackages SingleBuild {..} =
testRunOut = pbLogDir </> fpFromText namever </> "test-run.out" testRunOut = pbLogDir </> fpFromText namever </> "test-run.out"
wf fp inner' = do wf fp inner' = do
createTree $ parent fp ref <- newIORef Nothing
withBinaryFile (fpToString fp) WriteMode inner' let cleanup = do
mh <- readIORef ref
forM_ mh hClose
getH = do
mh <- readIORef ref
case mh of
Just h -> return h
Nothing -> mask_ $ do
createTree $ parent fp
h <- openBinaryFile (fpToString fp) WriteMode
writeIORef ref $ Just h
return h
inner' getH `finally` cleanup
configArgs = ($ []) $ execWriter $ do configArgs = ($ []) $ execWriter $ do
when pbAllowNewer $ tell' "--allow-newer" when pbAllowNewer $ tell' "--allow-newer"
@ -350,15 +364,15 @@ singleBuild pb@PerformBuild {..} registeredPackages SingleBuild {..} =
PackageConstraints {..} = ppConstraints $ piPlan sbPackageInfo PackageConstraints {..} = ppConstraints $ piPlan sbPackageInfo
buildLibrary = wf libOut $ \outH -> do buildLibrary = wf libOut $ \getOutH -> do
let run a b = do when pbVerbose $ log' (unwords (a : b)) let run a b = do when pbVerbose $ log' (unwords (a : b))
runChild outH a b runChild getOutH a b
isUnpacked <- newIORef False isUnpacked <- newIORef False
let withUnpacked inner = do let withUnpacked inner = do
unlessM (readIORef isUnpacked) $ do unlessM (readIORef isUnpacked) $ do
log' $ "Unpacking " ++ namever log' $ "Unpacking " ++ namever
runParent outH "cabal" ["unpack", namever] runParent getOutH "cabal" ["unpack", namever]
writeIORef isUnpacked True writeIORef isUnpacked True
inner inner
@ -440,8 +454,8 @@ singleBuild pb@PerformBuild {..} registeredPackages SingleBuild {..} =
return withUnpacked return withUnpacked
runTests withUnpacked = wf testOut $ \outH -> do runTests withUnpacked = wf testOut $ \getOutH -> do
let run = runChild outH let run = runChild getOutH
prevTestResult <- getPreviousResult pb Test pident prevTestResult <- getPreviousResult pb Test pident
let needTest = pbEnableTests let needTest = pbEnableTests