Index: csm.scm
===================================================================
--- csm.scm	(revision 42186)
+++ csm.scm	(working copy)
@@ -101,6 +101,7 @@
 (define debug #f)
 (define *program-options* '())
 (define *main* #f)
+(define max-procs 1)
 
 (define scheme-extensions '("scm" "ss" "sch" "scheme" "r4rs" "r5rs" "r7rs" "sld"))
 
@@ -399,6 +400,54 @@
             (string=? (pathname-file (c-module-info-filename cm)) name))
           c-modules)))
 
+(define (to-levels tree topo cmp)
+  (define (depends-on? elem lvl)
+    (let ((adj-list (alist-ref elem tree cmp)))
+      (and adj-list (any (lambda (x) (member x adj-list cmp)) lvl))))
+  (let loop ((topo (reverse topo)) (lvls '()))
+    (match (cons topo lvls)
+      ((() . _)
+       lvls)
+      (((curr . next) . ())
+       (loop next (list (list curr))))
+      (((curr . next) . (x . y))
+       (let lvl-loop ((seen-lvl '())
+                      (cand-lvl '())
+                      (curr-lvl x)
+                      (next-lvl y))
+         (if (depends-on? curr curr-lvl)
+           (loop next
+                 (append seen-lvl
+                         (cons (cons curr cand-lvl)
+                               (cons curr-lvl next-lvl))))
+           (if (null? next-lvl)
+             (loop next
+                   (append seen-lvl
+                           (list cand-lvl)
+                           (list (cons curr curr-lvl))))
+
+             (lvl-loop
+               (append seen-lvl (if (null? cand-lvl) '() (list cand-lvl)))
+               curr-lvl
+               (car next-lvl)
+               (cdr next-lvl)))))))))
+
+(define (spawn levels fun)
+  (define (make-level lvl)
+    (let ((slots (min (length lvl) max-procs)))
+      (if (eq? 1 slots)
+        (map fun lvl)
+        (let loop ((idx 0) (chunk lvl) (pids '()))
+          (if (or (null? chunk) (eq? idx slots))
+            (begin
+              (unless
+                (fold (lambda (pid prev) (and prev (eq? 0 (nth-value 2 (process-wait pid))))) #t pids)
+                (exit 1))
+              (unless (null? chunk) (loop 0 chunk '())))
+            (let ((pid (process-fork (lambda () (fun (car chunk))))))
+              (loop (+ 1 idx) (cdr chunk) (cons pid pids))))))))
+  (map make-level levels))
+
 (define (build-system)
   (explain "building system")
   (for-each build-c-module c-modules)
@@ -406,18 +455,20 @@
                       (cons (module-info-name m)
                             (module-info-imports m)))
                     modules))
-         (ms (topological-sort tree string=?)))
+         (ms (topological-sort tree string=?))
+         (lvls (reverse (to-levels tree ms string=?))))
     (when (dribble "dependency tree:")
       (pp tree (current-error-port)))
     (when (dribble "build order:")
-      (pp (reverse ms) (current-error-port)))
+      (pp lvls (current-error-port)))
+
+    (spawn lvls
+           (lambda (name)
+             (let ((m (find-module name)))
+               (when (and m (not (module-info-main m)))
+                 (build-module m))))))
+
     (for-each
-      (lambda (name)
-        (let ((m (find-module name)))
-          (when (and m (not (module-info-main m)))
-            (build-module m))))
-      (reverse ms)))
-    (for-each
      build-program
      programs))
 
@@ -979,6 +1030,12 @@
         (("-clean" . more)
           (set! mode 'clean)
           (loop more))
+        (("-max-procs" num . more)
+          (let ((n (string->number num)))
+            (unless (and n (> n 0))
+              (fail "-max-procs expects a positive integer: ~a given" num))
+            (set! max-procs n))
+          (loop more))
         ((opt . more)
           (cond ((string-prefix? "-" opt)
                   (canonical-option