From 8b2c08a8366d1af6d2a59b7733558fe6b8d54ba7 Mon Sep 17 00:00:00 2001 From: Kevin Tew Date: Fri, 10 Sep 2010 10:01:45 -0600 Subject: [PATCH] Parallel Build: fix error reporting --- collects/setup/parallel-build.rkt | 36 +++++++++++++++---------------- collects/setup/setup-unit.rkt | 15 +++++++------ 2 files changed, 26 insertions(+), 25 deletions(-) diff --git a/collects/setup/parallel-build.rkt b/collects/setup/parallel-build.rkt index 0d2d0937ca..79cf3fff2a 100644 --- a/collects/setup/parallel-build.rkt +++ b/collects/setup/parallel-build.rkt @@ -11,22 +11,21 @@ (provide parallel-compile 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 #:property prop:jobqueue (define-methods jobqueue (define (work-done jobqueue work workerid 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)]) - (match result-type - [(list 'ERROR msg) - ((collects-queue-printer jobqueue) (current-error-port) "ERROR" "~a ~a: ~a" cc-name file msg)] - ['DONE (void)]) - (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) - (eprintf "STDOUT:\n~a=====\n" out) - (eprintf "STDERR:\n~a=====\n" err)))])) + (match result-type + [(list 'ERROR msg) + ((collects-queue-append-error jobqueue) cc "making" (exn msg (current-continuation-marks)) out err "error")] + ['DONE + (when (or (not (zero? (string-length out))) (not (zero? (string-length err)))) + ((collects-queue-append-error jobqueue) cc "making" null out err "output"))]) + (when last ((collects-queue-printer jobqueue) (current-output-port) "made" "~a" cc-name )))])) ;; assigns a collection to each worker to be compiled ;; when it runs out of collections, steals work from other workers collections (define (get-job jobqueue workerid) @@ -46,7 +45,7 @@ (set-collects-queue-cclst! jobqueue t) (list h)])) (let ([w-hash (collects-queue-hash jobqueue)]) - (define (build-job cc file) + (define (build-job cc file last) (define (->bytes x) (cond [(path? x) (path->bytes x)] [(string? x) (string->bytes/locale x)])) @@ -54,7 +53,7 @@ [cc-path (cc-path cc)] [full-path (path->string (build-path 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 () (define (find-job-in-cc cc id) (match cc @@ -68,11 +67,10 @@ (hash-set! w-hash id (append subs tail)) (retry)] [(cons (list cc (list file) 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)] + (build-job cc file #t)] [(cons (list cc (cons file 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) [#f (match (hash/first-pair w-hash) @@ -95,18 +93,18 @@ (for/fold ([cnt 0]) ([cct (in-hash-values (collects-queue-hash jobqueue))]) (+ 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)]) (setup-fprintf (current-output-port) #f "--- parallel build using ~a processor cores ---" worker-count) (parallel-do-event-loop #f - (lambda (id) id) + values ; identity function (list (current-executable-path) "-X" (path->string collects-dir) "-l" "setup/parallel-build-worker.rkt") - (make-collects-queue collects-tree (make-hash) collects-dir setup-fprintf) - worker-count 999999999))) + (make-collects-queue collects-tree (make-hash) collects-dir setup-fprintf append-error) + worker-count 999999999))) (define (parallel-build-worker) (let ([cmc (make-caching-managed-compile-zo)] diff --git a/collects/setup/setup-unit.rkt b/collects/setup/setup-unit.rkt index 5283366ad0..b8e1e93663 100644 --- a/collects/setup/setup-unit.rkt +++ b/collects/setup/setup-unit.rkt @@ -88,6 +88,8 @@ ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (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) (with-handlers ([exn:fail? (lambda (x) @@ -96,7 +98,7 @@ (format "~a\n" (exn->string x)) 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))]) (go))) (define-syntax begin-record-error @@ -104,10 +106,11 @@ [(_ cc desc body ...) (record-error cc desc (lambda () body ...) void)])) (define (show-errors port) (for ([e (reverse errors)]) - (match-let ([(list cc desc x) e]) - (setup-fprintf port "error" "during ~a for ~a" - desc (if (cc? cc) (cc-name cc) cc)) - (setup-fprintf port #f " ~a" (exn->string x))))) + (match-let ([(list cc desc x out err type) e]) + (setup-fprintf port type "during ~a for ~a" desc (if (cc? cc) (cc-name cc) cc)) + (when (not (null? 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) (setup-printf #f "done") @@ -668,7 +671,7 @@ (let ([dir (cc-path cc)] [info (cc-info cc)]) (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]) (compile-cc cc gcs)))] [else