suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Parallel Build: fix error reporting

Browse Source
This commit is contained in:
Kevin Tew 2010-09-10 10:01:45 -06:00
parent 17cdb9eb3b
commit 8b2c08a836
2 changed files with 26 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

36
collects/setup/parallel-build.rkt
View File

@ -11,22 +11,21 @@
(provide parallel-compile (provide parallel-compile
parallel-build-worker) parallel-build-worker)
(define-struct collects-queue (cclst hash collects-dir printer) #:transparent (define-struct collects-queue (cclst hash collects-dir printer append-error) #:transparent
#:mutable #:mutable
#:property prop:jobqueue #:property prop:jobqueue
(define-methods jobqueue (define-methods jobqueue
(define (work-done jobqueue work workerid msg) (define (work-done jobqueue work workerid msg)
(match (list work msg) (match (list work msg)
[(list (list cc file) (list result-type out err)) [(list (list cc file last) (list result-type out err))
(let ([cc-name (cc-name cc)]) (let ([cc-name (cc-name cc)])
(match result-type (match result-type
[(list 'ERROR msg) [(list 'ERROR msg)
((collects-queue-printer jobqueue) (current-error-port) "ERROR" "~a ~a: ~a" cc-name file msg)] ((collects-queue-append-error jobqueue) cc "making" (exn msg (current-continuation-marks)) out err "error")]
['DONE (void)]) ['DONE
(when (or (not (zero? (string-length out))) (not (zero? (string-length err)))) (when (or (not (zero? (string-length out))) (not (zero? (string-length err))))
((collects-queue-printer jobqueue) (current-error-port) "build-output" "~a ~a" cc-name file) ((collects-queue-append-error jobqueue) cc "making" null out err "output"))])
(eprintf "STDOUT:\n~a=====\n" out) (when last ((collects-queue-printer jobqueue) (current-output-port) "made" "~a" cc-name )))]))
(eprintf "STDERR:\n~a=====\n" err)))]))
;; assigns a collection to each worker to be compiled ;; assigns a collection to each worker to be compiled
;; when it runs out of collections, steals work from other workers collections ;; when it runs out of collections, steals work from other workers collections
(define (get-job jobqueue workerid) (define (get-job jobqueue workerid)
@ -46,7 +45,7 @@
(set-collects-queue-cclst! jobqueue t) (set-collects-queue-cclst! jobqueue t)
(list h)])) (list h)]))
(let ([w-hash (collects-queue-hash jobqueue)]) (let ([w-hash (collects-queue-hash jobqueue)])
(define (build-job cc file) (define (build-job cc file last)
(define (->bytes x) (define (->bytes x)
(cond [(path? x) (path->bytes x)] (cond [(path? x) (path->bytes x)]
[(string? x) (string->bytes/locale x)])) [(string? x) (string->bytes/locale x)]))
@ -54,7 +53,7 @@
[cc-path (cc-path cc)] [cc-path (cc-path cc)]
[full-path (path->string (build-path cc-path file))]) [full-path (path->string (build-path cc-path file))])
;(printf "JOB ~a ~a ~a ~a\n" workerid cc-name cc-path file) ;(printf "JOB ~a ~a ~a ~a\n" workerid cc-name cc-path file)
(values (list cc file) (list cc-name (->bytes cc-path) (->bytes file))))) (values (list cc file last) (list cc-name (->bytes cc-path) (->bytes file)))))
(let retry () (let retry ()
(define (find-job-in-cc cc id) (define (find-job-in-cc cc id)
(match cc (match cc
@ -68,11 +67,10 @@
(hash-set! w-hash id (append subs tail)) (retry)] (hash-set! w-hash id (append subs tail)) (retry)]
[(cons (list cc (list file) subs) tail) [(cons (list cc (list file) subs) tail)
(hash-set! w-hash id (append subs tail)) (hash-set! w-hash id (append subs tail))
((collects-queue-printer jobqueue) (current-output-port) "made" "~a" (cc-name cc)) (build-job cc file #t)]
(build-job cc file)]
[(cons (list cc (cons file ft) subs) tail) [(cons (list cc (cons file ft) subs) tail)
(hash-set! w-hash id (cons (list cc ft subs) tail)) (hash-set! w-hash id (cons (list cc ft subs) tail))
(build-job cc file)])) (build-job cc file #f)]))
(match (hash-ref!/true w-hash workerid take-cc) (match (hash-ref!/true w-hash workerid take-cc)
[#f [#f
(match (hash/first-pair w-hash) (match (hash/first-pair w-hash)
@ -95,18 +93,18 @@
(for/fold ([cnt 0]) ([cct (in-hash-values (collects-queue-hash jobqueue))]) (for/fold ([cnt 0]) ([cct (in-hash-values (collects-queue-hash jobqueue))])
(+ cnt (count-cct cct))))))) (+ cnt (count-cct cct)))))))
(define (parallel-compile worker-count setup-fprintf collects-tree) (define (parallel-compile worker-count setup-fprintf append-error collects-tree)
(let ([collects-dir (current-collects-path)]) (let ([collects-dir (current-collects-path)])
(setup-fprintf (current-output-port) #f "--- parallel build using ~a processor cores ---" worker-count) (setup-fprintf (current-output-port) #f "--- parallel build using ~a processor cores ---" worker-count)
(parallel-do-event-loop #f (parallel-do-event-loop #f
(lambda (id) id) values ; identity function
(list (current-executable-path) (list (current-executable-path)
"-X" "-X"
(path->string collects-dir) (path->string collects-dir)
"-l" "-l"
"setup/parallel-build-worker.rkt") "setup/parallel-build-worker.rkt")
(make-collects-queue collects-tree (make-hash) collects-dir setup-fprintf) (make-collects-queue collects-tree (make-hash) collects-dir setup-fprintf append-error)
worker-count 999999999))) worker-count 999999999)))
(define (parallel-build-worker) (define (parallel-build-worker)
(let ([cmc (make-caching-managed-compile-zo)] (let ([cmc (make-caching-managed-compile-zo)]

15
collects/setup/setup-unit.rkt
View File

@ -88,6 +88,8 @@
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define errors null) (define errors null)
(define (append-error cc desc exn out err type)
(set! errors (cons (list cc desc exn out err type) errors)))
(define (record-error cc desc go fail-k) (define (record-error cc desc go fail-k)
(with-handlers ([exn:fail? (with-handlers ([exn:fail?
(lambda (x) (lambda (x)
@ -96,7 +98,7 @@
(format "~a\n" (exn->string x)) (format "~a\n" (exn->string x))
x) x)
(fprintf (current-error-port) "~a\n" (exn->string x))) (fprintf (current-error-port) "~a\n" (exn->string x)))
(set! errors (cons (list cc desc x) errors)) (append-error cc desc x "" "" "error")
(fail-k))]) (fail-k))])
(go))) (go)))
(define-syntax begin-record-error (define-syntax begin-record-error
@ -104,10 +106,11 @@
[(_ cc desc body ...) (record-error cc desc (lambda () body ...) void)])) [(_ cc desc body ...) (record-error cc desc (lambda () body ...) void)]))
(define (show-errors port) (define (show-errors port)
(for ([e (reverse errors)]) (for ([e (reverse errors)])
(match-let ([(list cc desc x) e]) (match-let ([(list cc desc x out err type) e])
(setup-fprintf port "error" "during ~a for ~a" (setup-fprintf port type "during ~a for ~a" desc (if (cc? cc) (cc-name cc) cc))
desc (if (cc? cc) (cc-name cc) cc)) (when (not (null? x)) (setup-fprintf port #f " ~a" (exn->string x)))
(setup-fprintf port #f " ~a" (exn->string x))))) (when (not (zero? (string-length out))) (eprintf "STDOUT:\n~a=====\n" out))
(when (not (zero? (string-length err))) (eprintf "STDERR:\n~a=====\n" err)))))
(define (done) (define (done)
(setup-printf #f "done") (setup-printf #f "done")
@ -668,7 +671,7 @@
(let ([dir (cc-path cc)] (let ([dir (cc-path cc)]
[info (cc-info cc)]) [info (cc-info cc)])
(clean-cc dir info))) cct) (clean-cc dir info))) cct)
(parallel-compile (parallel-workers) setup-fprintf cct)) (parallel-compile (parallel-workers) setup-fprintf append-error cct))
(for/fold ([gcs 0]) ([cc planet-dirs-to-compile]) (for/fold ([gcs 0]) ([cc planet-dirs-to-compile])
(compile-cc cc gcs)))] (compile-cc cc gcs)))]
[else [else