1 files changed, 22 insertions, 6 deletions
diff --git a/Omni/Bild.hs b/Omni/Bild.hs
index dbae550..414049b 100755
--- a/Omni/Bild.hs
+++ b/Omni/Bild.hs
@@ -119,6 +119,8 @@ module Omni.Bild where
 import Alpha hiding (sym, (<.>))
 import qualified Conduit
 import qualified Control.Concurrent.Async as Async
+import qualified Control.Concurrent.QSemN as QSemN
+import qualified Control.Exception as Exception
 import qualified Data.Aeson as Aeson
 import qualified Data.ByteString as ByteString
 import qualified Data.ByteString.Char8 as Char8
@@ -154,6 +156,15 @@ import qualified System.Process as Process
 import qualified System.Timeout as Timeout
 import qualified Text.Regex.Applicative as Regex
 
+mapConcurrentlyBounded :: Int -> (a -> IO b) -> [a] -> IO [b]
+mapConcurrentlyBounded n f xs = do
+  sem <- QSemN.newQSemN n
+  Async.forConcurrently xs <| \x ->
+    Exception.bracket_
+      (QSemN.waitQSemN sem 1)
+      (QSemN.signalQSemN sem 1)
+      (f x)
+
 main :: IO ()
 main = Cli.Plan help move test_ pure |> Cli.main
   where
@@ -940,10 +951,15 @@ test loud Target {..} =
           >> pure (Exit.ExitFailure 1, mempty)
 
 build :: Bool -> Bool -> Int -> Int -> Analysis -> IO [Exit.ExitCode]
-build andTest loud jobs cpus analysis =
-  Env.getEnv "CODEROOT" +> \root ->
-    forM (Map.elems analysis) <| \target@Target {..} ->
-      fst </ case compiler of
+build andTest loud jobs cpus analysis = do
+  root <- Env.getEnv "CODEROOT"
+  let targets = Map.elems analysis
+  results <- mapConcurrentlyBounded jobs (buildTarget root) targets
+  pure (map fst results)
+  where
+    buildTarget :: FilePath -> Target -> IO (Exit.ExitCode, ByteString)
+    buildTarget root target@Target {..} =
+      case compiler of
         CPython -> case out of
           Just _ ->
             Log.info ["bild", "nix", "python", nschunk namespace]
@@ -997,9 +1013,9 @@ build andTest loud jobs cpus analysis =
         Rustc ->
           Log.info ["bild", "dev", "rust", nschunk namespace]
             >> nixBuild loud jobs cpus target
-        Sbcl -> do
+        Sbcl ->
           Log.info ["bild", "dev", "lisp", nschunk namespace]
-          proc loud namespace (toNixFlag compiler) compilerFlags
+            >> proc loud namespace (toNixFlag compiler) compilerFlags
 
 data Proc = Proc
   { loud :: Bool,