haskal
/
crossfire
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

This commit is contained in:
xenia 2021-01-10 02:21:42 -05:00
parent d08892d6e9
commit f9486817ed
1 changed files with 119 additions and 75 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

62
crossfire/agent.rkt
View File

@ -184,20 +184,33 @@
(agent-report-state aid 'error)
(async-channel-put (current-queue) (cons 'stop aid)))
(with-handlers ([exn:fail? report-error])
(define work-range (assignment-work-range assignment))
(with-handlers ([exn:fail? report-error]
;; 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))