Concurrent.hs

{-# LANGUAGE ForeignFunctionInterface #-}
module Control.Concurrent (forkOS, ThreadId) where
import Foreign.Ptr
import Foreign.StablePtr
import Foreign.Storable
import Foreign.Marshal.Alloc
import Control.Monad (when)
import Jhc.Prim.Rts

data {-# CTYPE "rts/conc.h jhc_threadid_t" #-} CthreadIdT
data ThreadId = ThreadId CthreadIdT

foreign import ccall "rts/conc.h forkOS_createThread" forkOScreateThread ::
   FunPtr (Bang_ (StablePtr (IO ())) -> IO (Ptr ())) -> Bang_ a -> Ptr Int -> IO CthreadIdT

forkOScreateThreadWrapper :: Bang_ (StablePtr (IO ())) -> IO (Ptr ())
forkOScreateThreadWrapper b = do
  let s = fromBang_ b
  d <- deRefStablePtr s
  d
  freeStablePtr s
  return nullPtr

foreign export ccall "forkOScreateThreadWrapper" forkOScreateThreadWrapper ::
  Bang_ (StablePtr (IO ())) -> IO (Ptr ())
foreign import ccall "&forkOScreateThreadWrapper" p_forkOScreateThreadWrapper ::
  FunPtr (Bang_ (StablePtr (IO ())) -> IO (Ptr ()))

forkOS :: IO () -> IO ThreadId
forkOS f = alloca $ \ip -> do
  s <- newStablePtr f
  pth <- forkOScreateThread p_forkOScreateThreadWrapper (toBang_ s) ip
  i <- peek ip
  when (i /= 0) $ fail "Cannot create OS thread."
  return $ ThreadId pth