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 3a8d6bec7a5e5597296dfe58f5a93727cf44334a..64cf0b2960ccb83e15ca8e0d2b858bde86e48303 100644 (file)
--- 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 54e1fff8f4de91286f3232d9eec1cfe711de10ea..45566a796832641f61be790e29fb6c37651da399 100644 (file)
--- 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 477dff42f5fde3a1553b72787841cd17370859ce..ee4e3958fd125f522de0758aea63c67b144fcc96 100644 (file)
--- 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 5c6e11208f44ab2fe4c6cbe0c3750438b4c144f4..c5a3714b8dc76f60cc108851820c584985e36df3 100644 (file)
--- 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")))