From 0286be3d4c17ba1b1f9ad772d363dc86458c985d Mon Sep 17 00:00:00 2001 From: Rewbert Date: Thu, 23 Apr 2026 14:17:57 +0200 Subject: [PATCH 01/16] Linux support for non-blocking IO --- lib/Control/Concurrent.hs | 11 +-- lib/Primitives.hs | 6 ++ lib/System/IO/FD.hs | 9 +++ lib/base.cabal | 1 + src/MicroHs/Translate.hs | 2 + src/runtime/eval.c | 155 +++++++++++++++++++++++++++++++++++++- src/runtime/unix/config.h | 9 +++ tests/Makefile | 8 +- tests/NonBlockIO.hs | 84 +++++++++++++++++++++ tests/NonBlockIO.ref | 4 + 10 files changed, 281 insertions(+), 8 deletions(-) create mode 100644 lib/System/IO/FD.hs create mode 100644 tests/NonBlockIO.hs create mode 100644 tests/NonBlockIO.ref diff --git a/lib/Control/Concurrent.hs b/lib/Control/Concurrent.hs index 7e65bc650..90ba7ac9e 100644 --- a/lib/Control/Concurrent.hs +++ b/lib/Control/Concurrent.hs @@ -119,11 +119,12 @@ threadStatus thr = do st <- primThreadStatus thr return $ case st of - 0 -> ThreadRunning -- ts_runnable - 1 -> ThreadBlocked BlockedOnMVar -- ts_wait_mvar - 2 -> ThreadBlocked BlockedOnOther -- ts_wait_time - 3 -> ThreadFinished -- ts_finished - 4 -> ThreadDied -- ts_died + 0 -> ThreadRunning -- ts_runnable + 1 -> ThreadBlocked BlockedOnMVar -- ts_wait_mvar + 2 -> ThreadBlocked BlockedOnOther -- ts_wait_time + 3 -> ThreadFinished -- ts_finished + 4 -> ThreadDied -- ts_died + 5 -> ThreadBlocked BlockedOnForeignCall -- ts_wait_io ------------------------------------------------------- -- Just for GHC compatibility. diff --git a/lib/Primitives.hs b/lib/Primitives.hs index b61e5b43b..d0c31081f 100644 --- a/lib/Primitives.hs +++ b/lib/Primitives.hs @@ -389,6 +389,12 @@ primTryPutMVar = _primitive "IO.tryputmvar" primTryReadMVar :: MVar a -> IO b {-(Maybe a)-} primTryReadMVar = _primitive "IO.tryreadmvar" +primWaitWriteFD :: Int -> IO () +primWaitWriteFD = _primitive "IO.waitwrfd" + +primWaitReadFD :: Int -> IO () +primWaitReadFD = _primitive "IO.waitrdfd" + primThreadDelay :: Int -> IO () primThreadDelay = _primitive "IO.threaddelay" diff --git a/lib/System/IO/FD.hs b/lib/System/IO/FD.hs new file mode 100644 index 000000000..c21d54fac --- /dev/null +++ b/lib/System/IO/FD.hs @@ -0,0 +1,9 @@ +module System.IO.FD (waitForReadFD, waitForWriteFD) where + +import Primitives + +waitForReadFD :: Int -> IO () +waitForReadFD = primWaitReadFD + +waitForWriteFD :: Int -> IO () +waitForWriteFD = primWaitWriteFD \ No newline at end of file diff --git a/lib/base.cabal b/lib/base.cabal index 252916aa7..9f49399c2 100644 --- a/lib/base.cabal +++ b/lib/base.cabal @@ -190,6 +190,7 @@ library base System.Environment System.Exit System.IO + System.IO.FD System.IO.Error System.IO.MD5 System.IO.PrintOrRun diff --git a/src/MicroHs/Translate.hs b/src/MicroHs/Translate.hs index 295211039..78f8618e0 100644 --- a/src/MicroHs/Translate.hs +++ b/src/MicroHs/Translate.hs @@ -272,6 +272,8 @@ primTable = [ ("bs2fp", _primitive "bs2fp"), ("IO.fork", _primitive "IO.fork"), ("IO.thid", _primitive "IO.thid"), + ("IO.waitrdfd", _primitive "IO.waitrdfd"), + ("IO.waitwrfd", _primitive "IO.waitwrfd"), ("thnum", _primitive "thnum"), ("IO.throwto", _primitive "IO.throwto"), ("IO.yield", _primitive "IO.yield"), diff --git a/src/runtime/eval.c b/src/runtime/eval.c index b17753f94..ac64eccb0 100644 --- a/src/runtime/eval.c +++ b/src/runtime/eval.c @@ -43,6 +43,10 @@ #if WANT_SIGINT #include #endif +#if MHS_EPOLL_IO +#include +#include +#endif extern char **environ; /* should probably be behind some WANT_ */ @@ -126,6 +130,13 @@ int num_ffi; #define THREAD_DEBUG 0 #endif +#if MHS_EPOLL_IO +static int epoll_fd = -1; /* Global EPOLL descriptor */ +static int io_waiters = 0; /* How many green threads are waiting for events */ +static void init_epoll(void); +static void poll_io(int timeout_ms); +#endif + #define VERSION "v8.3\n" #define PRIvalue PRIdPTR @@ -542,6 +553,9 @@ enum node_tag { T_FREE, T_IND, T_AP, T_INT, T_INT64, T_DBL, T_FLT32, T_PTR, T_FU T_WKNEWFIN, T_WKNEW, T_WKDEREF, T_WKFINAL, T_IO_PP, /* for debugging */ T_IO_STDIN, T_IO_STDOUT, T_IO_STDERR, +#if MHS_EPOLL_IO + T_IO_WAITRDFD, T_IO_WAITWRFD, +#endif T_LAST_TAG, }; @@ -899,7 +913,16 @@ dump_tick_table(FILE *f) enum th_sched { mt_main, mt_resched, mt_raise }; /* The two enums below are known by the Haskell code. Do not change order */ -enum th_state { ts_runnable, ts_wait_mvar, ts_wait_time, ts_finished, ts_died }; +enum th_state { + ts_runnable, + ts_wait_mvar, + ts_wait_time, + ts_finished, + ts_died, +#if MHS_EPOLL_IO + ts_wait_io, /* not visible to Haskell; must stay after ts_died */ +#endif +}; enum mask_state { mask_unmasked, mask_interruptible, mask_uninterruptible }; /***************** HANDLER *****************/ @@ -924,6 +947,10 @@ struct mthread { NODEPTR mt_mval; /* filled after waiting for take/read */ bool mt_mark; /* marked as accessible */ uvalue_t mt_id; /* thread number, thread 1 is the main thread */ +#if MHS_EPOLL_IO + int mt_fd; /* The file descriptor that we are waiting on (-1 means none, -2 means we've already registered it) */ + uint32_t mt_events; /* EPOLLIN or EPOLLOUT, depending on read or write */ +#endif #if defined(CLOCK_INIT) CLOCK_T mt_at; /* time to wake up when in threadDelay */ #endif @@ -1302,7 +1329,16 @@ yield(void) check_timeq(); check_thrown(false); check_sigint(); - // printf("yield %p %d\n", runq, (int)stack_ptr); + +#if MHS_EPOLL_IO + if(io_waiters > 0) { + /* Check if any threads blocked on IO can be scheduled. Since we pass in a delay of 0, checking + for the events should not block. */ + poll_io(0); + } +#endif + +// printf("yield %p %d\n", runq, (int)stack_ptr); /* if there is nothing after in the runq then there is no need to reschedule */ if (!runq.mq_head->mt_queue) { #if THREAD_DEBUG @@ -1347,6 +1383,10 @@ new_thread(NODEPTR root) mt->mt_mark = false; mt->mt_num_slices = 0; mt->mt_id = num_thread_create++; +#if MHS_EPOLL_IO + mt->mt_fd = -1; + mt->mt_events = -1; +#endif #if defined(CLOCK_INIT) mt->mt_at = 0; /* delay has not expired */ #endif @@ -1599,6 +1639,42 @@ thread_delay(uvalue_t usecs) void pause_exec(void) { +/* End up here if the run queue is empty. If there is no thread waiting for +a delay to expire, we will never resume operation and we are deadlocked. However, if +we compile with MHS_EPOLL_IO there might be threads waiting for IO events, so in +that case we check for them as well. If there is no thread waiting for a delay or an +IO event, we are deadlocked. */ +#if MHS_EPOLL_IO + + /* Check for deadlock situation */ + if(io_waiters == 0 +#if defined(CLOCK_INIT) + && !timeq.mq_head +#endif + ) ERR("deadlock"); + + /* Loop until at least one thread is runnable.*/ + while (!runq.mq_head) { + int timeout_ms = -1; /* block indefinitely if only io_waiters */ +#if defined(CLOCK_INIT) + /* If there are threads blocked on delays, recompute the timeout_ms to account + for that. */ + if(timeq.mq_head) { + CLOCK_T delta = timeq.mq_head->mt_at - CLOCK_GET(); + /* +999 emulates a ceiling function, adding at most 0.999 ms. epoll_wait wants milliseconds, not + microseconds as delta represents. When delta is < 1000, without +999, we'll truncate to zero and + enter a loop at full CPU speed. I am not sure we want to call poll_io/epoll that many times. */ + timeout_ms = (delta > 0) ? (int)((delta + 999) / 1000) : 0; + } +#endif + poll_io(timeout_ms); +#if defined(CLOCK_INIT) + check_timeq(); +#endif + } + +#else /* !MHS_EPOLL_IO */ + #if defined(CLOCK_INIT) if (timeq.mq_head) { struct mthread *mt; @@ -1636,6 +1712,7 @@ pause_exec(void) #else /* CLOCK_INIT */ ERR("no clock"); #endif /* CLOCK_INIT */ +#endif /* MHS_EPOLL_IO */ } /* Interrupt a sleeping thread in a throwTo/threadDelay */ @@ -1823,6 +1900,30 @@ new_ap(NODEPTR f, NODEPTR a) return n; } +#if MHS_EPOLL_IO +/* Initialise the epoll nonsense. I call this once during startup. */ +static void init_epoll(void) { + epoll_fd = epoll_create1(EPOLL_CLOEXEC); + if (epoll_fd < 0) { + ERR("epoll_create1 failed"); + } +} + +/* Poll for IO events */ +// If timeout_ms is 0, this is non-blocking. If anything else, there +// is a period of blocking. +static void poll_io(int timeout_ms) { + struct epoll_event evs[64]; + int n = epoll_wait(epoll_fd, evs, 64, timeout_ms); + for(int i = 0; i < n; i++) { + struct mthread *mt = evs[i].data.ptr; + mt->mt_fd = -2; /* We test for -2 when the thread is woken up (in the eval loop), so we don't re-register it */ + io_waiters--; + add_runq_tail(mt); /* Here, we mark the thread as runnable again */ + } +} +#endif + NODEPTR evali(NODEPTR n); /* If this is non-0 it means that the threading system is active. */ @@ -1837,6 +1938,10 @@ start_exec(NODEPTR root) mt->mt_id = MAIN_THREAD; /* make it the main thread in case this is foreign export calling */ main_thread = mt; +#if MHS_EPOLL_IO + init_epoll(); +#endif + switch(setjmp(sched)) { case mt_main: break; @@ -2173,6 +2278,10 @@ struct { { "binbs1", T_BINBS1 }, { "unint1", T_UNINT1 }, { "undbl1", T_UNDBL1 }, +#if MHS_EPOLL_IO + { "IO.waitrdfd", T_IO_WAITRDFD}, + { "IO.waitwrfd", T_IO_WAITWRFD}, +#endif #if WANT_INT64 { "I+", T_ADD64, T_ADD64 }, { "I-", T_SUB64, T_SUBR64 }, @@ -5996,6 +6105,48 @@ evali(NODEPTR an) POP(2); GOPAIR(mkInt(mt->mt_state)); } +#if MHS_EPOLL_IO + case T_IO_WAITRDFD: + case T_IO_WAITWRFD: { + CHKARG2NP; /* x = the filedescriptor, y = RealWorld; no pop yet */ + + /* poll_io sets mt_fd=-2 when waking the thread. By seeing if it is -2 here we + can learn that our registered event has happened and we can return unit. If + we did not do this check we would just register again. + + This seems to be how T_IO_THREADDELAY works, with mt_at == -1. + */ + if (runq.mq_head->mt_fd == -2) { + runq.mq_head->mt_fd = -1; + POP(2); + GOPAIRUNIT; + } + + POP(2); + int fd = evalint(x); // initially I used GETVALUE(x) here, but that did not work. + // I assumed it had to do with lazyness, and the change to evalint + // seems to have fixed it. + uint32_t events = (tag == T_IO_WAITRDFD) ? EPOLLIN : EPOLLOUT; + events |= EPOLLONESHOT; + + /* Set up the waiting threads state, preparing it for going out + of the run queue until an event is ready for it */ + struct mthread *mt = remove_q_head(&runq); + mt->mt_fd = fd; + mt->mt_events = events; + mt->mt_state = ts_wait_io; + + /* Register the event with EPOLL */ + struct epoll_event ev = { .events = events, .data.ptr = mt }; + int err = 0; + if ((err = epoll_ctl(epoll_fd, EPOLL_CTL_ADD, fd, &ev)) < 0) { + ERR("epoll_ctl ADD failed"); + } + io_waiters++; + + resched(mt, ts_wait_io); + } +#endif case T_IO_GETMASKINGSTATE: CHKARG1; /* x = ST */ GOPAIR(mkInt(runq.mq_head->mt_mask)); diff --git a/src/runtime/unix/config.h b/src/runtime/unix/config.h index d3658ef71..4b68cf7f9 100644 --- a/src/runtime/unix/config.h +++ b/src/runtime/unix/config.h @@ -84,6 +84,15 @@ */ #define WANT_OVERFLOW 1 +/* + * use epoll for non-blocking IO (Linux only; macOS lacks epoll) + */ +#if defined(__linux__) +#define MHS_EPOLL_IO 1 +#else +#define MHS_EPOLL_IO 0 +#endif + /* * Use CPU counters. * Only available on: diff --git a/tests/Makefile b/tests/Makefile index 072e65f23..c23cb575e 100644 --- a/tests/Makefile +++ b/tests/Makefile @@ -4,8 +4,9 @@ MHS=../bin/gmhs TMHS=$(MHS) $(MHSTARGET) $(MHSOUTPUT) EVAL=../bin/mhseval +RTS -H1M -RTS .PHONY: test nfib clean errtest alltest cache info +UNAME_S := $(shell uname -s) -alltest: info test errtest testforimp testforexp testforimpexp testapplysp +alltest: info test errtest testforimp testforexp testforimpexp testapplysp testnonblockio # interactivetest cache: @@ -138,6 +139,11 @@ testforimpexp: testapplysp: $(TMHS) -optc -I. ApplySP hsasp.c -oApplySP.exe && ./ApplySP.exe > ApplySP.out && diff ApplySP.ref ApplySP.out +testnonblockio: +ifeq ($(UNAME_S),Linux) + MHSDIR=.. $(TMHS) -oNonBlockIO.exe NonBlockIO && ./NonBlockIO.exe > NonBlockIO.out && diff NonBlockIO.ref NonBlockIO.out +endif + errtest: sh errtester.sh $(MHS) < errmsg.test diff --git a/tests/NonBlockIO.hs b/tests/NonBlockIO.hs new file mode 100644 index 000000000..a2e816f6e --- /dev/null +++ b/tests/NonBlockIO.hs @@ -0,0 +1,84 @@ +module NonBlockIO where + +import Control.Concurrent +import Data.Word +import Foreign.C.Error +import Foreign.C.Types +import Foreign.Marshal.Alloc +import Foreign.Ptr +import Foreign.Storable +import System.IO.FD + +foreign import ccall "socket" c_socket :: CInt -> CInt -> CInt -> IO CInt +foreign import ccall "setsockopt" c_setsockopt :: CInt -> CInt -> CInt -> Ptr CInt -> CInt -> IO CInt +foreign import ccall "bind" c_bind :: CInt -> Ptr Word8 -> CInt -> IO CInt +foreign import ccall "listen" c_listen :: CInt -> CInt -> IO CInt +foreign import ccall "accept" c_accept :: CInt -> Ptr Word8 -> Ptr CInt -> IO CInt +foreign import ccall "htons" htons :: Word16 -> Word16 + +-- some wonderful Linux constants + +aFINET :: CInt +aFINET = 2 + +sOLSOCKET :: CInt +sOLSOCKET = 1 + +sOCKSTREAM :: CInt +sOCKSTREAM = 1 + +sOCKNONBLOCK :: CInt +sOCKNONBLOCK = 0x800 + +sOREUSEADDR :: CInt +sOREUSEADDR = 2 + +-- open and configure a socket. Important that it is set to O_NONBLOCK + +openServerSocket :: Word16 -> IO CInt +openServerSocket port = do + fd <- c_socket aFINET (sOCKSTREAM + sOCKNONBLOCK) 0 + + alloca $ \p -> do + poke p (1 :: CInt) + c_setsockopt fd sOLSOCKET sOREUSEADDR p 4 + return () + + -- struct sockaddr_in, configuring this to AF_INET + allocaBytes 16 $ \p -> do + mapM_ (\i -> pokeByteOff p i (0 :: Word8)) [0..15] + pokeByteOff p 0 (2 :: Word8) + pokeByteOff p 2 (fromIntegral (htons port `div` 256) :: Word8) + pokeByteOff p 3 (fromIntegral (htons port `mod` 256) :: Word8) + c_bind fd p 16 + return () + + c_listen fd 1 + + return fd + +blockOnAccept :: CInt -> IO () +blockOnAccept fd = do + r <- c_accept fd nullPtr nullPtr + if r /= -1 then return () else do -- O_NONBLOCK, now it returns straight away + errno <- getErrno + if errno == eAGAIN || errno == eWOULDBLOCK + then do + waitForReadFD (fromIntegral fd) -- this makes the runtime block, but using epoll, allowing other green threads to run + blockOnAccept fd -- when we run this, we were woken up by epoll and the accept call should now work + else throwErrno "accept" + +server :: IO () +server = do + fd <- openServerSocket 19876 + putStrLn "server: listening, blocking on accept" + blockOnAccept fd + +main :: IO () +main = do + forkIO server + yield -- yielding, letting the server thread run and printing its message + let tick = putStrLn "tick" >> threadDelay 1000000 + tick + tick + tick diff --git a/tests/NonBlockIO.ref b/tests/NonBlockIO.ref new file mode 100644 index 000000000..63120385b --- /dev/null +++ b/tests/NonBlockIO.ref @@ -0,0 +1,4 @@ +server: listening, blocking on accept +tick +tick +tick From 8434f6f1215056e341d7c777e34b122b011cbe2d Mon Sep 17 00:00:00 2001 From: Rewbert Date: Thu, 23 Apr 2026 14:59:09 +0200 Subject: [PATCH 02/16] remove conditional execution of test --- tests/Makefile | 3 --- 1 file changed, 3 deletions(-) diff --git a/tests/Makefile b/tests/Makefile index c23cb575e..737acc1cd 100644 --- a/tests/Makefile +++ b/tests/Makefile @@ -4,7 +4,6 @@ MHS=../bin/gmhs TMHS=$(MHS) $(MHSTARGET) $(MHSOUTPUT) EVAL=../bin/mhseval +RTS -H1M -RTS .PHONY: test nfib clean errtest alltest cache info -UNAME_S := $(shell uname -s) alltest: info test errtest testforimp testforexp testforimpexp testapplysp testnonblockio # interactivetest @@ -140,9 +139,7 @@ testapplysp: $(TMHS) -optc -I. ApplySP hsasp.c -oApplySP.exe && ./ApplySP.exe > ApplySP.out && diff ApplySP.ref ApplySP.out testnonblockio: -ifeq ($(UNAME_S),Linux) MHSDIR=.. $(TMHS) -oNonBlockIO.exe NonBlockIO && ./NonBlockIO.exe > NonBlockIO.out && diff NonBlockIO.ref NonBlockIO.out -endif errtest: sh errtester.sh $(MHS) < errmsg.test From 2f04f882928b3f660f054c05984a199b9b5eac26 Mon Sep 17 00:00:00 2001 From: Rewbert Date: Thu, 23 Apr 2026 15:05:08 +0200 Subject: [PATCH 03/16] refactor to prepare for implementations for the other platforms --- src/runtime/eval.c | 98 ++++++++++-------------------- src/runtime/io_poll.h | 20 ++++++ src/runtime/unix/config.h | 10 +-- src/runtime/unix/io_poll_epoll.c | 58 ++++++++++++++++++ src/runtime/unix/io_poll_impl.c | 15 +++++ src/runtime/unix/io_poll_kqueue.c | 10 +++ src/runtime/windows/io_poll_impl.c | 9 +++ src/runtime/windows/io_poll_iocp.c | 10 +++ 8 files changed, 160 insertions(+), 70 deletions(-) create mode 100644 src/runtime/io_poll.h create mode 100644 src/runtime/unix/io_poll_epoll.c create mode 100644 src/runtime/unix/io_poll_impl.c create mode 100644 src/runtime/unix/io_poll_kqueue.c create mode 100644 src/runtime/windows/io_poll_impl.c create mode 100644 src/runtime/windows/io_poll_iocp.c diff --git a/src/runtime/eval.c b/src/runtime/eval.c index ac64eccb0..8bc1d62e3 100644 --- a/src/runtime/eval.c +++ b/src/runtime/eval.c @@ -43,9 +43,8 @@ #if WANT_SIGINT #include #endif -#if MHS_EPOLL_IO -#include -#include +#if MHS_IO_POLL +#include "io_poll.h" #endif extern char **environ; /* should probably be behind some WANT_ */ @@ -130,12 +129,6 @@ int num_ffi; #define THREAD_DEBUG 0 #endif -#if MHS_EPOLL_IO -static int epoll_fd = -1; /* Global EPOLL descriptor */ -static int io_waiters = 0; /* How many green threads are waiting for events */ -static void init_epoll(void); -static void poll_io(int timeout_ms); -#endif #define VERSION "v8.3\n" @@ -553,7 +546,7 @@ enum node_tag { T_FREE, T_IND, T_AP, T_INT, T_INT64, T_DBL, T_FLT32, T_PTR, T_FU T_WKNEWFIN, T_WKNEW, T_WKDEREF, T_WKFINAL, T_IO_PP, /* for debugging */ T_IO_STDIN, T_IO_STDOUT, T_IO_STDERR, -#if MHS_EPOLL_IO +#if MHS_IO_POLL T_IO_WAITRDFD, T_IO_WAITWRFD, #endif T_LAST_TAG, @@ -919,7 +912,7 @@ enum th_state { ts_wait_time, ts_finished, ts_died, -#if MHS_EPOLL_IO +#if MHS_IO_POLL ts_wait_io, /* not visible to Haskell; must stay after ts_died */ #endif }; @@ -947,9 +940,9 @@ struct mthread { NODEPTR mt_mval; /* filled after waiting for take/read */ bool mt_mark; /* marked as accessible */ uvalue_t mt_id; /* thread number, thread 1 is the main thread */ -#if MHS_EPOLL_IO - int mt_fd; /* The file descriptor that we are waiting on (-1 means none, -2 means we've already registered it) */ - uint32_t mt_events; /* EPOLLIN or EPOLLOUT, depending on read or write */ +#if MHS_IO_POLL + int mt_fd; /* The file descriptor that we are waiting on (-1 means none, -2 means we've already been woken) */ + int mt_events; /* IO_POLL_READ or IO_POLL_WRITE */ #endif #if defined(CLOCK_INIT) CLOCK_T mt_at; /* time to wake up when in threadDelay */ @@ -1330,11 +1323,11 @@ yield(void) check_thrown(false); check_sigint(); -#if MHS_EPOLL_IO - if(io_waiters > 0) { +#if MHS_IO_POLL + if (io_waiter_count() > 0) { /* Check if any threads blocked on IO can be scheduled. Since we pass in a delay of 0, checking for the events should not block. */ - poll_io(0); + io_poll(0); } #endif @@ -1383,7 +1376,7 @@ new_thread(NODEPTR root) mt->mt_mark = false; mt->mt_num_slices = 0; mt->mt_id = num_thread_create++; -#if MHS_EPOLL_IO +#if MHS_IO_POLL mt->mt_fd = -1; mt->mt_events = -1; #endif @@ -1641,13 +1634,13 @@ pause_exec(void) { /* End up here if the run queue is empty. If there is no thread waiting for a delay to expire, we will never resume operation and we are deadlocked. However, if -we compile with MHS_EPOLL_IO there might be threads waiting for IO events, so in +we compile with MHS_IO_POLL there might be threads waiting for IO events, so in that case we check for them as well. If there is no thread waiting for a delay or an IO event, we are deadlocked. */ -#if MHS_EPOLL_IO +#if MHS_IO_POLL /* Check for deadlock situation */ - if(io_waiters == 0 + if (io_waiter_count() == 0 #if defined(CLOCK_INIT) && !timeq.mq_head #endif @@ -1659,21 +1652,21 @@ IO event, we are deadlocked. */ #if defined(CLOCK_INIT) /* If there are threads blocked on delays, recompute the timeout_ms to account for that. */ - if(timeq.mq_head) { + if (timeq.mq_head) { CLOCK_T delta = timeq.mq_head->mt_at - CLOCK_GET(); - /* +999 emulates a ceiling function, adding at most 0.999 ms. epoll_wait wants milliseconds, not - microseconds as delta represents. When delta is < 1000, without +999, we'll truncate to zero and - enter a loop at full CPU speed. I am not sure we want to call poll_io/epoll that many times. */ + /* +999 emulates a ceiling function, adding at most 0.999 ms. io_poll wants milliseconds, + not microseconds as delta represents. When delta is < 1000, without +999, we'll truncate + to zero and enter a loop at full CPU speed. */ timeout_ms = (delta > 0) ? (int)((delta + 999) / 1000) : 0; } #endif - poll_io(timeout_ms); + io_poll(timeout_ms); #if defined(CLOCK_INIT) check_timeq(); #endif } -#else /* !MHS_EPOLL_IO */ +#else /* !MHS_IO_POLL */ #if defined(CLOCK_INIT) if (timeq.mq_head) { @@ -1712,7 +1705,7 @@ IO event, we are deadlocked. */ #else /* CLOCK_INIT */ ERR("no clock"); #endif /* CLOCK_INIT */ -#endif /* MHS_EPOLL_IO */ +#endif /* MHS_IO_POLL */ } /* Interrupt a sleeping thread in a throwTo/threadDelay */ @@ -1900,28 +1893,8 @@ new_ap(NODEPTR f, NODEPTR a) return n; } -#if MHS_EPOLL_IO -/* Initialise the epoll nonsense. I call this once during startup. */ -static void init_epoll(void) { - epoll_fd = epoll_create1(EPOLL_CLOEXEC); - if (epoll_fd < 0) { - ERR("epoll_create1 failed"); - } -} - -/* Poll for IO events */ -// If timeout_ms is 0, this is non-blocking. If anything else, there -// is a period of blocking. -static void poll_io(int timeout_ms) { - struct epoll_event evs[64]; - int n = epoll_wait(epoll_fd, evs, 64, timeout_ms); - for(int i = 0; i < n; i++) { - struct mthread *mt = evs[i].data.ptr; - mt->mt_fd = -2; /* We test for -2 when the thread is woken up (in the eval loop), so we don't re-register it */ - io_waiters--; - add_runq_tail(mt); /* Here, we mark the thread as runnable again */ - } -} +#if MHS_IO_POLL +#include "io_poll_impl.c" #endif NODEPTR evali(NODEPTR n); @@ -1938,8 +1911,8 @@ start_exec(NODEPTR root) mt->mt_id = MAIN_THREAD; /* make it the main thread in case this is foreign export calling */ main_thread = mt; -#if MHS_EPOLL_IO - init_epoll(); +#if MHS_IO_POLL + io_init(); #endif switch(setjmp(sched)) { @@ -2278,7 +2251,7 @@ struct { { "binbs1", T_BINBS1 }, { "unint1", T_UNINT1 }, { "undbl1", T_UNDBL1 }, -#if MHS_EPOLL_IO +#if MHS_IO_POLL { "IO.waitrdfd", T_IO_WAITRDFD}, { "IO.waitwrfd", T_IO_WAITWRFD}, #endif @@ -6105,12 +6078,12 @@ evali(NODEPTR an) POP(2); GOPAIR(mkInt(mt->mt_state)); } -#if MHS_EPOLL_IO +#if MHS_IO_POLL case T_IO_WAITRDFD: case T_IO_WAITWRFD: { CHKARG2NP; /* x = the filedescriptor, y = RealWorld; no pop yet */ - /* poll_io sets mt_fd=-2 when waking the thread. By seeing if it is -2 here we + /* io_poll sets mt_fd=-2 when waking the thread. By seeing if it is -2 here we can learn that our registered event has happened and we can return unit. If we did not do this check we would just register again. @@ -6126,23 +6099,16 @@ evali(NODEPTR an) int fd = evalint(x); // initially I used GETVALUE(x) here, but that did not work. // I assumed it had to do with lazyness, and the change to evalint // seems to have fixed it. - uint32_t events = (tag == T_IO_WAITRDFD) ? EPOLLIN : EPOLLOUT; - events |= EPOLLONESHOT; + int events = (tag == T_IO_WAITRDFD) ? IO_POLL_READ : IO_POLL_WRITE; - /* Set up the waiting threads state, preparing it for going out - of the run queue until an event is ready for it */ + /* Set up the waiting thread's state, preparing it to leave the run queue + until an event is ready for it */ struct mthread *mt = remove_q_head(&runq); mt->mt_fd = fd; mt->mt_events = events; mt->mt_state = ts_wait_io; - /* Register the event with EPOLL */ - struct epoll_event ev = { .events = events, .data.ptr = mt }; - int err = 0; - if ((err = epoll_ctl(epoll_fd, EPOLL_CTL_ADD, fd, &ev)) < 0) { - ERR("epoll_ctl ADD failed"); - } - io_waiters++; + io_register(fd, events, mt); resched(mt, ts_wait_io); } diff --git a/src/runtime/io_poll.h b/src/runtime/io_poll.h new file mode 100644 index 000000000..fa7737f7a --- /dev/null +++ b/src/runtime/io_poll.h @@ -0,0 +1,20 @@ +/* Copyright 2026 Robert Krook + * See LICENSE file for full license. + */ + +/* + * OS-agnostic interface for non-blocking IO polling. + * Platform-specific implementations live in /io_poll_impl.c and + * are included into eval.c via #include "io_poll_impl.c". + * + */ + +#define IO_POLL_READ 1 +#define IO_POLL_WRITE 2 + +struct mthread; /* forward declaration; full definition is in eval.c */ + +void io_init(void); +void io_poll(int timeout_ms); +void io_register(int fd, int events, struct mthread *mt); +int io_waiter_count(void); diff --git a/src/runtime/unix/config.h b/src/runtime/unix/config.h index 4b68cf7f9..038cad044 100644 --- a/src/runtime/unix/config.h +++ b/src/runtime/unix/config.h @@ -85,12 +85,14 @@ #define WANT_OVERFLOW 1 /* - * use epoll for non-blocking IO (Linux only; macOS lacks epoll) + * Enable non-blocking IO polling. + * Linux uses epoll; macOS uses kqueue (not yet implemented). + * The backend is selected in unix/io_poll_impl.c. */ -#if defined(__linux__) -#define MHS_EPOLL_IO 1 +#if defined(__linux__) || (defined(__APPLE__) && defined(__MACH__)) +#define MHS_IO_POLL 1 #else -#define MHS_EPOLL_IO 0 +#define MHS_IO_POLL 0 #endif /* diff --git a/src/runtime/unix/io_poll_epoll.c b/src/runtime/unix/io_poll_epoll.c new file mode 100644 index 000000000..ea2a89ee1 --- /dev/null +++ b/src/runtime/unix/io_poll_epoll.c @@ -0,0 +1,58 @@ +/* Copyright 2026 Robert Krook + * See LICENSE file for full license. + */ + +/* + * epoll backend for non-blocking IO polling (Linux only). + * This file is #included into eval.c via io_poll_impl.c, so it has + * access to all definitions in eval.c (struct mthread, add_runq_tail, etc.). + */ + +#include +#include + +static int epoll_fd = -1; +static int io_waiters = 0; + +void +io_init(void) +{ + epoll_fd = epoll_create1(EPOLL_CLOEXEC); + if (epoll_fd < 0) { + ERR("epoll_create1 failed"); + } +} + +/* If timeout_ms is 0 this is a non-blocking check; otherwise it blocks up to + timeout_ms milliseconds (or indefinitely when timeout_ms == -1). */ +void +io_poll(int timeout_ms) +{ + struct epoll_event evs[64]; + int n = epoll_wait(epoll_fd, evs, 64, timeout_ms); + for (int i = 0; i < n; i++) { + struct mthread *mt = evs[i].data.ptr; + mt->mt_fd = -2; /* signal "already woken" to the eval loop */ + io_waiters--; + add_runq_tail(mt); + } +} + +/* Register fd to wake mt when the requested event is ready. + events is IO_POLL_READ or IO_POLL_WRITE. */ +void +io_register(int fd, int events, struct mthread *mt) +{ + uint32_t ev_flags = (events == IO_POLL_READ ? EPOLLIN : EPOLLOUT) | EPOLLONESHOT; + struct epoll_event ev = { .events = ev_flags, .data.ptr = mt }; + if (epoll_ctl(epoll_fd, EPOLL_CTL_ADD, fd, &ev) < 0) { + ERR("epoll_ctl ADD failed"); + } + io_waiters++; +} + +int +io_waiter_count(void) +{ + return io_waiters; +} diff --git a/src/runtime/unix/io_poll_impl.c b/src/runtime/unix/io_poll_impl.c new file mode 100644 index 000000000..5cf870fee --- /dev/null +++ b/src/runtime/unix/io_poll_impl.c @@ -0,0 +1,15 @@ +/* Copyright 2026 Robert Krook + * See LICENSE file for full license. + */ + +/* + * Selects the platform-specific IO poll backend for Unix targets. + */ + +#if defined(__linux__) +#include "io_poll_epoll.c" +#elif defined(__APPLE__) && defined(__MACH__) +#include "io_poll_kqueue.c" +#else +#error "No IO poll backend available for this platform" +#endif diff --git a/src/runtime/unix/io_poll_kqueue.c b/src/runtime/unix/io_poll_kqueue.c new file mode 100644 index 000000000..6430948df --- /dev/null +++ b/src/runtime/unix/io_poll_kqueue.c @@ -0,0 +1,10 @@ +/* Copyright 2026 Robert Krook + * See LICENSE file for full license. + */ + +/* + * kqueue backend for non-blocking IO polling (macOS / BSD). + * Not yet implemented. + */ + +#error "kqueue IO poll backend not yet implemented for this platform" diff --git a/src/runtime/windows/io_poll_impl.c b/src/runtime/windows/io_poll_impl.c new file mode 100644 index 000000000..34840c96d --- /dev/null +++ b/src/runtime/windows/io_poll_impl.c @@ -0,0 +1,9 @@ +/* Copyright 2026 Robert Krook + * See LICENSE file for full license. + */ + +/* + * Selects the platform-specific IO poll backend for Windows. + */ + +#include "io_poll_iocp.c" diff --git a/src/runtime/windows/io_poll_iocp.c b/src/runtime/windows/io_poll_iocp.c new file mode 100644 index 000000000..a72c0f554 --- /dev/null +++ b/src/runtime/windows/io_poll_iocp.c @@ -0,0 +1,10 @@ +/* Copyright 2026 Robert Krook + * See LICENSE file for full license. + */ + +/* + * IOCP backend for non-blocking IO polling (Windows). + * Not yet implemented. + */ + +#error "IOCP IO poll backend not yet implemented for Windows" From 0b1e26e862b3581f880936f46a6bbe60708126b8 Mon Sep 17 00:00:00 2001 From: Rewbert Date: Thu, 23 Apr 2026 15:08:13 +0200 Subject: [PATCH 04/16] mac variant, generated --- src/runtime/unix/io_poll_kqueue.c | 61 ++++++++++++++++++++++++++++++- 1 file changed, 59 insertions(+), 2 deletions(-) diff --git a/src/runtime/unix/io_poll_kqueue.c b/src/runtime/unix/io_poll_kqueue.c index 6430948df..8fd6ee8fa 100644 --- a/src/runtime/unix/io_poll_kqueue.c +++ b/src/runtime/unix/io_poll_kqueue.c @@ -4,7 +4,64 @@ /* * kqueue backend for non-blocking IO polling (macOS / BSD). - * Not yet implemented. + * This file is #included into eval.c via io_poll_impl.c, so it has + * access to all definitions in eval.c (struct mthread, add_runq_tail, etc.). */ -#error "kqueue IO poll backend not yet implemented for this platform" +#include +#include +#include + +static int kqueue_fd = -1; +static int io_waiters = 0; + +void +io_init(void) +{ + kqueue_fd = kqueue(); + if (kqueue_fd < 0) { + ERR("kqueue failed"); + } +} + +/* If timeout_ms is 0 this is a non-blocking check; otherwise it blocks up to + timeout_ms milliseconds (or indefinitely when timeout_ms == -1). */ +void +io_poll(int timeout_ms) +{ + struct kevent evs[64]; + struct timespec ts; + struct timespec *tsp = NULL; + if (timeout_ms >= 0) { + ts.tv_sec = timeout_ms / 1000; + ts.tv_nsec = (long)(timeout_ms % 1000) * 1000000L; + tsp = &ts; + } + int n = kevent(kqueue_fd, NULL, 0, evs, 64, tsp); + for (int i = 0; i < n; i++) { + struct mthread *mt = evs[i].udata; + mt->mt_fd = -2; /* signal "already woken" to the eval loop */ + io_waiters--; + add_runq_tail(mt); + } +} + +/* Register fd to wake mt when the requested event is ready. + events is IO_POLL_READ or IO_POLL_WRITE. */ +void +io_register(int fd, int events, struct mthread *mt) +{ + struct kevent ev; + int16_t filter = (events == IO_POLL_READ) ? EVFILT_READ : EVFILT_WRITE; + EV_SET(&ev, fd, filter, EV_ADD | EV_ONESHOT, 0, 0, mt); + if (kevent(kqueue_fd, &ev, 1, NULL, 0, NULL) < 0) { + ERR("kevent ADD failed"); + } + io_waiters++; +} + +int +io_waiter_count(void) +{ + return io_waiters; +} From 463d224524ccf99fd94031897d32ce5ed7d66b3d Mon Sep 17 00:00:00 2001 From: Rewbert Date: Thu, 23 Apr 2026 16:37:48 +0200 Subject: [PATCH 05/16] make test better --- tests/NonBlockIO.hs | 64 ++++++++++++++++++++++----------------------- 1 file changed, 32 insertions(+), 32 deletions(-) diff --git a/tests/NonBlockIO.hs b/tests/NonBlockIO.hs index a2e816f6e..eecd5677b 100644 --- a/tests/NonBlockIO.hs +++ b/tests/NonBlockIO.hs @@ -9,32 +9,24 @@ import Foreign.Ptr import Foreign.Storable import System.IO.FD -foreign import ccall "socket" c_socket :: CInt -> CInt -> CInt -> IO CInt -foreign import ccall "setsockopt" c_setsockopt :: CInt -> CInt -> CInt -> Ptr CInt -> CInt -> IO CInt -foreign import ccall "bind" c_bind :: CInt -> Ptr Word8 -> CInt -> IO CInt -foreign import ccall "listen" c_listen :: CInt -> CInt -> IO CInt -foreign import ccall "accept" c_accept :: CInt -> Ptr Word8 -> Ptr CInt -> IO CInt -foreign import ccall "htons" htons :: Word16 -> Word16 - --- some wonderful Linux constants - -aFINET :: CInt -aFINET = 2 - -sOLSOCKET :: CInt -sOLSOCKET = 1 - -sOCKSTREAM :: CInt -sOCKSTREAM = 1 - -sOCKNONBLOCK :: CInt -sOCKNONBLOCK = 0x800 - -sOREUSEADDR :: CInt -sOREUSEADDR = 2 - --- open and configure a socket. Important that it is set to O_NONBLOCK - +foreign import ccall "sys/socket.h socket" c_socket :: CInt -> CInt -> CInt -> IO CInt +foreign import ccall "sys/socket.h setsockopt" c_setsockopt :: CInt -> CInt -> CInt -> Ptr CInt -> CInt -> IO CInt +foreign import ccall "sys/socket.h bind" c_bind :: CInt -> Ptr Word8 -> CInt -> IO CInt +foreign import ccall "sys/socket.h listen" c_listen :: CInt -> CInt -> IO CInt +foreign import ccall "sys/socket.h accept" c_accept :: CInt -> Ptr Word8 -> Ptr CInt -> IO CInt +foreign import ccall "htons" htons :: Word16 -> Word16 + +-- Platform constants pulled from the system headers instead of hardcoded Linux values. +foreign import capi "sys/socket.h value AF_INET" aFINET :: CInt +foreign import capi "sys/socket.h value SOL_SOCKET" sOLSOCKET :: CInt +foreign import capi "sys/socket.h value SOCK_STREAM" sOCKSTREAM :: CInt +foreign import capi "sys/socket.h value SOCK_NONBLOCK" sOCKNONBLOCK :: CInt +foreign import capi "sys/socket.h value SO_REUSEADDR" sOREUSEADDR :: CInt + +-- ismacos is provided by the MHS runtime (returns non-zero on macOS/Darwin). +foreign import ccall "ismacos" ismacos :: IO CInt + +-- open and configure a socket. Important that it is set to O_NONBLOCK. openServerSocket :: Word16 -> IO CInt openServerSocket port = do fd <- c_socket aFINET (sOCKSTREAM + sOCKNONBLOCK) 0 @@ -44,10 +36,18 @@ openServerSocket port = do c_setsockopt fd sOLSOCKET sOREUSEADDR p 4 return () - -- struct sockaddr_in, configuring this to AF_INET + -- Build struct sockaddr_in (16 bytes). + -- On Linux: [sin_family: uint16_t at 0][sin_port: uint16_t at 2]... + -- On macOS: [sin_len: uint8_t at 0][sin_family: uint8_t at 1][sin_port: uint16_t at 2]... + mac <- ismacos allocaBytes 16 $ \p -> do mapM_ (\i -> pokeByteOff p i (0 :: Word8)) [0..15] - pokeByteOff p 0 (2 :: Word8) + if mac /= 0 + then do + pokeByteOff p 0 (16 :: Word8) -- sin_len = sizeof(sockaddr_in) + pokeByteOff p 1 (2 :: Word8) -- sin_family = AF_INET + else + pokeByteOff p 0 (2 :: Word8) -- sin_family low byte (LE uint16_t) pokeByteOff p 2 (fromIntegral (htons port `div` 256) :: Word8) pokeByteOff p 3 (fromIntegral (htons port `mod` 256) :: Word8) c_bind fd p 16 @@ -60,12 +60,12 @@ openServerSocket port = do blockOnAccept :: CInt -> IO () blockOnAccept fd = do r <- c_accept fd nullPtr nullPtr - if r /= -1 then return () else do -- O_NONBLOCK, now it returns straight away + if r /= -1 then return () else do -- O_NONBLOCK, returns immediately when no client errno <- getErrno if errno == eAGAIN || errno == eWOULDBLOCK then do - waitForReadFD (fromIntegral fd) -- this makes the runtime block, but using epoll, allowing other green threads to run - blockOnAccept fd -- when we run this, we were woken up by epoll and the accept call should now work + waitForReadFD (fromIntegral fd) -- block via epoll/kqueue, letting other threads run + blockOnAccept fd -- woken up by epoll/kqueue, retry accept else throwErrno "accept" server :: IO () @@ -77,7 +77,7 @@ server = do main :: IO () main = do forkIO server - yield -- yielding, letting the server thread run and printing its message + yield -- let the server thread run and print its message let tick = putStrLn "tick" >> threadDelay 1000000 tick tick From e1c0f4f337196bd1ae9423d35c5fcbafc3ea789a Mon Sep 17 00:00:00 2001 From: Rewbert Date: Thu, 23 Apr 2026 20:18:37 +0200 Subject: [PATCH 06/16] test --- src/runtime/unix/io_poll_epoll.c | 3 +++ tests/NonBlockIO.hs | 20 ++++++++++++++------ 2 files changed, 17 insertions(+), 6 deletions(-) diff --git a/src/runtime/unix/io_poll_epoll.c b/src/runtime/unix/io_poll_epoll.c index ea2a89ee1..cd1f51aab 100644 --- a/src/runtime/unix/io_poll_epoll.c +++ b/src/runtime/unix/io_poll_epoll.c @@ -32,6 +32,9 @@ io_poll(int timeout_ms) int n = epoll_wait(epoll_fd, evs, 64, timeout_ms); for (int i = 0; i < n; i++) { struct mthread *mt = evs[i].data.ptr; + /* EPOLLONESHOT disables but does not remove the fd; delete it now so + that a subsequent io_register on the same fd can use EPOLL_CTL_ADD. */ + epoll_ctl(epoll_fd, EPOLL_CTL_DEL, mt->mt_fd, NULL); mt->mt_fd = -2; /* signal "already woken" to the eval loop */ io_waiters--; add_runq_tail(mt); diff --git a/tests/NonBlockIO.hs b/tests/NonBlockIO.hs index eecd5677b..1a11b6a40 100644 --- a/tests/NonBlockIO.hs +++ b/tests/NonBlockIO.hs @@ -15,21 +15,29 @@ foreign import ccall "sys/socket.h bind" c_bind :: CInt -> Ptr Word8 foreign import ccall "sys/socket.h listen" c_listen :: CInt -> CInt -> IO CInt foreign import ccall "sys/socket.h accept" c_accept :: CInt -> Ptr Word8 -> Ptr CInt -> IO CInt foreign import ccall "htons" htons :: Word16 -> Word16 +foreign import ccall "fcntl.h fcntl" c_fcntl_setfl :: CInt -> CInt -> CInt -> IO CInt -- Platform constants pulled from the system headers instead of hardcoded Linux values. -foreign import capi "sys/socket.h value AF_INET" aFINET :: CInt -foreign import capi "sys/socket.h value SOL_SOCKET" sOLSOCKET :: CInt -foreign import capi "sys/socket.h value SOCK_STREAM" sOCKSTREAM :: CInt -foreign import capi "sys/socket.h value SOCK_NONBLOCK" sOCKNONBLOCK :: CInt -foreign import capi "sys/socket.h value SO_REUSEADDR" sOREUSEADDR :: CInt +foreign import capi "sys/socket.h value AF_INET" aFINET :: CInt +foreign import capi "sys/socket.h value SOL_SOCKET" sOLSOCKET :: CInt +foreign import capi "sys/socket.h value SOCK_STREAM" sOCKSTREAM :: CInt +foreign import capi "sys/socket.h value SO_REUSEADDR" sOREUSEADDR :: CInt +foreign import capi "fcntl.h value F_SETFL" fSETFL :: CInt +foreign import capi "fcntl.h value O_NONBLOCK" oNONBLOCK :: CInt -- ismacos is provided by the MHS runtime (returns non-zero on macOS/Darwin). foreign import ccall "ismacos" ismacos :: IO CInt +setNonBlocking :: CInt -> IO () +setNonBlocking fd = do + c_fcntl_setfl fd fSETFL oNONBLOCK + return () + -- open and configure a socket. Important that it is set to O_NONBLOCK. openServerSocket :: Word16 -> IO CInt openServerSocket port = do - fd <- c_socket aFINET (sOCKSTREAM + sOCKNONBLOCK) 0 + fd <- c_socket aFINET sOCKSTREAM 0 + setNonBlocking fd alloca $ \p -> do poke p (1 :: CInt) From 2e69f43445212af793f284e2ed211dc477327c28 Mon Sep 17 00:00:00 2001 From: Rewbert Date: Sun, 26 Apr 2026 08:08:52 +0200 Subject: [PATCH 07/16] update the test to use Client --- tests/NonBlockIO.hs | 95 ++++++++++++++++++++++++++++++++++---------- tests/NonBlockIO.ref | 2 + 2 files changed, 76 insertions(+), 21 deletions(-) diff --git a/tests/NonBlockIO.hs b/tests/NonBlockIO.hs index 1a11b6a40..36f5ae645 100644 --- a/tests/NonBlockIO.hs +++ b/tests/NonBlockIO.hs @@ -1,6 +1,7 @@ module NonBlockIO where import Control.Concurrent +import Control.Concurrent.MVar import Data.Word import Foreign.C.Error import Foreign.C.Types @@ -14,10 +15,16 @@ foreign import ccall "sys/socket.h setsockopt" c_setsockopt :: CInt -> CInt -> C foreign import ccall "sys/socket.h bind" c_bind :: CInt -> Ptr Word8 -> CInt -> IO CInt foreign import ccall "sys/socket.h listen" c_listen :: CInt -> CInt -> IO CInt foreign import ccall "sys/socket.h accept" c_accept :: CInt -> Ptr Word8 -> Ptr CInt -> IO CInt +foreign import ccall "sys/socket.h connect" c_connect :: CInt -> Ptr Word8 -> CInt -> IO CInt foreign import ccall "htons" htons :: Word16 -> Word16 foreign import ccall "fcntl.h fcntl" c_fcntl_setfl :: CInt -> CInt -> CInt -> IO CInt --- Platform constants pulled from the system headers instead of hardcoded Linux values. +-- Platform constants. +-- +-- I think an alternative is to hardcode the values in this file rather than pulling them in +-- like this, but conditionally choose the mac or linux variants with `ismacos`. Some of these +-- constants differ on the two platforms, e.g. oNONBLOCK. I have no clue if Windows have their +-- own, third, variant. foreign import capi "sys/socket.h value AF_INET" aFINET :: CInt foreign import capi "sys/socket.h value SOL_SOCKET" sOLSOCKET :: CInt foreign import capi "sys/socket.h value SOCK_STREAM" sOCKSTREAM :: CInt @@ -28,25 +35,20 @@ foreign import capi "fcntl.h value O_NONBLOCK" oNONBLOCK :: CInt -- ismacos is provided by the MHS runtime (returns non-zero on macOS/Darwin). foreign import ccall "ismacos" ismacos :: IO CInt +-- set a file descriptor to non-blocking mode setNonBlocking :: CInt -> IO () setNonBlocking fd = do c_fcntl_setfl fd fSETFL oNONBLOCK return () --- open and configure a socket. Important that it is set to O_NONBLOCK. -openServerSocket :: Word16 -> IO CInt -openServerSocket port = do - fd <- c_socket aFINET sOCKSTREAM 0 - setNonBlocking fd - - alloca $ \p -> do - poke p (1 :: CInt) - c_setsockopt fd sOLSOCKET sOREUSEADDR p 4 - return () - - -- Build struct sockaddr_in (16 bytes). - -- On Linux: [sin_family: uint16_t at 0][sin_port: uint16_t at 2]... - -- On macOS: [sin_len: uint8_t at 0][sin_family: uint8_t at 1][sin_port: uint16_t at 2]... +-- Build a struct sockaddr_in (16 bytes) and pass it to the given action. +-- layout differ slightly on the two platforms, whereby we have a test on whether +-- we run on macos or linux, +-- +-- On Linux: [sin_family: uint16_t at 0][sin_port: uint16_t at 2][sin_addr: 4 bytes at 4]... +-- On macOS: [sin_len: uint8_t at 0][sin_family: uint8_t at 1][sin_port: uint16_t at 2][sin_addr: 4 bytes at 4]... +withSockAddr :: Word16 -> (Word8, Word8, Word8, Word8) -> (Ptr Word8 -> IO a) -> IO a +withSockAddr port (a0, a1, a2, a3) action = do mac <- ismacos allocaBytes 16 $ \p -> do mapM_ (\i -> pokeByteOff p i (0 :: Word8)) [0..15] @@ -58,9 +60,29 @@ openServerSocket port = do pokeByteOff p 0 (2 :: Word8) -- sin_family low byte (LE uint16_t) pokeByteOff p 2 (fromIntegral (htons port `div` 256) :: Word8) pokeByteOff p 3 (fromIntegral (htons port `mod` 256) :: Word8) - c_bind fd p 16 + pokeByteOff p 4 a0 + pokeByteOff p 5 a1 + pokeByteOff p 6 a2 + pokeByteOff p 7 a3 + action p + +-- open and configure a socket. Important that it is set to O_NONBLOCK. +openServerSocket :: Word16 -> IO CInt +openServerSocket port = do + -- create nonblocking socket + fd <- c_socket aFINET sOCKSTREAM 0 + setNonBlocking fd + + alloca $ \p -> do + poke p (1 :: CInt) + c_setsockopt fd sOLSOCKET sOREUSEADDR p 4 return () + -- configure the SockAddr stuff + withSockAddr port (0, 0, 0, 0) $ \p -> + c_bind fd p 16 + + -- enable listening mode c_listen fd 1 return fd @@ -73,20 +95,51 @@ blockOnAccept fd = do if errno == eAGAIN || errno == eWOULDBLOCK then do waitForReadFD (fromIntegral fd) -- block via epoll/kqueue, letting other threads run - blockOnAccept fd -- woken up by epoll/kqueue, retry accept + blockOnAccept fd -- when we are woken up here, the socket is ready and the next + -- accept try should work immediately. else throwErrno "accept" -server :: IO () -server = do - fd <- openServerSocket 19876 +serverPort :: Word16 +serverPort = 19876 + +-- runs in its own green thread, blocking on IO until someone connects to it +server :: MVar () -> IO () +server mv = do + fd <- openServerSocket serverPort putStrLn "server: listening, blocking on accept" blockOnAccept fd + _ <- takeMVar mv + putStrLn "accepted an incoming connection" + +connectToServer :: IO () +connectToServer port = do + fd <- c_socket aFINET sOCKSTREAM 0 + withSockAddr serverPort (127, 0, 0, 1) $ \p -> + c_connect fd p 16 + return () +-- main thread +-- +-- forks a green thread running the server, which blocks +-- then, three heartbeats are emitted +-- after which we connect to the server. Both the server and this +-- green thread will issue a print to indicate success, but we use +-- an MVar to guarantee a specific order of their outputs. If the +-- main thread terminates before the server thread prints, it will +-- never print. main :: IO () main = do - forkIO server + mv <- newEmptyMVar :: IO (MVar ()) + forkIO $ server mv yield -- let the server thread run and print its message + let tick = putStrLn "tick" >> threadDelay 1000000 tick tick tick + + connectToServer + putMVar mv () + yield + + putStrLn "client: connected to server" \ No newline at end of file diff --git a/tests/NonBlockIO.ref b/tests/NonBlockIO.ref index 63120385b..e8ea6ba4b 100644 --- a/tests/NonBlockIO.ref +++ b/tests/NonBlockIO.ref @@ -2,3 +2,5 @@ server: listening, blocking on accept tick tick tick +accepted an incoming connection +client: connected to server From a7644d5b240e8e84fbf5506934f43b2971b8d1fb Mon Sep 17 00:00:00 2001 From: Rewbert Date: Sun, 26 Apr 2026 08:27:39 +0200 Subject: [PATCH 08/16] fix the test, after I broke it.. --- tests/NonBlockIO.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/NonBlockIO.hs b/tests/NonBlockIO.hs index 36f5ae645..063c52b21 100644 --- a/tests/NonBlockIO.hs +++ b/tests/NonBlockIO.hs @@ -111,7 +111,7 @@ server mv = do _ <- takeMVar mv putStrLn "accepted an incoming connection" -connectToServer :: IO () +connectToServer :: Word16 -> IO () connectToServer port = do fd <- c_socket aFINET sOCKSTREAM 0 withSockAddr serverPort (127, 0, 0, 1) $ \p -> @@ -138,7 +138,7 @@ main = do tick tick - connectToServer + connectToServer serverPort putMVar mv () yield From 01806d9967c0ab05bf9a1b2e8236d20953c42965 Mon Sep 17 00:00:00 2001 From: Rewbert Date: Sun, 26 Apr 2026 10:11:49 +0200 Subject: [PATCH 09/16] move the direct mthread/runq manipulation out of the io_poll machinery, instead passing a callback for what to do with the awake-able thread --- src/runtime/eval.c | 24 ++++++++++++++++----- src/runtime/io_poll.h | 6 ++---- src/runtime/unix/io_poll_epoll.c | 35 ++++++++++++++++++++++--------- src/runtime/unix/io_poll_kqueue.c | 15 ++++++------- 4 files changed, 52 insertions(+), 28 deletions(-) diff --git a/src/runtime/eval.c b/src/runtime/eval.c index 8bc1d62e3..f93030dcc 100644 --- a/src/runtime/eval.c +++ b/src/runtime/eval.c @@ -1135,6 +1135,20 @@ add_runq_tail(struct mthread *mt) add_q_tail(&runq, mt); } +#if MHS_IO_POLL +/* +this is the callback that is sent to the io_poll framework. It is invoked +when an event a thread is waiting for becomes ready. +*/ +static void +io_thread_ready(void *ptr) +{ + struct mthread *mt = (struct mthread *)ptr; + mt->mt_fd = -2; + add_runq_tail(mt); +} +#endif + struct mthread* remove_q_head(struct mqueue *q) { @@ -1327,7 +1341,7 @@ yield(void) if (io_waiter_count() > 0) { /* Check if any threads blocked on IO can be scheduled. Since we pass in a delay of 0, checking for the events should not block. */ - io_poll(0); + io_poll(0, io_thread_ready); } #endif @@ -1660,7 +1674,7 @@ IO event, we are deadlocked. */ timeout_ms = (delta > 0) ? (int)((delta + 999) / 1000) : 0; } #endif - io_poll(timeout_ms); + io_poll(timeout_ms, io_thread_ready); #if defined(CLOCK_INIT) check_timeq(); #endif @@ -6083,9 +6097,9 @@ evali(NODEPTR an) case T_IO_WAITWRFD: { CHKARG2NP; /* x = the filedescriptor, y = RealWorld; no pop yet */ - /* io_poll sets mt_fd=-2 when waking the thread. By seeing if it is -2 here we - can learn that our registered event has happened and we can return unit. If - we did not do this check we would just register again. + /* io_thread_ready sets mt_fd=-2 when waking the thread. By seeing if it is -2 + here we can learn that our registered event has happened and we can return + unit. If we did not do this check we would just register again. This seems to be how T_IO_THREADDELAY works, with mt_at == -1. */ diff --git a/src/runtime/io_poll.h b/src/runtime/io_poll.h index fa7737f7a..b280eb824 100644 --- a/src/runtime/io_poll.h +++ b/src/runtime/io_poll.h @@ -12,9 +12,7 @@ #define IO_POLL_READ 1 #define IO_POLL_WRITE 2 -struct mthread; /* forward declaration; full definition is in eval.c */ - void io_init(void); -void io_poll(int timeout_ms); -void io_register(int fd, int events, struct mthread *mt); +void io_poll(int timeout_ms, void (*on_ready)(void *cookie)); /* cookie is a struct mthread*, passed in from eval.c */ +void io_register(int fd, int events, void *cookie); int io_waiter_count(void); diff --git a/src/runtime/unix/io_poll_epoll.c b/src/runtime/unix/io_poll_epoll.c index cd1f51aab..9e883a881 100644 --- a/src/runtime/unix/io_poll_epoll.c +++ b/src/runtime/unix/io_poll_epoll.c @@ -4,12 +4,22 @@ /* * epoll backend for non-blocking IO polling (Linux only). - * This file is #included into eval.c via io_poll_impl.c, so it has - * access to all definitions in eval.c (struct mthread, add_runq_tail, etc.). + * This file is #included into eval.c via io_poll_impl.c. */ #include #include +#include + +/* +This is the user data that we register with epoll. When an event fires, we can retrieve it. + +We need to be able to reference both the void *cookie and the file descriptor it is waiting +for. We need to void *cookie to call the on_ready callback on, and we need the file descriptor +so that we can unregister it from epoll. + +*/ +struct io_entry { void *cookie; int fd; }; static int epoll_fd = -1; static int io_waiters = 0; @@ -26,29 +36,34 @@ io_init(void) /* If timeout_ms is 0 this is a non-blocking check; otherwise it blocks up to timeout_ms milliseconds (or indefinitely when timeout_ms == -1). */ void -io_poll(int timeout_ms) +io_poll(int timeout_ms, void (*on_ready)(void *cookie)) { struct epoll_event evs[64]; int n = epoll_wait(epoll_fd, evs, 64, timeout_ms); for (int i = 0; i < n; i++) { - struct mthread *mt = evs[i].data.ptr; + struct io_entry *e = evs[i].data.ptr; /* EPOLLONESHOT disables but does not remove the fd; delete it now so that a subsequent io_register on the same fd can use EPOLL_CTL_ADD. */ - epoll_ctl(epoll_fd, EPOLL_CTL_DEL, mt->mt_fd, NULL); - mt->mt_fd = -2; /* signal "already woken" to the eval loop */ + epoll_ctl(epoll_fd, EPOLL_CTL_DEL, e->fd, NULL); io_waiters--; - add_runq_tail(mt); + on_ready(e->cookie); + free(e); } } -/* Register fd to wake mt when the requested event is ready. +/* Register fd to call on_ready(cookie) when the requested event is ready. events is IO_POLL_READ or IO_POLL_WRITE. */ void -io_register(int fd, int events, struct mthread *mt) +io_register(int fd, int events, void *cookie) { + struct io_entry *e = malloc(sizeof *e); + if (!e) ERR("io_register malloc failed"); + e->cookie = cookie; + e->fd = fd; uint32_t ev_flags = (events == IO_POLL_READ ? EPOLLIN : EPOLLOUT) | EPOLLONESHOT; - struct epoll_event ev = { .events = ev_flags, .data.ptr = mt }; + struct epoll_event ev = { .events = ev_flags, .data.ptr = e }; if (epoll_ctl(epoll_fd, EPOLL_CTL_ADD, fd, &ev) < 0) { + free(e); ERR("epoll_ctl ADD failed"); } io_waiters++; diff --git a/src/runtime/unix/io_poll_kqueue.c b/src/runtime/unix/io_poll_kqueue.c index 8fd6ee8fa..b782c7938 100644 --- a/src/runtime/unix/io_poll_kqueue.c +++ b/src/runtime/unix/io_poll_kqueue.c @@ -4,8 +4,7 @@ /* * kqueue backend for non-blocking IO polling (macOS / BSD). - * This file is #included into eval.c via io_poll_impl.c, so it has - * access to all definitions in eval.c (struct mthread, add_runq_tail, etc.). + * This file is #included into eval.c via io_poll_impl.c. */ #include @@ -27,7 +26,7 @@ io_init(void) /* If timeout_ms is 0 this is a non-blocking check; otherwise it blocks up to timeout_ms milliseconds (or indefinitely when timeout_ms == -1). */ void -io_poll(int timeout_ms) +io_poll(int timeout_ms, void (*on_ready)(void *cookie)) { struct kevent evs[64]; struct timespec ts; @@ -39,21 +38,19 @@ io_poll(int timeout_ms) } int n = kevent(kqueue_fd, NULL, 0, evs, 64, tsp); for (int i = 0; i < n; i++) { - struct mthread *mt = evs[i].udata; - mt->mt_fd = -2; /* signal "already woken" to the eval loop */ io_waiters--; - add_runq_tail(mt); + on_ready((void *)evs[i].udata); } } -/* Register fd to wake mt when the requested event is ready. +/* Register fd to call on_ready(cookie) when the requested event is ready. events is IO_POLL_READ or IO_POLL_WRITE. */ void -io_register(int fd, int events, struct mthread *mt) +io_register(int fd, int events, void *cookie) { struct kevent ev; int16_t filter = (events == IO_POLL_READ) ? EVFILT_READ : EVFILT_WRITE; - EV_SET(&ev, fd, filter, EV_ADD | EV_ONESHOT, 0, 0, mt); + EV_SET(&ev, fd, filter, EV_ADD | EV_ONESHOT, 0, 0, cookie); if (kevent(kqueue_fd, &ev, 1, NULL, 0, NULL) < 0) { ERR("kevent ADD failed"); } From e76571b8a0911c22ddc0c9c237748a0a3d6a93f2 Mon Sep 17 00:00:00 2001 From: Rewbert Date: Tue, 5 May 2026 21:00:46 +0200 Subject: [PATCH 10/16] potential bugfix. Tests pass --- src/runtime/unix/io_poll_epoll.c | 97 ++++++++++++++++++++++--------- src/runtime/unix/io_poll_kqueue.c | 40 ++++++++++++- 2 files changed, 108 insertions(+), 29 deletions(-) diff --git a/src/runtime/unix/io_poll_epoll.c b/src/runtime/unix/io_poll_epoll.c index 9e883a881..6f0a9b969 100644 --- a/src/runtime/unix/io_poll_epoll.c +++ b/src/runtime/unix/io_poll_epoll.c @@ -5,23 +5,31 @@ /* * epoll backend for non-blocking IO polling (Linux only). * This file is #included into eval.c via io_poll_impl.c. + * + * A single TCP socket fd can have both a reader and a writer waiting on it + * simultaneously — e.g. a receive loop blocked on EPOLLIN while a send path + * is blocked on EPOLLOUT. The original design used one cookie per fd with + * EPOLL_CTL_ADD, which fails with EEXIST in that scenario. + * + * This version tracks separate read/write cookies per fd in a static table + * and uses EPOLL_CTL_MOD when the fd is already in the epoll set, so both + * directions stay live in a single epoll entry. */ #include #include #include -/* -This is the user data that we register with epoll. When an event fires, we can retrieve it. - -We need to be able to reference both the void *cookie and the file descriptor it is waiting -for. We need to void *cookie to call the on_ready callback on, and we need the file descriptor -so that we can unregister it from epoll. +/* Per-fd waiter state. */ +struct fd_state { + void *read_cookie; /* non-NULL while a thread is waiting for EPOLLIN */ + void *write_cookie; /* non-NULL while a thread is waiting for EPOLLOUT */ +}; -*/ -struct io_entry { void *cookie; int fd; }; +#define MAX_FDS 256 +static struct fd_state fd_table[MAX_FDS]; /* zero-initialised by the C runtime */ -static int epoll_fd = -1; +static int epoll_fd = -1; static int io_waiters = 0; void @@ -41,30 +49,67 @@ io_poll(int timeout_ms, void (*on_ready)(void *cookie)) struct epoll_event evs[64]; int n = epoll_wait(epoll_fd, evs, 64, timeout_ms); for (int i = 0; i < n; i++) { - struct io_entry *e = evs[i].data.ptr; - /* EPOLLONESHOT disables but does not remove the fd; delete it now so - that a subsequent io_register on the same fd can use EPOLL_CTL_ADD. */ - epoll_ctl(epoll_fd, EPOLL_CTL_DEL, e->fd, NULL); - io_waiters--; - on_ready(e->cookie); - free(e); + int fd = evs[i].data.fd; + uint32_t got = evs[i].events; + void *rc = NULL, *wc = NULL; + + /* Collect whichever cookies fired and clear them from the table. */ + if ((got & (EPOLLIN | EPOLLERR | EPOLLHUP)) && fd_table[fd].read_cookie) { + rc = fd_table[fd].read_cookie; + fd_table[fd].read_cookie = NULL; + io_waiters--; + } + if ((got & (EPOLLOUT | EPOLLERR | EPOLLHUP)) && fd_table[fd].write_cookie) { + wc = fd_table[fd].write_cookie; + fd_table[fd].write_cookie = NULL; + io_waiters--; + } + + /* EPOLLONESHOT disabled the fd after firing. Re-arm for any remaining + interest, or remove the fd from the set entirely. */ + uint32_t remaining = 0; + if (fd_table[fd].read_cookie) remaining |= EPOLLIN; + if (fd_table[fd].write_cookie) remaining |= EPOLLOUT; + + if (remaining) { + struct epoll_event ev = { .events = remaining | EPOLLONESHOT, .data.fd = fd }; + epoll_ctl(epoll_fd, EPOLL_CTL_MOD, fd, &ev); + } else { + epoll_ctl(epoll_fd, EPOLL_CTL_DEL, fd, NULL); + } + + if (rc) on_ready(rc); + if (wc) on_ready(wc); } } /* Register fd to call on_ready(cookie) when the requested event is ready. - events is IO_POLL_READ or IO_POLL_WRITE. */ + events is IO_POLL_READ or IO_POLL_WRITE. + Uses EPOLL_CTL_MOD when the fd already has an interest registered in the + other direction, so both directions coexist in a single epoll entry. */ void io_register(int fd, int events, void *cookie) { - struct io_entry *e = malloc(sizeof *e); - if (!e) ERR("io_register malloc failed"); - e->cookie = cookie; - e->fd = fd; - uint32_t ev_flags = (events == IO_POLL_READ ? EPOLLIN : EPOLLOUT) | EPOLLONESHOT; - struct epoll_event ev = { .events = ev_flags, .data.ptr = e }; - if (epoll_ctl(epoll_fd, EPOLL_CTL_ADD, fd, &ev) < 0) { - free(e); - ERR("epoll_ctl ADD failed"); + if (fd < 0 || fd >= MAX_FDS) ERR("io_register: fd out of range"); + + int already_registered = (fd_table[fd].read_cookie != NULL || + fd_table[fd].write_cookie != NULL); + + if (events == IO_POLL_READ) { + fd_table[fd].read_cookie = cookie; + } else { + fd_table[fd].write_cookie = cookie; + } + + uint32_t ev_flags = 0; + if (fd_table[fd].read_cookie) ev_flags |= EPOLLIN; + if (fd_table[fd].write_cookie) ev_flags |= EPOLLOUT; + ev_flags |= EPOLLONESHOT; + + struct epoll_event ev = { .events = ev_flags, .data.fd = fd }; + int op = already_registered ? EPOLL_CTL_MOD : EPOLL_CTL_ADD; + if (epoll_ctl(epoll_fd, op, fd, &ev) < 0) { + ERR("io_register epoll_ctl failed"); } io_waiters++; } diff --git a/src/runtime/unix/io_poll_kqueue.c b/src/runtime/unix/io_poll_kqueue.c index b782c7938..c3c3c47e7 100644 --- a/src/runtime/unix/io_poll_kqueue.c +++ b/src/runtime/unix/io_poll_kqueue.c @@ -5,12 +5,27 @@ /* * kqueue backend for non-blocking IO polling (macOS / BSD). * This file is #included into eval.c via io_poll_impl.c. + * + * kqueue tracks EVFILT_READ and EVFILT_WRITE as independent (fd, filter) + * entries, so concurrent read and write waiters on the same fd do not + * conflict at the kqueue level. We still maintain a per-fd cookie table + * (mirroring the epoll backend) so that io_poll can dispatch to the correct + * waiting thread without storing the cookie in udata and casting. */ #include #include #include +/* Per-fd waiter state. */ +struct fd_state { + void *read_cookie; /* non-NULL while a thread is waiting for EVFILT_READ */ + void *write_cookie; /* non-NULL while a thread is waiting for EVFILT_WRITE */ +}; + +#define MAX_FDS 256 +static struct fd_state fd_table[MAX_FDS]; /* zero-initialised by the C runtime */ + static int kqueue_fd = -1; static int io_waiters = 0; @@ -38,8 +53,17 @@ io_poll(int timeout_ms, void (*on_ready)(void *cookie)) } int n = kevent(kqueue_fd, NULL, 0, evs, 64, tsp); for (int i = 0; i < n; i++) { + int fd = (int)evs[i].ident; + void *cookie = NULL; + if (evs[i].filter == EVFILT_READ) { + cookie = fd_table[fd].read_cookie; + fd_table[fd].read_cookie = NULL; + } else { + cookie = fd_table[fd].write_cookie; + fd_table[fd].write_cookie = NULL; + } io_waiters--; - on_ready((void *)evs[i].udata); + if (cookie) on_ready(cookie); } } @@ -48,9 +72,19 @@ io_poll(int timeout_ms, void (*on_ready)(void *cookie)) void io_register(int fd, int events, void *cookie) { + if (fd < 0 || fd >= MAX_FDS) ERR("io_register: fd out of range"); + struct kevent ev; - int16_t filter = (events == IO_POLL_READ) ? EVFILT_READ : EVFILT_WRITE; - EV_SET(&ev, fd, filter, EV_ADD | EV_ONESHOT, 0, 0, cookie); + int16_t filter; + if (events == IO_POLL_READ) { + fd_table[fd].read_cookie = cookie; + filter = EVFILT_READ; + } else { + fd_table[fd].write_cookie = cookie; + filter = EVFILT_WRITE; + } + + EV_SET(&ev, fd, filter, EV_ADD | EV_ONESHOT, 0, 0, 0); if (kevent(kqueue_fd, &ev, 1, NULL, 0, NULL) < 0) { ERR("kevent ADD failed"); } From b9ee18df76a99b29fd1f25c5e42bd6a195dc1712 Mon Sep 17 00:00:00 2001 From: Rewbert Date: Fri, 15 May 2026 21:04:27 +0200 Subject: [PATCH 11/16] address some of Lennarts comments --- src/runtime/eval.c | 42 +++++++++++++++++++----------------------- 1 file changed, 19 insertions(+), 23 deletions(-) diff --git a/src/runtime/eval.c b/src/runtime/eval.c index f93030dcc..7e9eb7794 100644 --- a/src/runtime/eval.c +++ b/src/runtime/eval.c @@ -546,9 +546,7 @@ enum node_tag { T_FREE, T_IND, T_AP, T_INT, T_INT64, T_DBL, T_FLT32, T_PTR, T_FU T_WKNEWFIN, T_WKNEW, T_WKDEREF, T_WKFINAL, T_IO_PP, /* for debugging */ T_IO_STDIN, T_IO_STDOUT, T_IO_STDERR, -#if MHS_IO_POLL T_IO_WAITRDFD, T_IO_WAITWRFD, -#endif T_LAST_TAG, }; @@ -912,9 +910,7 @@ enum th_state { ts_wait_time, ts_finished, ts_died, -#if MHS_IO_POLL ts_wait_io, /* not visible to Haskell; must stay after ts_died */ -#endif }; enum mask_state { mask_unmasked, mask_interruptible, mask_uninterruptible }; @@ -928,6 +924,9 @@ struct handler { /***************** THREAD ******************/ +#define IO_POLL_WAITING_FOR_NONE (-1) +#define IO_POLL_EVENT_HAS_HAPPENED (-2) + struct mthread { enum th_state mt_state; /* thread state */ enum mask_state mt_mask; /* making state. */ @@ -941,7 +940,7 @@ struct mthread { bool mt_mark; /* marked as accessible */ uvalue_t mt_id; /* thread number, thread 1 is the main thread */ #if MHS_IO_POLL - int mt_fd; /* The file descriptor that we are waiting on (-1 means none, -2 means we've already been woken) */ + int mt_fd; /* The file descriptor that we are waiting on (will be either IO_POLL_WAITING_FOR_NONE or IO_POLL_EVENT_HAS_HAPPENED) */ int mt_events; /* IO_POLL_READ or IO_POLL_WRITE */ #endif #if defined(CLOCK_INIT) @@ -1136,15 +1135,14 @@ add_runq_tail(struct mthread *mt) } #if MHS_IO_POLL -/* -this is the callback that is sent to the io_poll framework. It is invoked -when an event a thread is waiting for becomes ready. -*/ +/* this is the callback that is sent to the io_poll framework. + * It is invoked when an event a thread is waiting for becomes ready. + */ static void io_thread_ready(void *ptr) { struct mthread *mt = (struct mthread *)ptr; - mt->mt_fd = -2; + mt->mt_fd = IO_POLL_EVENT_HAS_HAPPENED; add_runq_tail(mt); } #endif @@ -1391,7 +1389,7 @@ new_thread(NODEPTR root) mt->mt_num_slices = 0; mt->mt_id = num_thread_create++; #if MHS_IO_POLL - mt->mt_fd = -1; + mt->mt_fd = IO_POLL_WAITING_FOR_NONE; mt->mt_events = -1; #endif #if defined(CLOCK_INIT) @@ -1647,10 +1645,11 @@ void pause_exec(void) { /* End up here if the run queue is empty. If there is no thread waiting for -a delay to expire, we will never resume operation and we are deadlocked. However, if -we compile with MHS_IO_POLL there might be threads waiting for IO events, so in -that case we check for them as well. If there is no thread waiting for a delay or an -IO event, we are deadlocked. */ + * a delay to expire, we will never resume operation and we are deadlocked. However, if + * we compile with MHS_IO_POLL there might be threads waiting for IO events, so in + * that case we check for them as well. If there is no thread waiting for a delay or an + * IO event, we are deadlocked. + */ #if MHS_IO_POLL /* Check for deadlock situation */ @@ -6097,22 +6096,19 @@ evali(NODEPTR an) case T_IO_WAITWRFD: { CHKARG2NP; /* x = the filedescriptor, y = RealWorld; no pop yet */ - /* io_thread_ready sets mt_fd=-2 when waking the thread. By seeing if it is -2 - here we can learn that our registered event has happened and we can return - unit. If we did not do this check we would just register again. + /* io_thread_ready sets mt_fd=IO_POLL_EVENT_HAS_HAPPENED when waking the thread. + If we did not do this check we would just register again. This seems to be how T_IO_THREADDELAY works, with mt_at == -1. */ - if (runq.mq_head->mt_fd == -2) { - runq.mq_head->mt_fd = -1; + if (runq.mq_head->mt_fd == IO_POLL_EVENT_HAS_HAPPENED) { + runq.mq_head->mt_fd = IO_POLL_WAITING_FOR_NONE; POP(2); GOPAIRUNIT; } POP(2); - int fd = evalint(x); // initially I used GETVALUE(x) here, but that did not work. - // I assumed it had to do with lazyness, and the change to evalint - // seems to have fixed it. + int fd = evalint(x); int events = (tag == T_IO_WAITRDFD) ? IO_POLL_READ : IO_POLL_WRITE; /* Set up the waiting thread's state, preparing it to leave the run queue From 8b344ad2b505fde62c349d748c0081a6546f8b2e Mon Sep 17 00:00:00 2001 From: Rewbert Date: Fri, 15 May 2026 21:37:02 +0200 Subject: [PATCH 12/16] replace with a simpler, but equally 'testive' test --- tests/Makefile | 6 +- tests/NonBlockIO.hs | 145 --------------------------------------- tests/NonBlockIO.ref | 6 -- tests/PipeNonBlockIO.hs | 61 ++++++++++++++++ tests/PipeNonBlockIO.ref | 3 + 5 files changed, 67 insertions(+), 154 deletions(-) delete mode 100644 tests/NonBlockIO.hs delete mode 100644 tests/NonBlockIO.ref create mode 100644 tests/PipeNonBlockIO.hs create mode 100644 tests/PipeNonBlockIO.ref diff --git a/tests/Makefile b/tests/Makefile index 737acc1cd..50efdd0b2 100644 --- a/tests/Makefile +++ b/tests/Makefile @@ -5,7 +5,7 @@ TMHS=$(MHS) $(MHSTARGET) $(MHSOUTPUT) EVAL=../bin/mhseval +RTS -H1M -RTS .PHONY: test nfib clean errtest alltest cache info -alltest: info test errtest testforimp testforexp testforimpexp testapplysp testnonblockio +alltest: info test errtest testforimp testforexp testforimpexp testapplysp testpipenonblockio # interactivetest cache: @@ -138,8 +138,8 @@ testforimpexp: testapplysp: $(TMHS) -optc -I. ApplySP hsasp.c -oApplySP.exe && ./ApplySP.exe > ApplySP.out && diff ApplySP.ref ApplySP.out -testnonblockio: - MHSDIR=.. $(TMHS) -oNonBlockIO.exe NonBlockIO && ./NonBlockIO.exe > NonBlockIO.out && diff NonBlockIO.ref NonBlockIO.out +testpipenonblockio: + MHSDIR=.. $(TMHS) -oPipeNonBlockIO.exe PipeNonBlockIO && ./PipeNonBlockIO.exe > PipeNonBlockIO.out && diff PipeNonBlockIO.ref PipeNonBlockIO.out errtest: sh errtester.sh $(MHS) < errmsg.test diff --git a/tests/NonBlockIO.hs b/tests/NonBlockIO.hs deleted file mode 100644 index 063c52b21..000000000 --- a/tests/NonBlockIO.hs +++ /dev/null @@ -1,145 +0,0 @@ -module NonBlockIO where - -import Control.Concurrent -import Control.Concurrent.MVar -import Data.Word -import Foreign.C.Error -import Foreign.C.Types -import Foreign.Marshal.Alloc -import Foreign.Ptr -import Foreign.Storable -import System.IO.FD - -foreign import ccall "sys/socket.h socket" c_socket :: CInt -> CInt -> CInt -> IO CInt -foreign import ccall "sys/socket.h setsockopt" c_setsockopt :: CInt -> CInt -> CInt -> Ptr CInt -> CInt -> IO CInt -foreign import ccall "sys/socket.h bind" c_bind :: CInt -> Ptr Word8 -> CInt -> IO CInt -foreign import ccall "sys/socket.h listen" c_listen :: CInt -> CInt -> IO CInt -foreign import ccall "sys/socket.h accept" c_accept :: CInt -> Ptr Word8 -> Ptr CInt -> IO CInt -foreign import ccall "sys/socket.h connect" c_connect :: CInt -> Ptr Word8 -> CInt -> IO CInt -foreign import ccall "htons" htons :: Word16 -> Word16 -foreign import ccall "fcntl.h fcntl" c_fcntl_setfl :: CInt -> CInt -> CInt -> IO CInt - --- Platform constants. --- --- I think an alternative is to hardcode the values in this file rather than pulling them in --- like this, but conditionally choose the mac or linux variants with `ismacos`. Some of these --- constants differ on the two platforms, e.g. oNONBLOCK. I have no clue if Windows have their --- own, third, variant. -foreign import capi "sys/socket.h value AF_INET" aFINET :: CInt -foreign import capi "sys/socket.h value SOL_SOCKET" sOLSOCKET :: CInt -foreign import capi "sys/socket.h value SOCK_STREAM" sOCKSTREAM :: CInt -foreign import capi "sys/socket.h value SO_REUSEADDR" sOREUSEADDR :: CInt -foreign import capi "fcntl.h value F_SETFL" fSETFL :: CInt -foreign import capi "fcntl.h value O_NONBLOCK" oNONBLOCK :: CInt - --- ismacos is provided by the MHS runtime (returns non-zero on macOS/Darwin). -foreign import ccall "ismacos" ismacos :: IO CInt - --- set a file descriptor to non-blocking mode -setNonBlocking :: CInt -> IO () -setNonBlocking fd = do - c_fcntl_setfl fd fSETFL oNONBLOCK - return () - --- Build a struct sockaddr_in (16 bytes) and pass it to the given action. --- layout differ slightly on the two platforms, whereby we have a test on whether --- we run on macos or linux, --- --- On Linux: [sin_family: uint16_t at 0][sin_port: uint16_t at 2][sin_addr: 4 bytes at 4]... --- On macOS: [sin_len: uint8_t at 0][sin_family: uint8_t at 1][sin_port: uint16_t at 2][sin_addr: 4 bytes at 4]... -withSockAddr :: Word16 -> (Word8, Word8, Word8, Word8) -> (Ptr Word8 -> IO a) -> IO a -withSockAddr port (a0, a1, a2, a3) action = do - mac <- ismacos - allocaBytes 16 $ \p -> do - mapM_ (\i -> pokeByteOff p i (0 :: Word8)) [0..15] - if mac /= 0 - then do - pokeByteOff p 0 (16 :: Word8) -- sin_len = sizeof(sockaddr_in) - pokeByteOff p 1 (2 :: Word8) -- sin_family = AF_INET - else - pokeByteOff p 0 (2 :: Word8) -- sin_family low byte (LE uint16_t) - pokeByteOff p 2 (fromIntegral (htons port `div` 256) :: Word8) - pokeByteOff p 3 (fromIntegral (htons port `mod` 256) :: Word8) - pokeByteOff p 4 a0 - pokeByteOff p 5 a1 - pokeByteOff p 6 a2 - pokeByteOff p 7 a3 - action p - --- open and configure a socket. Important that it is set to O_NONBLOCK. -openServerSocket :: Word16 -> IO CInt -openServerSocket port = do - -- create nonblocking socket - fd <- c_socket aFINET sOCKSTREAM 0 - setNonBlocking fd - - alloca $ \p -> do - poke p (1 :: CInt) - c_setsockopt fd sOLSOCKET sOREUSEADDR p 4 - return () - - -- configure the SockAddr stuff - withSockAddr port (0, 0, 0, 0) $ \p -> - c_bind fd p 16 - - -- enable listening mode - c_listen fd 1 - - return fd - -blockOnAccept :: CInt -> IO () -blockOnAccept fd = do - r <- c_accept fd nullPtr nullPtr - if r /= -1 then return () else do -- O_NONBLOCK, returns immediately when no client - errno <- getErrno - if errno == eAGAIN || errno == eWOULDBLOCK - then do - waitForReadFD (fromIntegral fd) -- block via epoll/kqueue, letting other threads run - blockOnAccept fd -- when we are woken up here, the socket is ready and the next - -- accept try should work immediately. - else throwErrno "accept" - -serverPort :: Word16 -serverPort = 19876 - --- runs in its own green thread, blocking on IO until someone connects to it -server :: MVar () -> IO () -server mv = do - fd <- openServerSocket serverPort - putStrLn "server: listening, blocking on accept" - blockOnAccept fd - _ <- takeMVar mv - putStrLn "accepted an incoming connection" - -connectToServer :: Word16 -> IO () -connectToServer port = do - fd <- c_socket aFINET sOCKSTREAM 0 - withSockAddr serverPort (127, 0, 0, 1) $ \p -> - c_connect fd p 16 - return () - --- main thread --- --- forks a green thread running the server, which blocks --- then, three heartbeats are emitted --- after which we connect to the server. Both the server and this --- green thread will issue a print to indicate success, but we use --- an MVar to guarantee a specific order of their outputs. If the --- main thread terminates before the server thread prints, it will --- never print. -main :: IO () -main = do - mv <- newEmptyMVar :: IO (MVar ()) - forkIO $ server mv - yield -- let the server thread run and print its message - - let tick = putStrLn "tick" >> threadDelay 1000000 - tick - tick - tick - - connectToServer serverPort - putMVar mv () - yield - - putStrLn "client: connected to server" \ No newline at end of file diff --git a/tests/NonBlockIO.ref b/tests/NonBlockIO.ref deleted file mode 100644 index e8ea6ba4b..000000000 --- a/tests/NonBlockIO.ref +++ /dev/null @@ -1,6 +0,0 @@ -server: listening, blocking on accept -tick -tick -tick -accepted an incoming connection -client: connected to server diff --git a/tests/PipeNonBlockIO.hs b/tests/PipeNonBlockIO.hs new file mode 100644 index 000000000..cfe551788 --- /dev/null +++ b/tests/PipeNonBlockIO.hs @@ -0,0 +1,61 @@ +module PipeNonBlockIO where + +import Control.Concurrent +import Control.Concurrent.MVar +import Data.Word +import Foreign.C.Error +import Foreign.C.Types +import Foreign.Marshal.Alloc +import Foreign.Ptr +import Foreign.Storable +import System.IO.FD + +foreign import ccall "unistd.h pipe" c_pipe :: Ptr CInt -> IO CInt +foreign import ccall "unistd.h read" c_read :: CInt -> Ptr Word8 -> CInt -> IO CInt +foreign import ccall "unistd.h write" c_write :: CInt -> Ptr Word8 -> CInt -> IO CInt +foreign import ccall "fcntl.h fcntl" c_fcntl_setfl :: CInt -> CInt -> CInt -> IO CInt +foreign import capi "fcntl.h value F_SETFL" fSETFL :: CInt +foreign import capi "fcntl.h value O_NONBLOCK" oNONBLOCK :: CInt + +setNonBlocking :: CInt -> IO () +setNonBlocking fd = c_fcntl_setfl fd fSETFL oNONBLOCK >> return () + +blockOnRead :: CInt -> IO Word8 +blockOnRead fd = alloca $ \p -> go p + where + go p = do + r <- c_read fd p 1 + if r == 1 + then peek p + else do + errno <- getErrno + if errno == eAGAIN || errno == eWOULDBLOCK + then waitForReadFD (fromIntegral fd) >> go p + else throwErrno "read" + +reader :: CInt -> MVar () -> IO () +reader fd done = do + putStrLn "reader: waiting for data" + b <- blockOnRead fd + putStrLn $ "reader: received " ++ show b + putMVar done () + +main :: IO () +main = + allocaBytes 8 $ \fds -> do -- space for two CInt file descriptors + c_pipe fds + readFd <- peekByteOff fds 0 :: IO CInt + writeFd <- peekByteOff fds 4 :: IO CInt + setNonBlocking readFd + + done <- newEmptyMVar :: IO (MVar ()) + forkIO $ reader readFd done + yield -- let reader reach waitForReadFD + + threadDelay 1000000 -- let the other thread reach its blocking state + putStrLn "main: writing to pipe" + alloca $ \p -> do + poke p (42 :: Word8) + c_write writeFd p 1 + + takeMVar done diff --git a/tests/PipeNonBlockIO.ref b/tests/PipeNonBlockIO.ref new file mode 100644 index 000000000..f72c1fda9 --- /dev/null +++ b/tests/PipeNonBlockIO.ref @@ -0,0 +1,3 @@ +reader: waiting for data +main: writing to pipe +reader: received 42 From 53d0ddfaa88fec84b938d75214b34e2eb4a94560 Mon Sep 17 00:00:00 2001 From: Rewbert Date: Fri, 15 May 2026 21:50:20 +0200 Subject: [PATCH 13/16] remove macos support. Lennart will add it himself --- src/runtime/unix/config.h | 4 +- src/runtime/unix/io_poll_impl.c | 12 ++-- src/runtime/unix/io_poll_kqueue.c | 98 ------------------------------- 3 files changed, 7 insertions(+), 107 deletions(-) delete mode 100644 src/runtime/unix/io_poll_kqueue.c diff --git a/src/runtime/unix/config.h b/src/runtime/unix/config.h index 038cad044..701b86525 100644 --- a/src/runtime/unix/config.h +++ b/src/runtime/unix/config.h @@ -86,10 +86,10 @@ /* * Enable non-blocking IO polling. - * Linux uses epoll; macOS uses kqueue (not yet implemented). + * Linux uses epoll * The backend is selected in unix/io_poll_impl.c. */ -#if defined(__linux__) || (defined(__APPLE__) && defined(__MACH__)) +#if defined(__linux__) #define MHS_IO_POLL 1 #else #define MHS_IO_POLL 0 diff --git a/src/runtime/unix/io_poll_impl.c b/src/runtime/unix/io_poll_impl.c index 5cf870fee..574970f94 100644 --- a/src/runtime/unix/io_poll_impl.c +++ b/src/runtime/unix/io_poll_impl.c @@ -3,13 +3,11 @@ */ /* - * Selects the platform-specific IO poll backend for Unix targets. + * IO poll backend for Unix. + * + * Currently Linux only, using epoll. When a second implementation for MACOS is + * available, do some tricks here to dispatch the correct one. + * */ -#if defined(__linux__) #include "io_poll_epoll.c" -#elif defined(__APPLE__) && defined(__MACH__) -#include "io_poll_kqueue.c" -#else -#error "No IO poll backend available for this platform" -#endif diff --git a/src/runtime/unix/io_poll_kqueue.c b/src/runtime/unix/io_poll_kqueue.c deleted file mode 100644 index c3c3c47e7..000000000 --- a/src/runtime/unix/io_poll_kqueue.c +++ /dev/null @@ -1,98 +0,0 @@ -/* Copyright 2026 Robert Krook - * See LICENSE file for full license. - */ - -/* - * kqueue backend for non-blocking IO polling (macOS / BSD). - * This file is #included into eval.c via io_poll_impl.c. - * - * kqueue tracks EVFILT_READ and EVFILT_WRITE as independent (fd, filter) - * entries, so concurrent read and write waiters on the same fd do not - * conflict at the kqueue level. We still maintain a per-fd cookie table - * (mirroring the epoll backend) so that io_poll can dispatch to the correct - * waiting thread without storing the cookie in udata and casting. - */ - -#include -#include -#include - -/* Per-fd waiter state. */ -struct fd_state { - void *read_cookie; /* non-NULL while a thread is waiting for EVFILT_READ */ - void *write_cookie; /* non-NULL while a thread is waiting for EVFILT_WRITE */ -}; - -#define MAX_FDS 256 -static struct fd_state fd_table[MAX_FDS]; /* zero-initialised by the C runtime */ - -static int kqueue_fd = -1; -static int io_waiters = 0; - -void -io_init(void) -{ - kqueue_fd = kqueue(); - if (kqueue_fd < 0) { - ERR("kqueue failed"); - } -} - -/* If timeout_ms is 0 this is a non-blocking check; otherwise it blocks up to - timeout_ms milliseconds (or indefinitely when timeout_ms == -1). */ -void -io_poll(int timeout_ms, void (*on_ready)(void *cookie)) -{ - struct kevent evs[64]; - struct timespec ts; - struct timespec *tsp = NULL; - if (timeout_ms >= 0) { - ts.tv_sec = timeout_ms / 1000; - ts.tv_nsec = (long)(timeout_ms % 1000) * 1000000L; - tsp = &ts; - } - int n = kevent(kqueue_fd, NULL, 0, evs, 64, tsp); - for (int i = 0; i < n; i++) { - int fd = (int)evs[i].ident; - void *cookie = NULL; - if (evs[i].filter == EVFILT_READ) { - cookie = fd_table[fd].read_cookie; - fd_table[fd].read_cookie = NULL; - } else { - cookie = fd_table[fd].write_cookie; - fd_table[fd].write_cookie = NULL; - } - io_waiters--; - if (cookie) on_ready(cookie); - } -} - -/* Register fd to call on_ready(cookie) when the requested event is ready. - events is IO_POLL_READ or IO_POLL_WRITE. */ -void -io_register(int fd, int events, void *cookie) -{ - if (fd < 0 || fd >= MAX_FDS) ERR("io_register: fd out of range"); - - struct kevent ev; - int16_t filter; - if (events == IO_POLL_READ) { - fd_table[fd].read_cookie = cookie; - filter = EVFILT_READ; - } else { - fd_table[fd].write_cookie = cookie; - filter = EVFILT_WRITE; - } - - EV_SET(&ev, fd, filter, EV_ADD | EV_ONESHOT, 0, 0, 0); - if (kevent(kqueue_fd, &ev, 1, NULL, 0, NULL) < 0) { - ERR("kevent ADD failed"); - } - io_waiters++; -} - -int -io_waiter_count(void) -{ - return io_waiters; -} From 9c6ad1a75d93d5ed405ca229fdf8d052c927b26d Mon Sep 17 00:00:00 2001 From: Rewbert Date: Fri, 15 May 2026 21:52:55 +0200 Subject: [PATCH 14/16] try to make the linter happy? --- tests/PipeNonBlockIO.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/tests/PipeNonBlockIO.hs b/tests/PipeNonBlockIO.hs index cfe551788..0ca1828ad 100644 --- a/tests/PipeNonBlockIO.hs +++ b/tests/PipeNonBlockIO.hs @@ -1,5 +1,6 @@ module PipeNonBlockIO where +import Control.Monad (void) import Control.Concurrent import Control.Concurrent.MVar import Data.Word @@ -18,7 +19,7 @@ foreign import capi "fcntl.h value F_SETFL" fSETFL :: CInt foreign import capi "fcntl.h value O_NONBLOCK" oNONBLOCK :: CInt setNonBlocking :: CInt -> IO () -setNonBlocking fd = c_fcntl_setfl fd fSETFL oNONBLOCK >> return () +setNonBlocking fd = void (c_fcntl_setfl fd fSETFL oNONBLOCK) blockOnRead :: CInt -> IO Word8 blockOnRead fd = alloca $ \p -> go p From 35581bf5dfd011d2e97cdc1beb384f961a875497 Mon Sep 17 00:00:00 2001 From: Rewbert Date: Fri, 15 May 2026 22:06:28 +0200 Subject: [PATCH 15/16] add a return value to waitFor*FD, to notice whether MHS_IO_POLL is defined or not --- lib/System/IO/FD.hs | 4 ++-- src/runtime/eval.c | 12 +++++++----- 2 files changed, 9 insertions(+), 7 deletions(-) diff --git a/lib/System/IO/FD.hs b/lib/System/IO/FD.hs index c21d54fac..90993035c 100644 --- a/lib/System/IO/FD.hs +++ b/lib/System/IO/FD.hs @@ -2,8 +2,8 @@ module System.IO.FD (waitForReadFD, waitForWriteFD) where import Primitives -waitForReadFD :: Int -> IO () +waitForReadFD :: Int -> IO Int waitForReadFD = primWaitReadFD -waitForWriteFD :: Int -> IO () +waitForWriteFD :: Int -> IO Int waitForWriteFD = primWaitWriteFD \ No newline at end of file diff --git a/src/runtime/eval.c b/src/runtime/eval.c index 7e9eb7794..369b8f35d 100644 --- a/src/runtime/eval.c +++ b/src/runtime/eval.c @@ -2264,10 +2264,8 @@ struct { { "binbs1", T_BINBS1 }, { "unint1", T_UNINT1 }, { "undbl1", T_UNDBL1 }, -#if MHS_IO_POLL { "IO.waitrdfd", T_IO_WAITRDFD}, { "IO.waitwrfd", T_IO_WAITWRFD}, -#endif #if WANT_INT64 { "I+", T_ADD64, T_ADD64 }, { "I-", T_SUB64, T_SUBR64 }, @@ -6091,9 +6089,9 @@ evali(NODEPTR an) POP(2); GOPAIR(mkInt(mt->mt_state)); } -#if MHS_IO_POLL case T_IO_WAITRDFD: case T_IO_WAITWRFD: { +#if MHS_IO_POLL CHKARG2NP; /* x = the filedescriptor, y = RealWorld; no pop yet */ /* io_thread_ready sets mt_fd=IO_POLL_EVENT_HAS_HAPPENED when waking the thread. @@ -6104,7 +6102,7 @@ evali(NODEPTR an) if (runq.mq_head->mt_fd == IO_POLL_EVENT_HAS_HAPPENED) { runq.mq_head->mt_fd = IO_POLL_WAITING_FOR_NONE; POP(2); - GOPAIRUNIT; + GOPAIR(mkInt(1)); } POP(2); @@ -6121,8 +6119,12 @@ evali(NODEPTR an) io_register(fd, events, mt); resched(mt, ts_wait_io); - } +#else + CHKARG2NP; + POP(2); + GOPAIR(mkInt(-1)); #endif + } case T_IO_GETMASKINGSTATE: CHKARG1; /* x = ST */ GOPAIR(mkInt(runq.mq_head->mt_mask)); From 58436cc006203eb2abea1d92ef34e5dcf9f7103c Mon Sep 17 00:00:00 2001 From: Rewbert Date: Wed, 20 May 2026 12:09:00 +0200 Subject: [PATCH 16/16] fix type issue --- lib/Primitives.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lib/Primitives.hs b/lib/Primitives.hs index d0c31081f..17e116b53 100644 --- a/lib/Primitives.hs +++ b/lib/Primitives.hs @@ -389,10 +389,10 @@ primTryPutMVar = _primitive "IO.tryputmvar" primTryReadMVar :: MVar a -> IO b {-(Maybe a)-} primTryReadMVar = _primitive "IO.tryreadmvar" -primWaitWriteFD :: Int -> IO () +primWaitWriteFD :: Int -> IO Int primWaitWriteFD = _primitive "IO.waitwrfd" -primWaitReadFD :: Int -> IO () +primWaitReadFD :: Int -> IO Int primWaitReadFD = _primitive "IO.waitrdfd" primThreadDelay :: Int -> IO ()