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

194
crossfire/agent.rkt
View File

@ -184,92 +184,136 @@
(agent-report-state aid 'error) (agent-report-state aid 'error)
(async-channel-put (current-queue) (cons 'stop aid))) (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)) (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 cmd (manifest-data-ref manifest 'command))
(define num-cpus (count-cpus))
(define smp? (first (manifest-data-ref manifest 'smp))) (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 mode (first (manifest-data-ref manifest 'mode)))
(define pattern (manifest-pattern manifest)) (define pattern (manifest-pattern manifest))
(for ([interval (in-list work-range)]) ;; split up into chunks per CPU
(define pp-start (resolve-pattern-pos pattern (pos->pattern-pos pattern (car interval)))) (define percpu-size (quotient (integer-set-count work-range) num-cpus))
(define pp-end (resolve-pattern-pos pattern (pos->pattern-pos pattern (cdr interval)))) (define pattern-ranges
(define args (for/fold ([args '()]) ([pps (in-vector pp-start)] [ppe (in-vector pp-end)]) (for/fold ([ranges '()] [pr work-range] #:result (cons pr ranges))
;; TODO : this isn't very efficient... ([i (in-range (sub1 num-cpus))])
(append args (list (number->string (car pps) 16) (define-values [pr-this pr-rest] (pattern-range-take pr percpu-size))
(number->string (cdr pps) 16) (values (cons pr-this ranges) pr-rest)))
(number->string (car ppe) 16) (for ([pr (in-list pattern-ranges)] [i (in-naturals)])
(number->string (cdr ppe) 16))))) (log-agent-info "assignment ~a cpu ~a: ~a" aid i (integer-set-contents pr)))
(define-values [proc input-proc out] (define (execute-cpu work-range)
(parameterize ([current-custodian cust] [current-directory extract-dir]) (for ([interval (in-list (integer-set-contents work-range))])
(match mode (define pp-start (resolve-pattern-pos pattern (pos->pattern-pos pattern (car interval))))
['callback (define pp-end (resolve-pattern-pos pattern (pos->pattern-pos pattern (cdr interval))))
(define-values [proc out in err] (define args (for/fold ([args '()]) ([pps (in-vector pp-start)] [ppe (in-vector pp-end)])
(apply subprocess #f #f (current-error-port) 'new (append cmd args))) ;; TODO : this isn't very efficient...
(values proc #f out)] (append args (list (number->string (car pps) 16)
['stdio (number->string (cdr pps) 16)
(define-values [ig-proc ig-out ig-in ig-err] (number->string (car ppe) 16)
(apply subprocess #f #f (current-error-port) 'new *default-cg-cmd* args)) (number->string (cdr ppe) 16)))))
(define-values [proc out in err]
(apply subprocess #f ig-out (current-error-port) 'new cmd))
(values proc ig-proc out)])))
(with-handlers ([exn:break? (lambda (_) (define-values [proc input-proc out]
(log-agent-info "killing process for ~a" aid) (parameterize ([current-custodian cust] [current-directory extract-dir])
;; nicely ask the process to stop (match mode
(subprocess-kill proc #f) ['callback
(when input-proc (define-values [proc out in err]
(subprocess-kill input-proc)) (apply subprocess #f #f (current-error-port) 'new (append cmd args)))
(sync/timeout *subproc-kill-delay* proc) (values proc #f out)]
;; will handle killing for us :P ['stdio
(custodian-shutdown-all cust) (define-values [ig-proc ig-out ig-in ig-err]
;; exit without reporting status (apply subprocess #f #f (current-error-port) 'new *default-cg-cmd* args))
(kill-thread (current-thread)))]) (define-values [proc out in err]
(define line-match (regexp-match-evt #px"^[^\n]*\n" out)) (apply subprocess #f ig-out (current-error-port) 'new cmd))
(define eof-e (eof-evt out)) (values proc ig-proc out)])))
(let loop ([reached-eof #f] [proc-done #f])
(match (sync/enable-break proc line-match eof-e)
[(== proc)
(unless reached-eof
(loop reached-eof #t))]
[(? eof-object?)
(unless proc-done
(loop #t proc-done))]
[(list line)
(define line-str (bytes->string/utf-8 line #\?))
(define line-parts
(and line-str
(map (lambda (x) (string->number x 16))
(string-split (string-trim line-str) " "))))
;; check format, if it looks correct-ish then report it
;; otherwise warn
;; it will be #f if the line failed to decode as utf-8
;; theoretically since we're only dealing with 0-9a-f we could also just decode as
;; ascii but i like utf-8 so whatever potential bugs i'm introducing with this be
;; hecked tbh
(if (and ((listof integer?) line-parts)
(= (length line-parts) (vector-length (manifest-pattern manifest))))
(report-success/retry aid line-parts)
(log-agent-warning "assignment ~a input loop got unparseable line ~s" aid line))
(loop reached-eof proc-done)]
[x (log-agent-warning "assignment ~a input loop got unexpected value ~a" aid x)
(loop reached-eof proc-done)])))
(define errcode (subprocess-status proc)) (with-handlers ([exn:break? (lambda (_)
(log-agent-info "assignment ~a process exited with code ~a" aid errcode) (log-agent-info "killing process for ~a" aid)
;; report error if it's a nonzero exit code ;; nicely ask the process to stop
(unless (zero? errcode) (subprocess-kill proc #f)
(error "process exited with nonzero code" errcode)))) (when input-proc
(subprocess-kill input-proc))
(sync/timeout *subproc-kill-delay* proc)
;; exit without reporting status
(kill-thread (current-thread)))])
(define line-match (regexp-match-evt #px"^[^\n]*\n" out))
(define eof-e (eof-evt out))
(let loop ([reached-eof #f] [proc-done #f])
(match (sync/enable-break proc line-match eof-e)
[(== proc)
(unless reached-eof
(loop reached-eof #t))]
[(? eof-object?)
(unless proc-done
(loop #t proc-done))]
[(list line)
(define line-str (bytes->string/utf-8 line #\?))
(define line-parts
(and line-str
(map (lambda (x) (string->number x 16))
(string-split (string-trim line-str) " "))))
;; check format, if it looks correct-ish then report it
;; otherwise warn
;; it will be #f if the line failed to decode as utf-8
;; theoretically since we're only dealing with 0-9a-f we could also just decode as
;; ascii but i like utf-8 so whatever potential bugs i'm introducing with this be
;; hecked tbh
(if (and ((listof integer?) line-parts)
(= (length line-parts) (vector-length (manifest-pattern manifest))))
(report-success/retry aid line-parts)
(log-agent-warning "assignment ~a input loop got unparseable line ~s" aid line))
(loop reached-eof proc-done)]
[x (log-agent-warning "assignment ~a input loop got unexpected value ~a" aid x)
(loop reached-eof proc-done)])))
(cleanup) (define errcode (subprocess-status proc))
(void)) (log-agent-info "assignment ~a process exited with code ~a" aid errcode)
;; report error if it's a nonzero exit code
(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))
;; utils ;; utils