Testing concurrency of unsafe ffi calls

keep_sleeping.c

#include <errno.h>
#include <time.h>
#include <stdio.h>

// from https://stackoverflow.com/a/28294792/15207568

/* same as 'sleep' except it doesn't get interrupted by signals */
int keep_sleeping(unsigned long sec) {
    printf("START SLEEPING\n");
    struct timespec rem, req = { (time_t) sec, 0 }; /* warning: may overflow */
    while ((rem.tv_sec || rem.tv_nsec) && nanosleep(&req, &rem)) {
        if (errno != EINTR) /* this check is probably unnecessary */
            return -1;
        req = rem;
    }
    printf("STOP SLEEPING\n");
    return 0;
}

Main.hs

import Foreign.C
import Control.Concurrent
import System.IO.Unsafe
import Data.Foldable

foreign import ccall unsafe "keep_sleeping" c_keep_sleeping :: CInt -> IO CInt

{-# NOINLINE children #-}
children :: MVar [MVar ()]
children = unsafePerformIO (newMVar [])

waitForChildren :: IO ()
waitForChildren = do
  cs <- takeMVar children
  case cs of
    []   -> return ()
    m:ms -> do
       putMVar children ms
       takeMVar m
       waitForChildren

forkChild :: IO () -> IO ThreadId
forkChild io = do
  mvar <- newEmptyMVar
  childs <- takeMVar children
  putMVar children (mvar:childs)
  forkFinally io (\_ -> putMVar mvar ())

worker :: Int -> IO ()
worker i = do
  putStrLn $ "START " ++ show i
  c_keep_sleeping 1
  putStrLn $ "STOP " ++ show i

main :: IO ()
main = do
  traverse_ (forkChild . worker) [0..3]
  waitForChildren