implement smp mode, but right now it's slower u__u

crossfire/agent.rkt

@@ -184,20 +184,33 @@
     (agent-report-state aid 'error)
     (async-channel-put (current-queue) (cons 'stop aid)))
 
-  (with-handlers ([exn:fail? report-error])
+  (with-handlers ([exn:fail? report-error]
-    (define work-range (assignment-work-range assignment))
+                  ;; in the case of a break (sent from the main thread in response to a cancel),
+                  ;; kill this thread without reporting status
+                  [exn:break? (lambda (ex) (kill-thread (current-thread)))])
+    (define work-range (make-integer-set (assignment-work-range assignment)))
     (define manifest (assignment-manifest assignment))
-    (log-agent-info "the work for assignment ~a is ~a" aid work-range)
+    (log-agent-info "the work for assignment ~a is ~a" aid (integer-set-contents work-range))
 
     (define cmd (manifest-data-ref manifest 'command))
-    (define num-cpus (count-cpus))
     (define smp? (first (manifest-data-ref manifest 'smp)))
-    ;; TODO : handle smp
+    ;; in non-smp mode, we just pretend there's only one cpu
+    (define num-cpus (if smp? (count-cpus) 1))
     (define mode (first (manifest-data-ref manifest 'mode)))
-
     (define pattern (manifest-pattern manifest))
 
-    (for ([interval (in-list work-range)])
+    ;; split up into chunks per CPU
+    (define percpu-size (quotient (integer-set-count work-range) num-cpus))
+    (define pattern-ranges
+      (for/fold ([ranges '()] [pr work-range] #:result (cons pr ranges))
+                ([i (in-range (sub1 num-cpus))])
+        (define-values [pr-this pr-rest] (pattern-range-take pr percpu-size))
+        (values (cons pr-this ranges) pr-rest)))
+    (for ([pr (in-list pattern-ranges)] [i (in-naturals)])
+      (log-agent-info "assignment ~a cpu ~a: ~a" aid i (integer-set-contents pr)))
+
+    (define (execute-cpu work-range)
+      (for ([interval (in-list (integer-set-contents work-range))])
         (define pp-start (resolve-pattern-pos pattern (pos->pattern-pos pattern (car interval))))
         (define pp-end (resolve-pattern-pos pattern (pos->pattern-pos pattern (cdr interval))))
         (define args (for/fold ([args '()]) ([pps (in-vector pp-start)] [ppe (in-vector pp-end)])
@@ -228,8 +241,6 @@
                                       (when input-proc
                                         (subprocess-kill input-proc))
                                       (sync/timeout *subproc-kill-delay* proc)
-                                    ;; will handle killing for us :P
-                                    (custodian-shutdown-all cust)
                                       ;; exit without reporting status
                                       (kill-thread (current-thread)))])
           (define line-match (regexp-match-evt #px"^[^\n]*\n" out))
@@ -268,6 +279,39 @@
         (unless (zero? errcode)
           (error "process exited with nonzero code" errcode))))
 
+    (define (execute-cpu-wrap work-range result-box)
+      (with-handlers ([exn? (lambda (ex) (set-box! result-box ex))])
+        (execute-cpu work-range)))
+
+    ;; SMP manager thread
+    (break-enabled #f)
+    ;; create one child thread (managing a subprocess or pair of piped subprocesses) per
+    ;; cpu-task-list
+    (define children
+      (parameterize ([current-custodian cust])
+        (for/list ([i (in-naturals)] [wr (in-list pattern-ranges)])
+                         (define b (box #f))
+                         (cons (thread (lambda () (execute-cpu-wrap wr b))) b))))
+    (let loop ()
+      (with-handlers ([exn? (lambda (ex)
+                              (log-agent-error "stopping assignment ~a due to error" aid)
+                              ;; break all children
+                              (map (compose break-thread car) children)
+                              (apply sync/timeout (+ *subproc-kill-delay* 2)
+                                     (map car children))
+                              ;; kill all children and subprocesses that may be remaining
+                              (custodian-shutdown-all)
+                              ;; reraise
+                              (raise ex))])
+        (apply sync/enable-break (map car children))
+        (define threads-running? (ormap (compose thread-running? car) children))
+        (define any-exn (ormap (compose unbox cdr) children))
+        (when any-exn
+          (raise any-exn))
+        (when threads-running?
+          (loop))))
+    (break-enabled #t))
+
   (cleanup)
   (void))