From: Chris Hanson Date: Fri, 12 Oct 2018 22:49:43 +0000 (-0700) Subject: Refactor compiler top level to do info-file dump as late as possible. X-Git-Tag: mit-scheme-pucked-10.1.2~16^2~224 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=6fa641e09ec0dee405f8fa8151dc87bdcc3bcf98;p=mit-scheme.git Refactor compiler top level to do info-file dump as late as possible. This is to support compiling R7RS libraries as if they were independent files, and gathering all their debug info together before writing it out. --- diff --git a/src/compiler/base/asstop.scm b/src/compiler/base/asstop.scm index 3a8d6bec7..64cf0b296 100644 --- a/src/compiler/base/asstop.scm +++ b/src/compiler/base/asstop.scm @@ -77,10 +77,11 @@ USA. (define (assemble&link info-output-pathname) (phase/assemble) - (if info-output-pathname - (phase/info-generation-2 info-output-pathname)) - (phase/link) - *result*) + (let ((file-wrapper + (and info-output-pathname + (phase/info-generation-2 info-output-pathname)))) + (phase/link) + (values *result* file-wrapper))) (define (wrap-lap entry-label some-lap) (LAP ,@(if *procedure-result?* @@ -232,57 +233,60 @@ USA. (define (info-generation-2 pathname set-debugging-info!) (compiler-phase "Debugging Information Generation" (lambda () - (set-debugging-info! - *code-vector* - (let ((info - (info-generation-phase-3 - (last-reference *dbg-expression*) - (last-reference *dbg-procedures*) - (last-reference *dbg-continuations*) - *label-bindings* - (last-reference *external-labels*)))) - (cond ((eq? pathname 'KEEP) ; for dynamic execution - (vector 'DEBUGGING-INFO-WRAPPER - 2 - #f - #f - #f - info)) - ((eq? pathname 'RECURSIVE) ; recursive compilation - (set! *recursive-compilation-results* - (cons (vector *recursive-compilation-number* - info - *code-vector* - *tl-bound* - *tl-free* - *tl-metadata*) - *recursive-compilation-results*)) - (vector 'DEBUGGING-INFO-WRAPPER - 2 - *debugging-key* - (if (pathname? *info-output-filename*) - (->namestring *info-output-filename*) - *info-output-filename*) - *recursive-compilation-number* - #f)) - (else - (compiler:dump-info-file - (vector 'DEBUGGING-FILE-WRAPPER - 2 - *debugging-key* - (list->vector - (cons info - (map (lambda (other) (vector-ref other 1)) - (recursive-compilation-results))))) - pathname) - (vector 'DEBUGGING-INFO-WRAPPER - 2 - *debugging-key* - (if (pathname? *info-output-filename*) - (->namestring *info-output-filename*) - *info-output-filename*) - 0 - #f)))))))) + (receive (debug-info file-wrapper) + (let ((info + (info-generation-phase-3 + (last-reference *dbg-expression*) + (last-reference *dbg-procedures*) + (last-reference *dbg-continuations*) + *label-bindings* + (last-reference *external-labels*)))) + (cond ((eq? pathname 'KEEP) ; for dynamic execution + (values (vector 'DEBUGGING-INFO-WRAPPER + 2 + #f + #f + #f + info) + #f)) + ((eq? pathname 'RECURSIVE) ; recursive compilation + (set! *recursive-compilation-results* + (cons (vector *recursive-compilation-number* + info + *code-vector* + *tl-bound* + *tl-free* + *tl-metadata*) + *recursive-compilation-results*)) + (values (vector 'DEBUGGING-INFO-WRAPPER + 2 + *debugging-key* + (if (pathname? *info-output-filename*) + (->namestring *info-output-filename*) + *info-output-filename*) + *recursive-compilation-number* + #f) + #f)) + (else + (values (vector 'DEBUGGING-INFO-WRAPPER + 2 + *debugging-key* + (if (pathname? *info-output-filename*) + (->namestring *info-output-filename*) + *info-output-filename*) + 0 + #f) + (vector 'DEBUGGING-FILE-WRAPPER + 2 + *debugging-key* + (list->vector + (cons info + (map (lambda (other) + (vector-ref other 1)) + (recursive-compilation-results)) + ))))))) + (set-debugging-info! *code-vector* debug-info) + file-wrapper)))) (define (recursive-compilation-results) (sort *recursive-compilation-results* @@ -372,9 +376,7 @@ USA. (set! *block-label* (generate-label)) (set! *external-labels* '()) (set! *ic-procedure-headers* '()) - (phase/assemble) - (phase/link) - *result*))) + (assemble&link #f)))) (define (canonicalize-label-name name) ;; The Scheme assembler allows any Scheme symbol as a label diff --git a/src/compiler/base/crstop.scm b/src/compiler/base/crstop.scm index 54e1fff8f..45566a796 100644 --- a/src/compiler/base/crstop.scm +++ b/src/compiler/base/crstop.scm @@ -35,10 +35,11 @@ USA. (define (cross-assemble&link info-output-pathname) (phase/assemble) - (if info-output-pathname - (cross-compiler-phase/info-generation-2 info-output-pathname)) - (cross-compiler-phase/link) - *result*) + (let ((file-wrapper + (and info-output-pathname + (cross-compiler-phase/info-generation-2 info-output-pathname)))) + (cross-compiler-phase/link) + (values *result* file-wrapper))) (define (cross-compiler-phase/info-generation-2 pathname) (info-generation-2 pathname set-cc-code-block/debugging-info!)) diff --git a/src/compiler/base/toplev.scm b/src/compiler/base/toplev.scm index 477dff42f..ee4e3958f 100644 --- a/src/compiler/base/toplev.scm +++ b/src/compiler/base/toplev.scm @@ -157,7 +157,7 @@ USA. input-pathname output-pathname (lambda () - (compile-scode/internal + (compile-bin-file-1 scode (pathname-new-type output-pathname @@ -166,6 +166,16 @@ USA. lap-output-port))))))))))))) unspecific) +(define (compile-bin-file-1 scode info-output-pathname rtl-output-port + lap-output-port) + (receive (result file-wrapper) + (compile-scode/internal scode info-output-pathname rtl-output-port + lap-output-port) + (if file-wrapper + (compiler:dump-info-file file-wrapper + info-output-pathname)) + result)) + (define *debugging-key*) (define *compiler-input-pathname*) (define *compiler-output-pathname*) @@ -267,7 +277,10 @@ USA. (*info-output-filename* keep-debugging-info?)) (compile-scode/no-file/hook (lambda () - (compile-scode/internal scode keep-debugging-info?))))) + (receive (result file-wrapper) + (compile-scode/internal scode keep-debugging-info?) + (declare (ignore file-wrapper)) + result))))) (define (compiler:batch-compile input #!optional output) (fluid-let ((compiler:batch-mode? #t)) @@ -334,15 +347,18 @@ USA. (*procedure-result?* procedure-result?)) (compile-scode/recursive/hook (lambda () - (compile-scode/internal - scode - (and *info-output-filename* - (if (eq? *info-output-filename* 'KEEP) - 'KEEP - 'RECURSIVE)) - *rtl-output-port* - *lap-output-port* - bind-compiler-variables))))))) + (receive (result file-wrapper) + (compile-scode/internal + scode + (and *info-output-filename* + (if (eq? *info-output-filename* 'KEEP) + 'KEEP + 'RECURSIVE)) + *rtl-output-port* + *lap-output-port* + bind-compiler-variables) + (declare (ignore file-wrapper)) + result))))))) (if procedure-result? (let ((do-it (lambda () @@ -428,10 +444,10 @@ USA. (define (in-compiler thunk) (let ((run-compiler (lambda () - (let ((value - (let ((expression (thunk))) + (receive (scode file-marker) (thunk) + (let ((result (let ((others (recursive-compilation-results))) - (if (compiled-code-address? expression) + (if (compiled-code-address? scode) (scode/make-comment ;; Keep in sync with "crsend.scm" and with ;; "runtime/infstr.scm". @@ -440,7 +456,7 @@ USA. (if compiler:compile-by-procedures? 'compiled-by-procedures 'compiled-as-unit) - (compiled-code-address->block expression) + (compiled-code-address->block scode) (list->vector (map (lambda (other) (vector-ref other 2)) @@ -466,17 +482,17 @@ USA. others)) (lambda (elt1 elt2) (eq? (car elt1) (car elt2))))) - expression) + scode) (vector compiler:compile-by-procedures? - expression + scode (map (lambda (other) (vector-ref other 2)) - others))))))) - (if compiler:show-time-reports? - (compiler-time-report "Total compilation time" - *process-time* - *real-time*)) - value)))) + others)))))) + (if compiler:show-time-reports? + (compiler-time-report "Total compilation time" + *process-time* + *real-time*)) + (values result file-marker)))))) (if compiler:preserve-data-structures? (begin (compiler:reset!) @@ -1112,4 +1128,4 @@ USA. (begin (write-char #\page) (newline))) - (output-port/flush-output port)))))) + (output-port/flush-output port)))))) \ No newline at end of file diff --git a/src/compiler/machines/C/ctop.scm b/src/compiler/machines/C/ctop.scm index 5c6e11208..c5a3714b8 100644 --- a/src/compiler/machines/C/ctop.scm +++ b/src/compiler/machines/C/ctop.scm @@ -211,10 +211,11 @@ USA. (define (assemble&link info-output-pathname) (phase/assemble info-output-pathname) - (if info-output-pathname - (phase/info-generation-2 *labels* info-output-pathname)) - (phase/output-generation) - *result*) + (let ((file-wrapper + (and info-output-pathname + (phase/info-generation-2 *labels* info-output-pathname)))) + (phase/output-generation) + (values *result* file-wrapper))) (define (wrap-lap entry-label some-lap) (set! *start-label* entry-label) @@ -406,24 +407,22 @@ USA. (last-reference *external-labels*)))) (cond ((eq? pathname 'KEEP) ; for dynamic execution ;; (warn "C back end cannot keep debugging info in memory") - unspecific) + #f) ((eq? pathname 'RECURSIVE) ; recursive compilation (set! *recursive-compilation-results* (cons (vector *recursive-compilation-number* info #f) *recursive-compilation-results*)) - unspecific) + #f) (else - (compiler:dump-info-file - (let ((others (recursive-compilation-results))) - (if (null? others) - info - (list->vector - (cons info - (map (lambda (other) (vector-ref other 1)) - others))))) - pathname))))))) + (let ((others (recursive-compilation-results))) + (if (null? others) + info + (list->vector + (cons info + (map (lambda (other) (vector-ref other 1)) + others))))))))))) (define (compiler:dump-bci-file binf pathname) (let ((bci-path (pathname-new-type pathname "bci")))