I'm currently trying to port parts of the Windows API to Haskell. One of the functions covered is SetConsoleCtrlHandler which registers a handler callback that is called whenever a Ctrl+C or Ctrl+Break is received from console input. So here a small sample program:
{-# LANGUAGE CPP #-}
{-# LANGUAGE ForeignFunctionInterface #-}
module Main where
import Control.Monad
import GHC.ConsoleHandler
import Foreign
import System.Win32.Process
import System.Win32.Types
foreign import ccall "wrapper"
makeHandlerPtr :: (DWORD -> IO BOOL) -> IO (FunPtr (DWORD -> IO BOOL))
foreign import stdcall "windows.h SetConsoleCtrlHandler"
c_SetConsoleCtrlHandler :: FunPtr (DWORD -> IO BOOL) -> BOOL -> IO BOOL
main :: IO ()
main = unsafeCtrl
unsafeCtrl :: IO ()
unsafeCtrl = do
ptrHandler <- makeHandlerPtr $ \d -> do
putStrLn $ "received event " ++ show d
return True
c_SetConsoleCtrlHandler ptrHandler True
forM_ [1..50] $ \_ -> sleep 100
freeHaskellFunPtr ptrHandler
safeCtrl :: IO ()
safeCtrl = do
installHandler $ Catch $ \e -> do
putStrLn $ "received event " ++ show e
forM_ [1..50] $ \_ -> sleep 100
If you compile the above program via ghc --make AsyncCallback.hs and run the program, it crashes with the following error as soon as a control event is received:
$ AsyncCallback
AsyncCallback.exe: schedule: re-entered unsafely.
Perhaps a 'foreign import unsafe' should be 'safe'?
However, compiling with the -threaded option added seems to work fine:
$ AsyncCallback
received event 0
received event 1
received event 0
Not sure why this makes it work, as I don't explicitly use threads here, and I can't see where GHC would implicitly start a new thread.
Asking earlier about this on #haskell, someone noted that calling Haskell functions asynchronously from a C callback is inherently unsafe and that the above example just more or less coincidentally works. I was also pointed to GHC.ConsoleHandler.installHandler which seems to be a safe wrapper around SetConsoleCtrlHandler, and running the above program with main = safeCtrl indeed works fine. I tried to understand the implementation of installHandler (C-side and Haskell-side) but I don't quite get it.
The whole problem here seems to be that the callback is issued asynchronously, such that the Haskell RTS isn't "prepared" for when the callback tries to run the Haskell code. So I would like to know
How does the GHC implementation of installHandler work? What is the crucial part that makes that implementation work and my version fail?
Are there other options/general patterns how to call Haskell code asynchronously from a C callback? In this particular case, I can switch to the GHC implementation. But I may come accross similar C functions that asynchronously call back into Haskell code where I would have to write a safe binding on my own.
Related
I'm working with dbus in haskell, and I'm having difficulties figuring out how to export dbus methods that perform stateful operations. Below is a fully fleshed out example to illustrate where I'm stuck.
Let's say you're writing a counter service with dbus. When the service starts, the counter is initially at 0. The service defines a dbus API that exposes a count method, which returns the current value of the counter, and an update method, which increments that counter, and returns the new value.
Here's a pseudocodey implementation of the behavior I just described, using a message-passing-style of communication:
-- | Updates the given integer.
update :: Int -> Int
update = (+1)
-- | main function with message-passing-style communication
mainLoop :: Int -> IO Int
mainLoop state = do
case receiveMessage of
"update" -> do -- increment / update counter
sendReply $ update state
mainLoop $ update state -- recurse
"count" -> do -- return counter value
sendReply state
mainLoop state
"stop" -> do -- stop the counting service
exitSuccess
main :: IO ()
main = do
mainLoop 0
However, dbus uses method-calls, not message passing. So, I need to be able to export a count and update method that behaves the same way as in my message-passing example.
The stub we'll work with is something like this:
-- | Updates the given integer.
update :: Int -> Int
update = (+1)
main :: IO ()
main = do
let initialState = 0
dbus <- connectSession
export dbus "/org/counter/CounterService"
[ autoMethod "org.counter.CounterService" "update" ({-- call update? --})
, autoMethod "org.counter.CounterService" "count" ({-- return state? --}) ]
And here lies my question: How should I encode the missing {-- call update? --} and {-- return state? --} functions?
I know I can use an MVar to create global mutable state, and then just make the functions read from that, but I want to avoid mutability as much as possible here. I think I can do this with the Reader/State monad somehow, maybe by sneaking a get/ask into the functions, but I don't know how to handle the types with respect to DBus.
Ultimately, the dbus package only allows you to export methods of type Method, which has a methodHandler field that returns the monadic value:
DBusR Reply === ReaderT Client IO Reply
and there's no room in there for you to squeeze in your own StateT monad. You could export a Property instead, but that doesn't help you, since the fields of that type also involve IO actions to get and set the property.
So, maintaining your state in IO, most likely as an MVar, is going to be pretty much unavoidable.
You could try to separate your pure-ish "core" from the IO shell. One way to do it (as per #HTNW's comment) is to write the core in State:
type Counter = Int
update :: State Counter ()
update = modify (+1)
count :: State Counter Int
count = get
and lift it to IO with something like:
import Data.Tuple (swap)
runStateIO :: State s a -> MVar s -> IO a
runStateIO act s = modifyMVar s (return . swap . runState act)
main = do
...
s <- newMVar 0
let run act = runStateIO act s
export dbus "/com/example/CounterService"
defaultInterface
{ interfaceName = "com.example.CounterService"
, interfaceMethods =
[ autoMethod "update" (run update)
, autoMethod "count" (run count) ]
}
(I think I'm using a newer version of dbus here than you, since the API is a little different -- I'm testing with dbus-1.2.16, FYI.)
One potential drawback is that this is going to lock the state MVar on every method call, even if the call doesn't need the state or needs only read-only access. DBus services are typically pretty low-traffic with method calls that are intended to complete quickly, so I don't think this is a problem in practice.
Anyway, a here's a full working program, which I tested with:
dbus-send --print-reply --session --dest=com.example /com/example/CounterService com.example.CounterService.update
dbus-send --print-reply --session --dest=com.example /com/example/CounterService com.example.CounterService.count
The program:
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wall #-}
import System.IO
import System.Exit
import Data.Int
import DBus.Client
import Data.Tuple
import Control.Concurrent
import Control.Monad.State
type Counter = Int32
update :: State Counter ()
update = modify (+1)
count :: State Counter Int32
count = get
runStateIO :: State s a -> MVar s -> IO a
runStateIO act s = modifyMVar s (return . swap . runState act)
main :: IO ()
main = do
dbus <- connectSession
requestResult <- requestName dbus "com.example" []
when (requestResult /= NamePrimaryOwner) $ do
hPutStrLn stderr "Name \"com.example\" not available"
exitFailure
s <- newMVar 0
let run act = runStateIO act s
export dbus "/com/example/CounterService"
defaultInterface
{ interfaceName = "com.example.CounterService"
, interfaceMethods =
[ autoMethod "update" (run update)
, autoMethod "count" (run count) ]
}
forever $ threadDelay 60000000
I'm trying to follow along with the LLVM bindings tutorial here, and running into a segfault. The following code works in the sense that it prints a module header to output.ll, but it also segfaults somewhere.
module Main where
import Control.Monad.Error
import LLVM.General.Module
import LLVM.General.Context
import qualified LLVM.General.AST as AST
--Create and write out an empty LLVM module
main :: IO ()
main = writeModule (AST.defaultModule { AST.moduleName = "myModule" })
outputFile :: File
outputFile = File "output.ll"
writeModule :: AST.Module -> IO ()
writeModule mod = withContext $ (\context ->
liftError $ withModuleFromAST context mod (\m ->
liftError $ writeLLVMAssemblyToFile outputFile m))
--perform the action, or fail on an error
liftError :: ErrorT String IO a -> IO a
liftError = runErrorT >=> either fail return
I suspect this is related to the following hint from the linked tutorial:
It is very important to remember not to pass or attempt to use resources outside of the bracket as this will lead to undefined behavior and/or segfaults.
I think in this context the "bracket" is implemented by the withContext function, which makes it seem like everything should be handled.
If I change the definition of writeModule to
writeModule mod = do assembly <- (withContext $ (\context ->
liftError $ withModuleFromAST context mod moduleLLVMAssembly))
putStrLn assembly
that is, instead of writing to a file I just print out the string representation of the LLVM assembly, no segfault is thrown.
Does anyone have experience with these bindings? I'm also interested to know about the failure cases for the warning I quoted. That is, how would one "forget" not to use resources outside the bracket? All of the functions that seem to require a Context, well, require one. Isn't this kind of resource scoping issue exactly what Haskell is good at handling for you?
Version information:
llvm-general-3.4.3.0
LLVM version 3.4
Default target: x86_64-apple-darwin13.2.0
It would help if you shared your LLVM and cabal environment, LLVM is notorious for being backwards incompatible with itself so there might be an issue with using the latest versions of the bindings.
Behind the scenes writeLLVMAssemblyToFile is using a C++ call to do the file IO operation and I speculate that it's holding a reference to the LLVM module as a result of finalizing the file resource.
Try rendering the module to a String using moduleString and then only lifting into the IO monad to call writeFile from Haskell instead of going through C++ to the write.
import LLVM.General.Context
import LLVM.General.Module as Mod
import qualified LLVM.General.AST as AST
import Control.Monad.Error
main :: IO ()
main = do
writeModule (AST.defaultModule { AST.moduleName = "myModule" })
return ()
writeModule :: AST.Module -> IO (Either String ())
writeModule ast =
withContext $ \ctx ->
runErrorT $ withModuleFromAST ctx ast $ \m -> do
asm <- moduleString m
liftIO $ writeFile "output.ll" asm
The bindings can still rather brittle in my experience, you should ask on the issue tracker if the problem persists.
EDIT: This is a workaround for an old version that has been subsequently fixed. See: https://github.com/bscarlet/llvm-general/issues/109
Below is a Haskell/C FFI code that is throwing schedule error at runtime (GHC 7.0.3, Mac OS 10.7, x86_64). I searched for explanation of the error but didn't find anything relevant.
C Code (mt.c):
#include <pthread.h>
#include <stdio.h>
typedef void(*FunctionPtr)(int);
/* This is our thread function. It is like main(), but for a thread*/
void *threadFunc(void *arg)
{
FunctionPtr fn;
fn = (FunctionPtr) arg;
fn(1); //call haskell function with a CInt argument to see if it works
}
void create_threads(FunctionPtr* fp, int numThreads )
{
pthread_t pth[numThreads]; // array of pthreads
int t;
for (t=0; t < numThreads;){
pthread_create(&pth[t],NULL,threadFunc,*(fp + t));
t++;
}
printf("main waiting for all threads to terminate...\n");
for (t=0; t < numThreads;t++){
pthread_join(pth[t],NULL);
}
}
Haskell code (t.hs) - it calls create_threads in mt.c above with Storable Vector of FunPtr to Haskell function f (after applying first three arguments to f):
{-# LANGUAGE BangPatterns #-}
import Control.Concurrent (forkIO, threadDelay, MVar, newEmptyMVar, putMVar, takeMVar)
import qualified Data.Vector.Storable.Mutable as MSV
import qualified Data.Vector.Storable as SV
import Control.Monad.Primitive (PrimState)
import Control.Monad (mapM, forM_)
import Foreign.Ptr (Ptr, FunPtr)
import Foreign.C.Types (CInt)
type Length = CInt
-- | f is a function that is called back by create_threads in mt.c
f :: MVar Int -> MSV.MVector (PrimState IO) CInt -> Length -> CInt -> IO ()
f m v l x = do
!i <- takeMVar m
case (i< fromIntegral l) of
True -> MSV.unsafeWrite v i x >> print x >> putMVar m (i+1)
False -> return () -- overflow
-- a "wrapper" import gives us a converter for converting a Haskell function to a foreign function pointer
foreign import ccall "wrapper"
wrap :: (CInt -> IO()) -> IO (FunPtr (CInt -> IO()))
foreign import ccall safe "create_threads"
createThreads :: Ptr (FunPtr (CInt -> IO())) -> CInt -> IO()
main = do
let threads = [1..4]
m <- mapM (\x -> newEmptyMVar) $ threads
-- intialize mvars with 0
forM_ m $ \x -> putMVar x 0
let l = 10
-- intialize vectors of length 10 that will be filled by function f
v <- mapM (\x -> MSV.new l) threads
-- create a list of function pointers to partial function - the partial function is obtained by applying first three arguments to function f
lf <- mapM (\(x,y) -> wrap (f x y (fromIntegral l))) $ zip m v
-- convert above function list to a storable vector of function pointers
let fv = SV.fromList lf
-- call createThreads with storable vector of function pointers, and number of threads - createThreads will spawn threads which will use function pointers for callback
SV.unsafeWith fv $ \x -> createThreads x (fromIntegral $ length threads)
Please ignore unsafe parts in the code - my objective here is to test callback using Haskell FFI with multi-threaded C code. When I compile it, and run it, I get the error below:
$ ghc -O2 t.hs mt.c -lpthread
[1 of 1] Compiling Main ( t.hs, t.o )
Linking t ...
$ ./t
main waiting for all threads to terminate...
t: schedule: re-entered unsafely.
Perhaps a 'foreign import unsafe' should be 'safe'?
$ uname -a
Darwin desktop.local 11.2.0 Darwin Kernel Version 11.2.0: Tue Aug 9 20:54:00 PDT 2011; root:xnu-1699.24.8~1/RELEASE_X86_64 x86_64
$ ghc --version
The Glorious Glasgow Haskell Compilation System, version 7.0.3
The schedule error happens only if I have the C threads call back haskell function f. I guess it is more likely there is a bug in my code, than there is a bug in one of the libraries or GHC. So, I will like to check here first for pointers on cause of the error.
In this case, the schedule error happened because the haskell code was compiled without -threaded option.
The haskell code is calling C function create_threads which spawns multiple threads for threadFunc C function. threadFunc calls back into Haskell function f. So, even though Haskell code is compiled without -threaded option, it still results in multiple C threads executing f.
It was a good catch by GHC Runtime Scheduler to detect this oversight of executing multiple threads without threaded runtime, and mark it as error. That is much better than a cryptic run-time crash. I realized the oversight when I checked rts/schedule.c code in GHC code base, and saw the comment below. It tipped me off about threaded runtime not being enabled:
// Check whether we have re-entered the RTS from Haskell without
// going via suspendThread()/resumeThread (i.e. a 'safe' foreign
// call).
It seems desirable to create a FunPtr to a top-level function just once instead of creating a new one (to the same function) whenever it's needed and dealing with its deallocation.
Am I overlooking some way to obtain the FunPtr other than foreign import ccall "wrapper"? If not, my workaround would be as in the code below. Is that safe?
type SomeCallback = CInt -> IO ()
foreign import ccall "wrapper" mkSomeCallback :: SomeCallback -> IO (FunPtr SomeCallback)
f :: SomeCallback
f i = putStrLn ("It is: "++show i)
{-# NOINLINE f_FunPtr #-}
f_FunPtr :: FunPtr SomeCallback
f_FunPtr = unsafePerformIO (mkSomeCallback f)
Edit: Verified that the "creating a new one every time" variant (main = forever (mkSomeCallback f)) does in fact leak memory if one doesn't freeHaskellFunPtr it.
This should, in principle, be safe - GHC internal code uses a similar pattern to initialize singletons such as the IO watched-handles queues. Just keep in mind that you have no control over when mkSomeCallback runs, and don't forget the NOINLINE.
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 :).