semaphore: Teach semThreadWait to use semWait with threaded RTS

semThreadWait uses a rather atrocious polling loop to avoid
blocking, which we block the entire program when using the non-threaded
runtime. However, this is unnecessary in the threaded runtime, where we
can instead simply block in semWait. Take advantage of this.

Fixes #253.

Author: bgamari

System/Posix/Semaphore.hsc

@@ -39,6 +39,13 @@ import Foreign.Marshal
 import Foreign.Storable
 #endif
 
+#if __GLASGOW_HASKELL__ >= 902
+import System.Posix.Internals (hostIsThreaded)
+#else
+hostIsThreaded :: Bool
+hostIsThreaded = False
+#endif
+
 data OpenSemFlags = OpenSemFlags { semCreate :: Bool,
                                    -- ^ If true, create the semaphore if it
                                    --   does not yet exist.
@@ -96,9 +103,15 @@ semTryWait (Semaphore fptr) = withForeignPtr fptr semTrywait'
 --   semWait, this will block only the current thread rather than the
 --   entire process.
 semThreadWait :: Semaphore -> IO ()
-semThreadWait sem = do res <- semTryWait sem
-                       (if res then return ()
-                        else ( do { yield; semThreadWait sem } ))
+semThreadWait sem
+  -- N.B. semWait can be safely used in the case of the threaded runtime, where
+  -- the safe foreign call will be performed in its own thread, thereby not
+  -- blocking the process.
+  | hostIsThreaded = semWait sem
+  | otherwise = do
+      res <- semTryWait sem
+      if res then return ()
+             else do yield >> semThreadWait sem
 
 -- | Unlock the semaphore.
 semPost :: Semaphore -> IO ()

test-wasm32-wasi.mjs

@@ -8,7 +8,7 @@ const my_execFile = util.promisify(child_process.execFile);
 let warns_count = 0;
 for (const f of await fs.promises.readdir("tests")) {
   // odd linker errors
-  if (f === "Semaphore001.hs") continue;
+  if (f.startsWith('Semaphore')) continue;
   // Find self-contained test cases (aka doesn't rely on tasty)
   if (!f.endsWith(".hs")) continue;
   const s = await fs.promises.readFile(`tests/${f}`, "utf-8");

tests/Semaphore002.hs

@@ -0,0 +1,15 @@
+module Main (main) where
+
+import Control.Concurrent
+import System.Posix
+
+main :: IO ()
+main = do
+  sem <- semOpen "/test" OpenSemFlags {semCreate = True, semExclusive = False} stdFileMode 0
+  forkIO $ do
+      threadDelay (1000*1000)
+      semPost sem
+
+  -- This should succeed after 1 second.
+  semThreadWait sem
+  semPost sem

unix.cabal

@@ -262,3 +262,11 @@ test-suite Semaphore001
     default-language: Haskell2010
     build-depends: base, unix
     ghc-options: -Wall
+
+test-suite Semaphore002
+    hs-source-dirs: tests
+    main-is: Semaphore002.hs
+    type: exitcode-stdio-1.0
+    default-language: Haskell2010
+    build-depends: base, unix
+    ghc-options: -Wall -threaded