diff --git a/pkgs/racket-doc/scribblings/raco/make.scrbl b/pkgs/racket-doc/scribblings/raco/make.scrbl index b98b4dc483..4407484024 100644 --- a/pkgs/racket-doc/scribblings/raco/make.scrbl +++ b/pkgs/racket-doc/scribblings/raco/make.scrbl @@ -258,6 +258,8 @@ the security guard in the @racket[current-security-guard] when the files are created is used (not the security guard at the point @racket[make-compilation-manager-load/use-compiled-handler] is called). +The continuation the compilation of a module is marked with a +@racket[managed-compiled-context-key] and the module's source path. @emph{Do not} install the result of @racket[make-compilation-manager-load/use-compiled-handler] when the @@ -265,7 +267,7 @@ current namespace contains already-loaded versions of modules that may need to be recompiled---unless the already-loaded modules are never 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.} +@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 @@ -282,6 +284,10 @@ 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]. +@history[#:changed "6.1.1.8" @elem{Added identification of the compilation + context via @racket[managed-compiled-context-key].}]} + + @defproc[(managed-compile-zo [file path-string?] [read-src-syntax (any/c input-port? . -> . syntax?) read-syntax] [#:security-guard security-guard (or/c security-guard? #f) #f]) @@ -305,7 +311,39 @@ of existing files. If it is @racket[#f], then the security guard in the @racket[current-security-guard] when the files are created is used (not the security guard at the point @racket[managed-compile-zo] is called). -} + +While compiling @racket[file], the @racket[error-display-handler] +parameter is set to +@racket[(make-compilation-context-error-display-handler +(error-display-handler))], so that errors from uncaught exceptions +will report the compilation context. + +@history[#:changed "6.1.1.8" @elem{Added @racket[error-display-handler] + configuration.}]} + + +@defthing[managed-compiled-context-key any/c]{ + +A key used as a continuation mark key by +@racket[make-compilation-manager-load/use-compiled-handler] for the +continuation of a module compilation. The associated value is a path +to the module's source. + +@history[#:added "6.1.1.8"]} + + +@defproc[(make-compilation-context-error-display-handler + [orig-handlers (string? any/c . -> . void?)]) + (string? any/c . -> . void?)]{ + +Produces a handler suitable for use as a +@racket[error-display-handler] value, given an existing such value. +The generated handler shows information about the compilation context +when the handler's second argument is an exception whose continuation +marks include @racket[managed-compiled-context-key] keys. + +@history[#:added "6.1.1.8"]} + @defboolparam[trust-existing-zos trust?]{ @@ -469,14 +507,27 @@ result will not call @racket[proc] with @racket['unlock].) The @racketmodname[setup/parallel-build] library provides the parallel-compilation functionality of @exec{raco setup} and @exec{raco make}.} +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]. + + @defproc[(parallel-compile-files [list-of-files (listof path-string?)] [#:worker-count worker-count exact-positive-integer? (processor-count)] - [#:handler handler (->i ([worker-id exact-integer?] - [handler-type symbol?] - [path path-string?] - [msg string?] - [out string?] - [err string?]) + [#:handler handler (->i ([_worker-id exact-integer?] + [_handler-type symbol?] + [_path path-string?] + [_msg string?] + [_out string?] + [_err string?]) void?) void]) (or/c void? #f)]{ @@ -509,40 +560,33 @@ The return value is @racket[(void)] if it was successful, or @racket[#f] if ther @defproc[(parallel-compile [worker-count non-negative-integer?] - [setup-fprintf (->* ([stage string?] [format string?]) + [setup-fprintf (->i ([_stage string?] [_format string?]) () #:rest (listof any/c) void)] - [append-error (-> cc? - [prefix string?] - [exn (or/c exn? null?)] - [out string?] - [err srtring?] - [message string?] - void?)] + [append-error (->i ([_cc cc?] + [_prefix string?] + [_exn (or/c exn? (cons/c string? string?) #f)] + [_out string?] + [_err srtring?] + [_message string?]) + void?)] [collects-tree (listof any/c)]) (void)]{ -The @racket[parallel-compile] internal utility function is used by @exec{rack -setup} to compile collects in parallel. The @racket[worker-count] argument -specifies the number of compile workers to spawn during parallel compilation. -The @racket[setup-fprintf] and @racket[append-error] functions are internal -callback mechanisms that @exec{raco setup} uses to communicate intermediate -compilation results. The @racket[collects-tree] argument is a compound -datastructure containing an in-memory tree representation of the collects -directory. -} +The @racket[parallel-compile] function is used by @exec{raco setup} to +compile collections in parallel. The @racket[worker-count] argument +specifies the number of compilation workers to spawn during parallel +compilation. The @racket[setup-fprintf] and @racket[append-error] +functions communicate intermediate compilation results and errors. The +@racket[collects-tree] argument is a compound 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: +When the @racket[_exn] argument to @racket[append-error] is a part of +strings, the first string is a long form of the error message, and the +second string is a short form (omitting evaluation context +information, for example). - -@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]. +@history[#:changed "6.1.1.8" @elem{Changed @racket[append-error] to allow + a pair of error strings.}]} @; ---------------------------------------------------------------------- diff --git a/racket/collects/compiler/cm.rkt b/racket/collects/compiler/cm.rkt index de97ea30ea..b92adca448 100644 --- a/racket/collects/compiler/cm.rkt +++ b/racket/collects/compiler/cm.rkt @@ -26,6 +26,9 @@ get-compiled-file-sha1 with-compile-output + managed-compiled-context-key + make-compilation-context-error-display-handler + parallel-lock-client make-compile-lock compile-lock->parallel-lock-client) @@ -49,6 +52,22 @@ (define depth (make-parameter 0)) (define parallel-lock-client (make-parameter #f)) +(define managed-compiled-context-key (gensym)) +(define (make-compilation-context-error-display-handler orig) + (lambda (str exn) + (define l (continuation-mark-set->list + (exn-continuation-marks exn) + managed-compiled-context-key)) + (orig (if (null? l) + str + (apply + string-append + str + "\n compilation context...:" + (for/list ([i (in-list l)]) + (format "\n ~a" i)))) + exn))) + (define (file-stamp-in-collection p) (file-stamp-in-paths p (current-library-collection-paths))) @@ -383,9 +402,12 @@ d)) rg))] [current-logger accomplice-logger]) - (get-module-code path mode compile - (lambda (a b) #f) ; extension handler - #:source-reader read-src-syntax))) + (with-continuation-mark + managed-compiled-context-key + path + (get-module-code path mode compile + (lambda (a b) #f) ; extension handler + #:source-reader read-src-syntax)))) (define dest-roots (list (car roots))) (define code-dir (get-compilation-dir path #:modes (list mode) #:roots dest-roots)) @@ -689,7 +711,10 @@ cache collection-cache #f - #:security-guard security-guard)]) + #:security-guard security-guard)] + [error-display-handler + (make-compilation-context-error-display-handler + (error-display-handler))]) (compile-root (car (use-compiled-file-paths)) (current-compiled-file-roots) (path->complete-path src) diff --git a/racket/collects/setup/parallel-build.rkt b/racket/collects/setup/parallel-build.rkt index ff50ea8fd6..1a655942bf 100644 --- a/racket/collects/setup/parallel-build.rkt +++ b/racket/collects/setup/parallel-build.rkt @@ -13,6 +13,7 @@ compiler/find-exe racket/place syntax/modresolve + "private/format-error.rkt" (for-syntax racket/base)) @@ -90,8 +91,8 @@ [(list (list cc file last) (list result-type out err)) (begin0 (match result-type - [(list 'ERROR msg) - (append-error cc "making" (exn msg (current-continuation-marks)) out err "error") + [(list 'ERROR long-msg short-msg) + (append-error cc "making" (cons long-msg short-msg) out err "error") #t] [(list 'LOCK fn) (lm/lock lock-mgr fn wrkr) #f] [(list 'UNLOCK fn) (lm/unlock lock-mgr fn) #f] @@ -102,7 +103,7 @@ ['DONE (define (string-!empty? s) (not (zero? (string-length s)))) (when (ormap string-!empty? (list out err)) - (append-error cc "making" null out err "output")) + (append-error cc "making" #f out err "output")) ;(when last (printer (current-output-port) "made" "~a" (cc-name cc))) #t] [else (eprintf "Failed trying to match:\n~e\n" result-type)]))] @@ -112,7 +113,7 @@ [else (match work [(list-rest (list cc file last) message) - (append-error cc "making" null "" "" "error") + (append-error cc "making" #f "" "" "error") (eprintf "work-done match cc failed.\n") (eprintf "trying to match:\n~e\n" (list work msg)) #t] @@ -301,11 +302,12 @@ (send/msg (list (list 'UNLOCK (path->bytes fn)) "" ""))] [x (send/error (format "DIDNT MATCH C ~v\n" x))] [else (send/error (format "DIDNT MATCH C\n"))])) - (with-handlers ([exn:fail? (lambda (x) - (define sp (open-output-string)) - (parameterize ([current-error-port sp]) - ((error-display-handler) (exn-message x) x)) - (send/resp (list 'ERROR (get-output-string sp))))]) + (with-handlers ([exn:fail? (lambda (x) + (send/resp (list 'ERROR + ;; Long form shows context: + (format-error x #:long? #t #:to-string? #t) + ;; Short form for summary omits context: + (format-error x #:long? #f #:to-string? #t))))]) (parameterize ([parallel-lock-client lock-client] [compile-context-preservation-enabled (member 'disable-inlining options )] [manager-trace-handler diff --git a/racket/collects/setup/private/format-error.rkt b/racket/collects/setup/private/format-error.rkt new file mode 100644 index 0000000000..04e05500b5 --- /dev/null +++ b/racket/collects/setup/private/format-error.rkt @@ -0,0 +1,32 @@ +#lang racket/base +(require compiler/cm + setup/path-to-relative) + +(provide format-error) + +(define (format-error exn + #:long? [long? #t] + #:to-string? [to-string? #f] + #:cache [pkg-path-cache #f]) + (let loop ([to-string? to-string?]) + (cond + [to-string? + (define sp (open-output-string)) + (parameterize ([current-error-port sp]) + (loop #f)) + (regexp-replace #rx"\n$" (get-output-string sp) "")] + [long? + ((make-compilation-context-error-display-handler + (lambda (str exn) + ((error-display-handler) + str + exn))) + (exn-message exn) + exn)] + [else + (eprintf "~a\n" (exn-message exn)) + (define path (continuation-mark-set-first (exn-continuation-marks exn) + managed-compiled-context-key)) + (when (path-string? path) + (eprintf " compiling: ~a" + (path->relative-string/setup path #:cache pkg-path-cache)))]))) diff --git a/racket/collects/setup/setup-core.rkt b/racket/collects/setup/setup-core.rkt index 1ffacad3f0..16581acf89 100644 --- a/racket/collects/setup/setup-core.rkt +++ b/racket/collects/setup/setup-core.rkt @@ -37,6 +37,7 @@ "private/elf.rkt" "private/pkg-deps.rkt" "collection-name.rkt" + "private/format-error.rkt" compiler/private/dep (only-in pkg/lib pkg-directory pkg-single-collection)) @@ -151,12 +152,13 @@ (when (fail-fast) (break-thread original-thread))) (define (handle-error cc desc exn out err type) - (if (verbose) - ((error-display-handler) - (format "~a\n" (exn->string exn)) - exn) - (eprintf "~a\n" (exn->string exn))) - (append-error cc desc exn out err type)) + (define long? #t) ; possibly better: (define long? (verbose)) + (cond + [(exn? exn) + (format-error exn #:long? long?)] + [(and (pair? exn) (string? (car exn)) (string? (cdr exn))) + (eprintf "~a\n" ((if long? car cdr) exn))]) + (append-error cc desc exn out err type)) (define (record-error cc desc go fail-k) (with-handlers ([exn:fail? (lambda (x) @@ -174,8 +176,12 @@ [(path? cc) (path->relative-string/setup cc #:cache pkg-path-cache)] [else cc])) - (unless (null? x) (for ([str (in-list (regexp-split #rx"\n" (exn->string x)))]) - (setup-fprintf port #f " ~a" str))) + (let ([msg (if (exn? x) + (format-error x #:long? #f #:to-string? #t #:cache pkg-path-cache) + ;; `x` is a pair of long and short strings: + (cdr x))]) + (unless (null? x) (for ([str (in-list (regexp-split #rx"\n" msg))]) + (setup-fprintf port #f " ~a" str)))) (unless (zero? (string-length out)) (eprintf "STDOUT:\n~a=====\n" out)) (unless (zero? (string-length err)) (eprintf "STDERR:\n~a=====\n" err)))))