ghci: fix ^C handling for wasm iserv

This commit fixes ^C handling for wasm iserv. Previously we didn't
handle it at all, so ^C would kill the node process and host ghc would
then crash as well. But native ghc with external interpreter can
handle ^C just fine and wasm should be no different. Hence the fix:
wasm iserv exports its signal handler as a js callback to be handled
by the dyld script. Also see added note for details.

(cherry picked from commit fa2fbd2b)
(cherry picked from commit 6797c0a4)

libraries/ghci/GHCi/Server.hs

@@ -7,6 +7,7 @@ where
 
 import Prelude
 import GHCi.Run
+import GHCi.Signals
 import GHCi.TH
 import GHCi.Message
 #if defined(wasm32_HOST_ARCH)
@@ -19,7 +20,6 @@ import Foreign
 import Foreign.ForeignPtr.Unsafe
 import GHC.Wasm.Prim
 #else
-import GHCi.Signals
 import GHCi.Utils
 #endif
 
@@ -107,8 +107,8 @@ serv verbose hook pipe restore = loop
 
 -- | Default server
 #if defined(wasm32_HOST_ARCH)
-defaultServer :: Callback (IO JSUint8Array) -> Callback (JSUint8Array -> IO ()) -> IO ()
-defaultServer cb_recv cb_send = do
+defaultServer :: Callback (JSVal -> IO ()) -> Callback (IO JSUint8Array) -> Callback (JSUint8Array -> IO ()) -> IO ()
+defaultServer cb_sig cb_recv cb_send = do
   args <- getArgs
   let rest = args
 #else
@@ -136,6 +136,8 @@ defaultServer = do
     dieWithUsage
 
 #if defined(wasm32_HOST_ARCH)
+  -- See Note [wasm ghci signal handlers] for details
+  installSignalHandlers $ js_register_signal_handler cb_sig
   pipe <- mkPipeFromContinuations (recv_buf cb_recv) (send_buf cb_send)
 #else
   when verbose $
@@ -186,6 +188,9 @@ send_buf cb b = do
   buf <- evaluate $ LB.toStrict $ B.toLazyByteString b
   B.unsafeUseAsCStringLen buf $ \(ptr, len) -> js_send_buf cb ptr len
 
+foreign import javascript unsafe "dynamic"
+  js_register_signal_handler :: Callback (JSVal -> IO ()) -> JSVal -> IO ()
+
 foreign import javascript "dynamic"
   js_recv_buf :: Callback (IO JSUint8Array) -> IO JSUint8Array
 
@@ -199,6 +204,6 @@ foreign import javascript unsafe "$1(new Uint8Array(__exports.memory.buffer, $2,
   js_send_buf :: Callback (JSUint8Array -> IO ()) -> Ptr a -> Int -> IO ()
 
 foreign export javascript "defaultServer"
-  defaultServer :: Callback (IO JSUint8Array) -> Callback (JSUint8Array -> IO ()) -> IO ()
+  defaultServer :: Callback (JSVal -> IO ()) -> Callback (IO JSUint8Array) -> Callback (JSUint8Array -> IO ()) -> IO ()
 
 #endif

libraries/ghci/GHCi/Signals.hs

@@ -6,7 +6,9 @@ import Control.Concurrent
 import Control.Exception
 import System.Mem.Weak  ( deRefWeak )
 
-#if !defined(mingw32_HOST_OS)
+#if defined(wasm32_HOST_ARCH)
+import GHC.Wasm.Prim
+#elif !defined(mingw32_HOST_OS)
 import System.Posix.Signals
 #endif
 
@@ -18,8 +20,13 @@ import GHC.ConsoleHandler
 --   exception in the target thread.  The current target thread is the
 --   thread at the head of the list in the MVar passed to
 --   installSignalHandlers.
+#if defined(wasm32_HOST_ARCH)
+installSignalHandlers :: (JSVal -> IO ()) -> IO ()
+installSignalHandlers cb_sig = do
+#else
 installSignalHandlers :: IO ()
 installSignalHandlers = do
+#endif
   main_thread <- myThreadId
   wtid <- mkWeakThreadId main_thread
 
@@ -29,7 +36,9 @@ installSignalHandlers = do
           Nothing -> return ()
           Just t  -> throwTo t UserInterrupt
 
-#if !defined(mingw32_HOST_OS)
+#if defined(wasm32_HOST_ARCH)
+  cb_sig =<< js_export_signal_handler interrupt
+#elif !defined(mingw32_HOST_OS)
   _ <- installHandler sigQUIT  (Catch interrupt) Nothing
   _ <- installHandler sigINT   (Catch interrupt) Nothing
 #else
@@ -45,3 +54,34 @@ installSignalHandlers = do
   _ <- installHandler (Catch sig_handler)
 #endif
   return ()
+
+#if defined(wasm32_HOST_ARCH)
+
+-- Note [wasm ghci signal handlers]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- For native ghc with -fexternal-interpreter, when you press ^C,
+-- SIGINT is delivered to both ghc/iserv. iserv SIGINT handler raises
+-- an async UserInterrupt exception in the main thread, which might
+-- handle it right away, or later since it's doing I/O under
+-- uninterruptibleMask.
+--
+-- wasm is no different here. The node process needs to catch the same
+-- signals. Instead of calling process.on('SIGINT', handler) in
+-- Haskell via JSFFI, we pass a JS callback that registers the handler
+-- from iserv main, export the Haskell handler to JS, then invoke the
+-- callback to register the handler. This allows iserv to be run in
+-- non-nodejs environments as well, and the dyld script can pass a
+-- handler register callback other than process.on().
+--
+-- IMPORTANT: THE SIGNAL HANDLER MUST BE EXPORTED AS ASYNC!!!!!!!
+-- Otherwise, throwTo may block the handler thread, so the handler
+-- thread is removed from the run queue. Since the main thread may
+-- also be absent from the run queue (e.g. blocked on waiting for
+-- input message), the run queue is empty and then the RTS scheduler
+-- panics.
+
+foreign import javascript "wrapper"
+  js_export_signal_handler :: IO () -> IO JSVal
+
+#endif

utils/jsffi/dyld.mjs

@@ -714,6 +714,11 @@ if (isMain()) {
   const reader = in_stream.getReader();
   const writer = out_stream.getWriter();
 
+  const cb_sig = (cb) => {
+    process.on("SIGINT", cb);
+    process.on("SIGQUIT", cb);
+  };
+
   const cb_recv = async () => {
     const { done, value } = await reader.read();
     if (done) {
@@ -725,5 +730,5 @@ if (isMain()) {
     writer.write(new Uint8Array(buf));
   };
 
-  await dyld.exportFuncs.defaultServer(cb_recv, cb_send);
+  await dyld.exportFuncs.defaultServer(cb_sig, cb_recv, cb_send);
 }