diff --git a/pkgs/racket-pkgs/racket-doc/scribblings/raco/make.scrbl b/pkgs/racket-pkgs/racket-doc/scribblings/raco/make.scrbl index f562c2133b..483ca2cb8b 100644 --- a/pkgs/racket-pkgs/racket-doc/scribblings/raco/make.scrbl +++ b/pkgs/racket-pkgs/racket-doc/scribblings/raco/make.scrbl @@ -267,6 +267,20 @@ referenced by not-yet-loaded modules. References to already-loaded modules may produce compiled files with inconsistent timestamps and/or @filepath{.dep} files with incorrect information.} +The handler logs messages to the topic @racket['compiler/cm] at the level +@racket['info]. These messages are instances of a @racket[compile-event] prefab +structure: + +@racketblock[ + (struct compile-event (timestamp path type) #:prefab) +] + +The @racket[timestamp] field is the time at which the event occured in +milliseconds since the epoch. The @racket[path] field is the path of a file +being compiled for which the event is about. The @racket[type] field is a symbol +which describes the action the event corresponds to. The currently logged values +are @racket['locking], @racket['start-compile], @racket['finish-compile], and +@racket['already-done]. @defproc[(managed-compile-zo [file path-string?] [read-src-syntax (any/c input-port? . -> . syntax?) read-syntax] @@ -293,7 +307,6 @@ the files are created is used (not the security guard at the point @racket[managed-compile-zo] is called). } - @defboolparam[trust-existing-zos trust?]{ A parameter that is intended for use by @exec{setup-plt} when @@ -467,7 +480,7 @@ functionality of @exec{raco setup} and @exec{raco make}.} void]) (or/c void? #f)]{ -The @racket[parallel-compile] utility function is used by @exec{raco make} to +The @racket[parallel-compile-files] utility function is used by @exec{raco make} to compile a list of paths in parallel. The optional @racket[#:worker-count] argument specifies the number of compile workers to spawn during parallel compilation. The callback, @racket[handler], is called with the symbol @@ -517,6 +530,19 @@ datastructure containing an in-memory tree representation of the collects directory. } +Both @racket[parallel-compile-files] and @racket[parallel-compile] log messages +to the topic @racket['setup/parallel-build] at the level @racket['info]. These +messages are instances of a @racket[parallel-compile-event] prefab structure: + + +@racketblock[ + (struct parallel-compile-event (worker event) #:prefab) +]. + +The worker field is the index of the worker that the created the event. The event +field is a @racket[compile-event] as document in +@racket[make-compilation-manager-load/use-compiled-handler]. + @; ---------------------------------------------------------------------- @section{Compilation Manager Hook for Syntax Transformers} diff --git a/racket/collects/compiler/cm.rkt b/racket/collects/compiler/cm.rkt index 43e4cda49d..7f8f9595be 100644 --- a/racket/collects/compiler/cm.rkt +++ b/racket/collects/compiler/cm.rkt @@ -34,6 +34,12 @@ (when (log-level? cm-logger 'debug) (log-message cm-logger 'debug str (current-inexact-milliseconds)))) +(struct compile-event (timestamp path action) #:prefab) +(define (log-compile-event path action) + (when (log-level? cm-logger 'info 'compiler/cm) + (log-message cm-logger 'info (format "~a: ~a" action path) + (compile-event (current-inexact-milliseconds) path action)))) + (define manager-compile-notify-handler (make-parameter void)) (define manager-trace-handler (make-parameter default-manager-trace-handler)) (define indent (make-parameter "")) @@ -505,12 +511,14 @@ ((if sha1-only? values (lambda (build) (build) #f)) (lambda () (let* ([lc (parallel-lock-client)] + [_ (when lc (log-compile-event path 'locking))] [locked? (and lc (lc 'lock zo-name))] [ok-to-compile? (or (not lc) locked?)]) (dynamic-wind (lambda () (void)) (lambda () (when ok-to-compile? + (log-compile-event path 'start-compile) (when zo-exists? (try-delete-file zo-name #f)) (log-info (format "cm: ~acompiling ~a" (build-string @@ -532,6 +540,8 @@ (λ (x) (if (= 2 (modulo x 3)) #\| #\space))) actual-path)))) (lambda () + (when lc + (log-compile-event path (if locked? 'finish-compile 'already-done))) (when locked? (lc 'unlock zo-name)))))))))))) (unless sha1-only? diff --git a/racket/collects/setup/parallel-build.rkt b/racket/collects/setup/parallel-build.rkt index d7b90b56a6..60ea0abf3e 100644 --- a/racket/collects/setup/parallel-build.rkt +++ b/racket/collects/setup/parallel-build.rkt @@ -24,6 +24,11 @@ ; (begin a ...) ) +(struct parallel-compile-event (worker value) #:prefab) +;; Logger that joins the events of the compiler/cm logger of the different places. +;; The attached values are (parallel-compile-event ). +(define pb-logger (make-logger 'setup/parallel-build (current-logger))) + (define lock-manager% (class object% (field (locks (make-hash))) @@ -80,6 +85,7 @@ (inspect #f) (define/public (work-done work wrkr msg) + (define id (send wrkr get-id)) (match (list work msg) [(list (list cc file last) (list result-type out err)) (begin0 @@ -89,6 +95,10 @@ #t] [(list 'LOCK fn) (lm/lock lock-mgr fn wrkr) #f] [(list 'UNLOCK fn) (lm/unlock lock-mgr fn) #f] + [(list 'LOG level msg data) + (when (log-level? pb-logger level) + (log-message pb-logger level msg (parallel-compile-event id data))) + #f] ['DONE (define (string-!empty? s) (not (zero? (string-length s)))) (when (ormap string-!empty? (list out err)) @@ -215,6 +225,10 @@ [(list 'ERROR msg) (handler id 'error work msg out err) (set! results #f) #t] + [(list 'LOG level msg data) + (when (log-level? pb-logger level) + (log-message pb-logger level msg (parallel-compile-event id data))) + #f] ['DONE (define (string-!empty? s) (not (zero? (string-length s)))) (if (ormap string-!empty? (list out err)) @@ -243,11 +257,12 @@ (super-new))) (define (parallel-build work-queue worker-count) + (define do-log-forwarding (log-level? pb-logger 'info 'setup/parallel-build)) (parallel-do - worker-count - (lambda (workerid) (list workerid)) + worker-count + (lambda (workerid) (list workerid do-log-forwarding)) work-queue - (define-worker (parallel-compile-worker worker-id) + (define-worker (parallel-compile-worker worker-id do-log-forwarding) (DEBUG_COMM (eprintf "WORKER ~a\n" worker-id)) (define prev-uncaught-exception-handler (uncaught-exception-handler)) (uncaught-exception-handler @@ -307,11 +322,17 @@ ) ;; Watch for module-prefetch events, and queue jobs in response - (define t (start-prefetch-thread send/add)) + (define prefetch-thread (start-prefetch-thread send/add)) + ;; Watch for logging events, and send log messages to parent + (define stop-logging-thread + (if do-log-forwarding + (start-logging-thread send/log) + void)) (cmc (build-path dir file)) - (kill-thread t)) + (kill-thread prefetch-thread) + (stop-logging-thread)) (send/resp 'DONE))] [x (send/error (format "DIDNT MATCH A ~v\n" x))] [else (send/error (format "DIDNT MATCH A\n"))])))) @@ -362,3 +383,27 @@ (send/add path))) p]))) (loop)))))) + +;; This thread is run in the worker's place. For every compiler event in the worker, this sends a +;; message back to the original place, which will be turned into a log event in `pb-logger`. +(define (start-logging-thread send/log) + (define log-rec (make-log-receiver (current-logger) 'info 'compiler/cm)) + (define sema (make-semaphore)) + (define t + (thread + (lambda () + (define (handle-msg v) + (send/log (vector-ref v 0) (vector-ref v 1) (vector-ref v 2))) + (define (drain) + (sync/timeout 0 (handle-evt log-rec (λ (v) (handle-msg v) (drain))))) + + (let loop () + (sync + (handle-evt log-rec + (λ (v) (handle-msg v) (loop))) + (handle-evt sema + (λ (_) (drain)))))))) + (lambda () + (semaphore-post sema) + (sync t))) + diff --git a/racket/collects/setup/parallel-do.rkt b/racket/collects/setup/parallel-do.rkt index 63715d36b5..07f7da1c8e 100644 --- a/racket/collects/setup/parallel-do.rkt +++ b/racket/collects/setup/parallel-do.rkt @@ -20,6 +20,7 @@ send/error send/report send/msg + send/log recv/req worker/die work-queue<%> @@ -351,6 +352,7 @@ (define-syntax-parameter-error send/success) (define-syntax-parameter-error send/error) (define-syntax-parameter-error send/report) +(define-syntax-parameter-error send/log) (define-syntax-parameter-error recv/req) (define-syntax-parameter-error worker/die) @@ -373,10 +375,11 @@ [recv/req (make-rename-transformer #'recv/reqp)] [worker/die (make-rename-transformer #'die-k)]) ;; message handler: - (lambda (msg send/successp send/errorp send/reportp) + (lambda (msg send/successp send/errorp send/reportp send/logp) (syntax-parameterize ([send/success (make-rename-transformer #'send/successp)] [send/error (make-rename-transformer #'send/errorp)] - [send/report (make-rename-transformer #'send/reportp)]) + [send/report (make-rename-transformer #'send/reportp)] + [send/log (make-rename-transformer #'send/logp)]) (match msg [work work-body ...] ...))))))]))))) @@ -429,6 +432,8 @@ (send/resp (list 'ERROR message))) (define (send/reportp message) (send/resp (list 'REPORT message))) + (define (send/logp level message data) + (send/resp (list 'LOG level message data))) ((with-handlers* ([exn:fail? (lambda (x) (define sp (open-output-string)) (parameterize ([current-error-port sp]) @@ -440,7 +445,7 @@ (let ([msg (pdo-recv)]) (match msg [(list 'DIE) void] - [_ (msg-proc msg send/successp send/errorp send/reportp) + [_ (msg-proc msg send/successp send/errorp send/reportp send/logp) (lambda () (loop (add1 i)))])))))))))))) (define-syntax (lambda-worker stx)