POpen, opening lots of processes

[Tomasz Zielonka]

On Thu, Jan 08, 2004 at 09:33:29AM -0800, Hal Daume III wrote:
> Hi,
> 
> I'm using POpen to shell out to a command several hundreds or thousands of 
> times per call (none of them simultaneous, though, this is completely 
> serial).  After running my program for a while, I get:
> 
> Fail: resource exhausted
> Action: forkProcess
> Reason: Resource temporarily unavailable
> 
> which basically seems to be telling me that the program hasn't been 
> closing the old processes, even though they're definitely not in use 
> anymore.
> 
> Does anyone have any suggestions how to get around this?

I had a similar problem, and finally I created my own solution that
doesn't leave zombies and doesn't block when the launched process writes
too much to stderr.

I tested it in GHC 6.0. For 6.2 you'd have to change the use of
forkProcess.

Usage:

  launch :: String -> [String] -> String -> IO (ProcessStatus, String, String)

  (status, out, err) <- launch prog args progInput

Example:

*Shell> (status, out, err) <- launch "tr" ["a-z", "A-Z"] 
				    (unlines (replicate 10000 "Haskell"))
*Shell> status
Exited ExitSuccess
*Shell> length out
80000
*Shell> mapM_ putStrLn (take 10 (lines out))
HASKELL
HASKELL
HASKELL
HASKELL
HASKELL
HASKELL
HASKELL
HASKELL
HASKELL
HASKELL

Best regards,
Tom

-- 
.signature: Too many levels of symbolic links
-------------- next part --------------

module Shell where

import System.Posix.Process
import System.Posix.IO
import Control.Concurrent
import IO

launch :: String -> [String] -> String -> IO (ProcessStatus, String, String)
launch prog args inputStr = do
    (childIn, parentIn) <- createPipe
    (parentOut, childOut) <- createPipe
    (parentErr, childErr) <- createPipe

    forkProcess >>= \pid -> case pid of
	Nothing -> do -- child
	    closeFd parentIn
	    closeFd parentOut
	    closeFd parentErr
	    closeFd 0 -- FIXME: What if some of 0,1,2 are already closed?
	    closeFd 1
	    closeFd 2
	    childIn `dupTo` 0
	    childOut `dupTo` 1
	    childErr `dupTo` 2
	    closeFd childIn
	    closeFd childOut
	    closeFd childErr
	    executeFile prog True args Nothing
	    fail "launch: executeFile failed"

	Just child -> do -- parent
	    closeFd childIn
	    closeFd childOut
	    closeFd childErr

	    input <- fdToHandle parentIn
	    output <- fdToHandle parentOut
	    err <- fdToHandle parentErr

	    outputCS <- hGetContents output
	    errCS <- hGetContents err

	    outputMV <- newEmptyMVar
	    errMV <- newEmptyMVar
	    inputMV <- newEmptyMVar

	    forkIO $ hPutStr input inputStr >> hClose input >> putMVar inputMV ()
	    forkIO $ foldr seq () outputCS `seq` hClose output >> putMVar outputMV ()
	    forkIO $ foldr seq () errCS `seq` hClose err >> putMVar errMV ()

	    takeMVar outputMV
	    takeMVar errMV
	    takeMVar inputMV

	    mStatus <- getProcessStatus True False child

	    case mStatus of
		Nothing -> fail "launch: can't get child process status"
		Just stat -> return (stat, outputCS, errCS)