I have some simple code which prints to the screen at fixed intervals of time, unless an IORef is set to indicate that the user is currently typing:
import Data.IORef
import Control.Concurrent
main = do
amTyping <- newIORef False
forkIO $ printALot amTyping
aChar <- getChar
writeIORef amTyping True
aLine <- getLine
writeIORef amTyping False
putStrLn $ aChar : aLine
main
printALot :: IORef Bool -> IO ()
printALot theRef = do
putStrLn "1111111"
threadDelay 1000000
isTyping <- readIORef theRef
if isTyping
then return ()
else printALot theRef
This works beautifully in GHCi, but when I use it with runghc (or compile it), the read of or write to the IORef seems not to work -- printALot just continues looping, overrunning anything the user types.
What's the difference here between ghci and runghc/compiled? Am I using IORefs wrong, but not noticing because ghci isn't truly multithreaded?
This has nothing to do with concurrency.
Your interpreted and compiled programs differ in the terminal mode they use: non-canonical vs canonical.
In the canonical mode, your program doesn't get the character before the whole line is available — hence the effect you are observing.
To fix this, simply put the handle in the non-buffering mode:
import System.IO
main = do
hSetBuffering stdin NoBuffering
...
Related
I want to make an "asynchronous" reading of stdin for a few seconds. The way I am doing if is by forking getContents and writing to a Chan. After 5 seconds, I kill the thread and read the channel.
From my understading, the code below should just print whatever is in chan and terminate, but it keeps waiting for input and ^C must be pressed to finish. This is the behaviour you have when doing getContents >>= print on its own, so I have two guesses and no clue about each:
The thread is not killed and getContent keep running asking for more input
Something weird is happening with multithreading (see considerations below)
-- OS: Ubuntu 22.04.1 LTS
-- Gnome Terminal
-- ghc 9.2.5
import Control.Concurrent.Chan ( newChan, readChan, writeChan, Chan )
import Control.Concurrent (threadDelay, forkIO, killThread)
import System.IO (getContents, BufferMode (..), stdin, hSetBuffering)
main :: IO ()
main = do
hSetBuffering stdin NoBuffering
chan <- newChan
putStrLn "start"
threadId <- forkIO $ getContents >>= writeChan chan
threadDelay 5000000
putStrLn "\nend"
killThread threadId
a <- readChan chan
print a
Some considerations:
Using getLine make it work only if Enter is pressed. But I'd like to just "stream" stdin into the channel
hSetBuffering stdin NoBuffering is neccessary, otherwise the programm hangs (I guess waiting for end of input?)
Using getContents' cause a thread blocked indefinitely in an MVar operation, which up to the documentation is due to the channel being empty. I guess getContents' actually never terminates.
Last but most importantly, the behaviour is different depending on the compilation parameters:
ghc -threaded main.hs && ./main +RTS -N2 wont print anything and will hang until ^C is pressed (same thing with -N1, -N3, etc...)
runghc main.hs will actually print whatever has being the stdin during the 5 seconds (i.e. whatever is in chan) and then hang.
Just to clarify. Here are the ouputs:
> runghc main.hs
start
abc # user input
end
"abc^C" # ^C is done manually, to termiante the program and the last \" is for formatting purpose
> ghc -threaded main.hs && ./main +RTS -N2
start
abc # user input
end
^C # ^C is done manually, to termiante the program
So the question is simple. How do I make my program to end?
The thread getContents >>= writeChan chan is not an infinite loop that constantly adds content to chan. getContents creates a thunk, which is put in chan, and the thread terminates near instantaneously. Then in the main thread readChan gets that thunk, and print a forces it. It's the forcing of the thunk which prompts reading stdin, hence your program just blocks for more input until EOF or it gets killed.
What you want to do is to explicitly take small bits of input and write them into the channel. However, in the main thread, the channel does not give you a way to tell when it's ended. A workaround is to use an IORef String instead as a channel. Write to it by explicitly appending to the stored string, and readIORef will give you whatever content was written so far.
import Control.Concurrent.Chan ( newChan, readChan, writeChan, Chan )
import Control.Concurrent (threadDelay, forkIO, killThread)
import Control.Monad (forever)
import Data.IORef
import System.IO (getContents, BufferMode (..), stdin, hSetBuffering)
main :: IO ()
main = do
hSetBuffering stdin NoBuffering
buf <- newIORef []
putStrLn "start"
threadId <- forkIO $ forever $ do
c <- getChar
atomicModifyIORef' buf (\cs -> (c : cs, ()))
threadDelay 5000000
putStrLn "\nend"
killThread threadId
a <- reverse <$> readIORef buf
print a
The next simple code works fine in GHCi (the window with graphics appears), but after compiling in GHC, when one run it from command line, nothing happens. Why is it so?
import Graphics.Gnuplot.Simple
main :: IO ()
main = do
plotFunc [] (linearScale 1000 (-10.0::Double,10.0)) (\x -> x^2)
GHC 8.2.2
gnuplot 0.5.5.1
Don't exit your program immediately after opening the window, since that will close it down.
For instance, wait for the user:
import Graphics.Gnuplot.Simple
main :: IO ()
main = do
plotFunc [] (linearScale 1000 (-10.0::Double,10.0)) (\x -> x^2)
putStrLn "Press enter to exit."
getLine
return ()
Your best bet is to switch from Graphics.Gnuplot.Simple to Graphics.Gnuplot.Advanced. You can use plotSync to wait for GNUPlot to exit. I don't think plotAsync has much to offer, since it doesn't offer a way to wait for the thread it creates. Here's a better version:
myPlotAsync
:: (Terminal.C terminal, Display.C gfx)
=> terminal -> gfx -> IO (ThreadId, MVar ExitStatus)
myPlotAsync term gfx = do
resultMV <- newEmptyMVar
tid <- forkIO $ plotSync term gfx
>>= putMVar resultMV
`onException` putMVar resultMV ExitSuccess
pure (tid, resultMV)
After your program calls myPlotAsync, it can do whatever else it needs to do and then call readMVar on the MVar to wait for GNUPlot to exit and get its exit status. It also has the option of holding on to the thread ID so it can kill the GNUPlot thread using throwTo.
I'm writing a simple script to run bunch of tasks in parallel using the Shelly library but I want to limit the max number of tasks running at any one time. The script takes a file with an input on each line and runs a task for that input. There are a few hundred inputs in the file and I want to limit to around 16 processes at a time.
The current script actually limits to 1 (well tries to) using a QSem with an initial count of 1. I seem to be missing something though because when I run on a test file with 4 inputs I see this:
Starting
Starting
Starting
Starting
Done
Done
Done
Done
So the threads are not blocking on the QSem as I would expect, they're all running simultaneously. I've even gone so far as to implement my own semaphores both on MVar and TVar and neither worked the way I expected. I'm obviously missing something fundamental but what? I've also tried compiling the code and running it as a binary.
#!/usr/bin/env runhaskell
{-# LANGUAGE TemplateHaskell, QuasiQuotes, DeriveDataTypeable, OverloadedStrings #-}
import Shelly
import Prelude hiding (FilePath)
import Text.Shakespeare.Text (lt)
import qualified Data.Text.Lazy as LT
import Control.Monad (forM)
import System.Environment (getArgs)
import qualified Control.Concurrent.QSem as QSem
import Control.Concurrent (forkIO, MVar, putMVar, newEmptyMVar, takeMVar)
-- Define max number of simultaneous processes
maxProcesses :: IO QSem.QSem
maxProcesses = QSem.newQSem 1
bkGrnd :: ShIO a -> ShIO (MVar a)
bkGrnd proc = do
mvar <- liftIO newEmptyMVar
_ <- liftIO $ forkIO $ do
-- Block until there are free processes
sem <- maxProcesses
QSem.waitQSem sem
putStrLn "Starting"
-- Run the shell command
result <- shelly $ silently proc
liftIO $ putMVar mvar result
putStrLn "Done"
-- Signal that this process is done and another can run.
QSem.signalQSem sem
return mvar
main :: IO ()
main = shelly $ silently $ do
[img, file] <- liftIO $ getArgs
contents <- readfile $ fromText $ LT.pack file
-- Run a backgrounded process for each line of input.
results <- forM (LT.lines contents) $ \line -> bkGrnd $ do
runStdin <command> <arguments>
liftIO $ mapM_ takeMVar results
As I said in my comment, each call to bkGrnd creates its own semaphonre, allowing every thread to continue without waiting. I would try something like this instead, where the semaphore is created in the main and passed each time to bkGrnd.
bkGrnd :: QSem.QSem -> ShIO a -> ShIO (MVar a)
bkGrnd sem proc = do
mvar <- liftIO newEmptyMVar
_ <- liftIO $ forkIO $ do
-- Block until there are free processes
QSem.waitQSem sem
--
-- code continues as before
--
main :: IO ()
main = shelly $ silently $ do
[img, file] <- liftIO $ getArgs
contents <- readfile $ fromText $ LT.pack file
sem <- maxProcesses
-- Run a backgrounded process for each line of input.
results <- forM (LT.lines contents) $ \line -> bkGrnd sem $ do
runStdin <command> <arguments>
liftIO $ mapM_ takeMVar results
You have an answer, but I need to add: QSem and QSemN are not thread safe if killThread or asynchronous thread death is possible.
My bug report and patch are GHC trac ticket #3160. The fixed code is available as a new library called SafeSemaphore with module Control.Concurrent.MSem, MSemN, MSampleVar, and a bonus FairRWLock.
Isn't it better
bkGrnd sem proc = do
QSem.waitQSem sem
mvar <- liftIO newEmptyMVar
_ <- liftIO $ forkIO $ do
...
so not even forkIO until you get the semaphore?
I'm using
import Control.Concurrent.ParallelIO.Global
main = parallel_ (map processI [1..(sdNumber runParameters)]) >> stopGlobalPool
where
processI :: Int -> IO ()
is some function, which reads data from file, processes it and writes it to another file. No output to terminal. The problem is when I run the program with +RTS -N8 the terminal is flooded with random text like
piptufuht teata thtsieieo ocnsno e nscsdeoe qnqvuduee ernvnstetiirioasanlil lolwynya. .s
w
a s s uY Ysosopuuue's'nvpvdeeee n dpdp rerdodoub beada
bub lel y
What is happening? Without +RTS there is no clutter. I couldn't reproduce the behavior with a more simple (suitable to post here) program.
GHC 7.0.3 if that matters
Buffering is probably preventing you from constructing a simple test case. I was able to reproduce it with this (only when run with +RTS -Nsomething):
import Control.Concurrent
import System.IO
main :: IO ()
main = do
hSetBuffering stdout NoBuffering
forkIO $ putStrLn "foo"
forkIO $ putStrLn "bar"
forkIO $ putStrLn "baz"
threadDelay 1000 -- Allow things to print
As Thomas mentioned, you'll probably need to sequence this somehow, though I'm not sure how writing straight to files would change this. Here's a simple example how you can sequence this with a Chan. I'm sure there's a better way to do this, this is just an example of how I got this to not garble the output.
import Control.Concurrent
import Control.Concurrent.Chan
import System.IO
main :: IO ()
main = do
hSetBuffering stdout NoBuffering
ch <- newChan -- Things written here are picked up by stuffWriter
forkIO $ stuffWriter ch -- Fire up concurrent stuffWriter
forkIO $ writeChan ch "foo"
forkIO $ writeChan ch "bar"
forkIO $ writeChan ch "baz"
threadDelay 1000 -- Allow things to print
-- | Write all the things!
stuffWriter :: Chan String -> IO ()
stuffWriter ch = do
readChan ch >>= putStrLn -- Block, then write once I've got something
stuffWriter ch -- loop... looking for more things to write
Now your writes to somewhere are now synchronous (stuffWriter writes things, one at a time), and you should have no more garbling.
I built a really simple read-eval-print-loop in Haskell that catches Control-C (UserInterrupt). However, whenever I compile and run this program, it always catches the first Control-C and always aborts on the second Control-C with exit code 130. It doesn't matter how many lines of input I give it before and between the two Control-Cs, it always happens this way. I know I must be missing something simple... please help, thanks!
Note: this is with base-4 exceptions, so Control.Exception and not Control.OldException.
import Control.Exception as E
import System.IO
main :: IO ()
main = do hSetBuffering stdout NoBuffering
hSetBuffering stdin NoBuffering
repLoop
repLoop :: IO ()
repLoop
= do putStr "> "
line <- interruptible "<interrupted>" getLine
if line == "exit"
then putStrLn "goodbye"
else do putStrLn $ "input was: " ++ line
repLoop
interruptible :: a -> IO a -> IO a
interruptible a m
= E.handleJust f return m
where
f UserInterrupt
= Just a
f _
= Nothing
Wei Hu is correct; the Haskell runtime system deliberately aborts the program when a second control-C is pressed. To get the behavior one might expect:
import Control.Exception as E
import Control.Concurrent
import System.Posix.Signals
main = do
tid <- myThreadId
installHandler keyboardSignal (Catch (throwTo tid UserInterrupt)) Nothing
... -- rest of program
Disclaimer: I'm not familiar with GHC internals and my answer is based on grepping the source code, reading the comments, and making guesses.
The main function you define is in fact wrapped by runMainIO defined in GHC.TopHandler (this is further confirmed by looking at TcRnDriver.lhs):
-- | 'runMainIO' is wrapped around 'Main.main' (or whatever main is
-- called in the program). It catches otherwise uncaught exceptions,
-- and also flushes stdout\/stderr before exiting.
runMainIO :: IO a -> IO a
runMainIO main =
do
main_thread_id <- myThreadId
weak_tid <- mkWeakThreadId main_thread_id
install_interrupt_handler $ do
m <- deRefWeak weak_tid
case m of
Nothing -> return ()
Just tid -> throwTo tid (toException UserInterrupt)
a <- main
cleanUp
return a
`catch`
topHandler
And install_interrupt_handler is defined as:
install_interrupt_handler :: IO () -> IO ()
#ifdef mingw32_HOST_OS
install_interrupt_handler handler = do
_ <- GHC.ConsoleHandler.installHandler $
Catch $ \event ->
case event of
ControlC -> handler
Break -> handler
Close -> handler
_ -> return ()
return ()
#else
#include "rts/Signals.h"
-- specialised version of System.Posix.Signals.installHandler, which
-- isn't available here.
install_interrupt_handler handler = do
let sig = CONST_SIGINT :: CInt
_ <- setHandler sig (Just (const handler, toDyn handler))
_ <- stg_sig_install sig STG_SIG_RST nullPtr
-- STG_SIG_RST: the second ^C kills us for real, just in case the
-- RTS or program is unresponsive.
return ()
On Linux, stg_sig_install is a C function that calls out to sigaction. The parameter STG_SIG_RST is translated to SA_RESETHAND. On Windows, things are done differently, which probably explains ja's observation.
The most reliable solution for me (at least on Linux), has been to install a signal handler using System.Posix.Signals. I was hoping for a solution that would not require this, but the real reason I posted the question was that I wanted to know why GHC behaved the way it did. As explained on #haskell, a likely explanation is that GHC behaves this way so that the user can always Control-C an application if it hangs. Still, it would be nice if GHC provided a way to affect this behavior without the somewhat lower-level method that we resorted to :).