From: Chris Hanson Date: Sun, 14 Oct 2018 02:54:58 +0000 (-0700) Subject: Extensive work to get compiler to work with R7RS libraries. X-Git-Tag: mit-scheme-pucked-10.1.2~16^2~222 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=99b600327c30a187253cdde9c6b5de4ee74e0e43;p=mit-scheme.git Extensive work to get compiler to work with R7RS libraries. The bulk of the work is to refactor the debugging info so that it's generated and consumed properly; this required upgrading the version and introducing a new top-level info form. I also eliminated the now-ancient and unused BSM file support, which was making things more difficult than necessary. The compiler top level required only to detect an R7RS input file and to compile each part separately, plus collecting all of the debugging information from the parts. Some tweaks were used to make RTL/LAP files work right with multiple roots. Finally, the runtime system was modified so that compiled-code blocks and entries now show the R7RS library name if there is one, both when printed and in various other places. --- diff --git a/src/compiler/base/asstop.scm b/src/compiler/base/asstop.scm index 64cf0b296..06a2d50f9 100644 --- a/src/compiler/base/asstop.scm +++ b/src/compiler/base/asstop.scm @@ -241,15 +241,16 @@ USA. (last-reference *dbg-continuations*) *label-bindings* (last-reference *external-labels*)))) - (cond ((eq? pathname 'KEEP) ; for dynamic execution - (values (vector 'DEBUGGING-INFO-WRAPPER - 2 + (cond ((eq? pathname 'keep) ; for dynamic execution + (values (vector 'debugging-info-wrapper + 3 #f #f #f - info) + info + #f) #f)) - ((eq? pathname 'RECURSIVE) ; recursive compilation + ((eq? pathname 'recursive) ; recursive compilation (set! *recursive-compilation-results* (cons (vector *recursive-compilation-number* info @@ -258,33 +259,36 @@ USA. *tl-free* *tl-metadata*) *recursive-compilation-results*)) - (values (vector 'DEBUGGING-INFO-WRAPPER - 2 + (values (vector 'debugging-info-wrapper + 3 *debugging-key* (if (pathname? *info-output-filename*) (->namestring *info-output-filename*) *info-output-filename*) *recursive-compilation-number* - #f) + #f + *library-name*) #f)) (else - (values (vector 'DEBUGGING-INFO-WRAPPER - 2 + (values (vector 'debugging-info-wrapper + 3 *debugging-key* (if (pathname? *info-output-filename*) (->namestring *info-output-filename*) *info-output-filename*) 0 - #f) - (vector 'DEBUGGING-FILE-WRAPPER - 2 + #f + *library-name*) + (vector 'debugging-file-wrapper + 3 *debugging-key* (list->vector - (cons info - (map (lambda (other) - (vector-ref other 1)) - (recursive-compilation-results)) - ))))))) + (cons + info + (map (lambda (other) + (vector-ref other 1)) + (recursive-compilation-results)))) + *library-name*))))) (set-debugging-info! *code-vector* debug-info) file-wrapper)))) @@ -298,24 +302,8 @@ USA. (define (compiler:dump-inf-file binf pathname) (compiler-file-output binf pathname)) -(define (compiler:dump-bif/bsm-files binf pathname) - (let ((bif-path (pathname-new-type pathname "bif")) - (bsm-path (pathname-new-type pathname "bsm"))) - (let ((bsm (split-inf-structure! binf bsm-path))) - (compiler-file-output binf bif-path) - (compiler-file-output bsm bsm-path)))) - -(define (compiler:dump-bci/bcs-files binf pathname) - (let ((bci-path (pathname-new-type pathname "bci")) - (bcs-path (pathname-new-type pathname "bcs"))) - (let ((bsm (split-inf-structure! binf bcs-path))) - (dump-compressed binf bci-path) - (dump-compressed bsm bcs-path)))) - (define (compiler:dump-bci-file binf pathname) - (let ((bci-path (pathname-new-type pathname "bci"))) - (split-inf-structure! binf #f) - (dump-compressed binf bci-path))) + (dump-compressed binf (pathname-new-type pathname "bci"))) (define (dump-compressed object path) (call-with-temporary-filename diff --git a/src/compiler/base/crsend.scm b/src/compiler/base/crsend.scm index b3780f873..c13e7f6f5 100644 --- a/src/compiler/base/crsend.scm +++ b/src/compiler/base/crsend.scm @@ -97,10 +97,6 @@ USA. (write (enough-namestring output-file) port)) (lambda () (let ((inf (fasload input-file #t))) - ((access SPLIT-INF-STRUCTURE! ; XXX ugh - (->environment '(RUNTIME COMPILER-INFO))) - inf - #f) (call-with-temporary-filename (lambda (temp) (fasdump inf temp #t) diff --git a/src/compiler/base/toplev.scm b/src/compiler/base/toplev.scm index ee4e3958f..505c80659 100644 --- a/src/compiler/base/toplev.scm +++ b/src/compiler/base/toplev.scm @@ -168,17 +168,48 @@ USA. (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 + (receive (result wrapper) + (let ((do-one-expr + (lambda (scode library-name) + (fluid-let ((*library-name* library-name)) + (compile-scode/internal scode + info-output-pathname + rtl-output-port + lap-output-port))))) + (if (r7rs-scode-file? scode) + (let ((file-wrappers '())) + (let ((result + (map-r7rs-scode-file + (lambda (library) + (let ((name + (or (scode-library-name library) + 'program))) + (map-scode-library + (lambda (contents) + (receive (result file-wrapper) + (do-one-expr contents name) + (if file-wrapper + (set! file-wrappers + (cons file-wrapper + file-wrappers))) + result)) + library))) + scode))) + (values result + (vector 'debugging-library-wrapper + 3 + *debugging-key* + (list->vector (reverse file-wrappers)))))) + (do-one-expr scode #f))) + (if wrapper + (compiler:dump-info-file wrapper info-output-pathname)) result)) (define *debugging-key*) (define *compiler-input-pathname*) (define *compiler-output-pathname*) +(define *library-name*) (define (maybe-open-file open? pathname receiver) (if open? @@ -1025,21 +1056,12 @@ USA. (define (phase/rtl-file-output scode port) (compiler-phase "RTL File Output" (lambda () - (write-string "RTL for object " port) - (write *recursive-compilation-number* port) - (newline port) - (pp scode port #t 4) - (newline port) - (newline port) + (rtl/lap-file-header "RTL" scode port) (write-rtl-instructions (linearize-rtl *rtl-root* *rtl-procedures* *rtl-continuations*) port) - (if (not (zero? *recursive-compilation-number*)) - (begin - (write-char #\page port) - (newline port))) - (output-port/flush-output port)))) + (rtl/lap-file-footer port)))) (define (phase/lap-generation) (compiler-phase "LAP Generation" @@ -1094,38 +1116,49 @@ USA. (lambda () (parameterize ((param:printer-radix 16) (param:print-uninterned-symbols-by-name? #t)) - (parameterize ((current-output-port port)) - (write-string "LAP for object ") - (write *recursive-compilation-number*) - (newline) - (pp scode (current-output-port) #t 4) - (newline) - (newline) - (newline) - (for-each - (lambda (instruction) - (cond ((and (pair? instruction) - (eq? (car instruction) 'LABEL)) - (write (cadr instruction)) - (write-char #\:)) - ((and (pair? instruction) - (eq? (car instruction) 'COMMENT)) - (write-char #\tab) - (write-string ";;") - (for-each (lambda (frob) - (write-string " ") - (write (if (and (pair? frob) - (eq? (car frob) 'RTL)) - (cadr frob) - frob))) - (cdr instruction))) - (else - (write-char #\tab) - (write instruction))) - (newline)) - *lap*) - (if (not (zero? *recursive-compilation-number*)) - (begin - (write-char #\page) - (newline))) - (output-port/flush-output port)))))) \ No newline at end of file + (rtl/lap-file-header "LAP" scode port) + (for-each (lambda (instruction) + (write-lap-instruction instruction port)) + *lap*) + (rtl/lap-file-footer port))))) + +(define (write-lap-instruction instruction port) + (cond ((and (pair? instruction) + (eq? (car instruction) 'label)) + (write (cadr instruction) port) + (write-char #\: port)) + ((and (pair? instruction) + (eq? (car instruction) 'comment)) + (write-char #\tab port) + (write-string ";;" port) + (for-each (lambda (frob) + (write-string " " port) + (write (if (and (pair? frob) + (eq? (car frob) 'rtl)) + (cadr frob) + frob) + port)) + (cdr instruction))) + (else + (write-char #\tab port) + (write instruction port))) + (newline port)) + +(define (rtl/lap-file-header tag scode port) + (write-char #\page port) + (newline port) + (write-string tag port) + (write-string " for object " port) + (write *recursive-compilation-number* port) + (cond ((eq? *library-name* 'program) + (write-string " in R7RS top level" port)) + (*library-name* + (write-string " in R7RS library " port) + (write *library-name* port))) + (newline port) + (pp scode port #t 4) + (newline port) + (newline port)) + +(define (rtl/lap-file-footer port) + (output-port/flush-output port)) \ No newline at end of file diff --git a/src/compiler/machines/C/compiler.pkg b/src/compiler/machines/C/compiler.pkg index 0ee65baad..f1e072374 100644 --- a/src/compiler/machines/C/compiler.pkg +++ b/src/compiler/machines/C/compiler.pkg @@ -271,8 +271,6 @@ USA. *root-expression* *rtl-procedures* *rtl-graphs*) - (import (runtime compiler-info) - split-inf-structure!) (import (runtime load) fasload-object-file) (import (scode-optimizer build-utilities) diff --git a/src/compiler/machines/C/ctop.scm b/src/compiler/machines/C/ctop.scm index c5a3714b8..3193fdacc 100644 --- a/src/compiler/machines/C/ctop.scm +++ b/src/compiler/machines/C/ctop.scm @@ -425,9 +425,7 @@ USA. others))))))))))) (define (compiler:dump-bci-file binf pathname) - (let ((bci-path (pathname-new-type pathname "bci"))) - (split-inf-structure! binf #f) - (dump-compressed binf bci-path))) + (dump-compressed binf (pathname-new-type pathname "bci"))) (define (dump-compressed object path) (call-with-temporary-filename diff --git a/src/compiler/machines/i386/compiler.pkg b/src/compiler/machines/i386/compiler.pkg index 719b344fb..258bea675 100644 --- a/src/compiler/machines/i386/compiler.pkg +++ b/src/compiler/machines/i386/compiler.pkg @@ -259,8 +259,6 @@ USA. *root-expression* *rtl-procedures* *rtl-graphs*) - (import (runtime compiler-info) - split-inf-structure!) (import (scode-optimizer build-utilities) directory-processor)) diff --git a/src/compiler/machines/i386/dassm1.scm b/src/compiler/machines/i386/dassm1.scm index 960696e2f..f1144f106 100644 --- a/src/compiler/machines/i386/dassm1.scm +++ b/src/compiler/machines/i386/dassm1.scm @@ -88,16 +88,19 @@ USA. (let ((symbol-table (and info (dbg-info/labels info)))) (write-string "Disassembly of ") (write block) - (call-with-values - (lambda () (compiled-code-block/filename-and-index block)) - (lambda (filename index) - (if filename - (begin - (write-string " (Block ") - (write index) - (write-string " in ") - (write-string filename) - (write-string ")"))))) + (receive (filename index library) + (compiled-code-block/filename-and-index block) + (if filename + (begin + (write-string " (Block ") + (write index) + (if library + (begin + (write-string " of library ") + (write library))) + (write-string " in ") + (write-string filename) + (write-string ")")))) (write-string ":\n") (write-string "Code:\n\n") (disassembler/write-instruction-stream diff --git a/src/compiler/machines/svm/compiler.pkg b/src/compiler/machines/svm/compiler.pkg index dccdfbae0..3f55760ca 100644 --- a/src/compiler/machines/svm/compiler.pkg +++ b/src/compiler/machines/svm/compiler.pkg @@ -259,8 +259,6 @@ USA. *root-expression* *rtl-procedures* *rtl-graphs*) - (import (runtime compiler-info) - split-inf-structure!) (import (scode-optimizer build-utilities) directory-processor)) diff --git a/src/compiler/machines/svm/disassembler.scm b/src/compiler/machines/svm/disassembler.scm index 0c1f62a50..562c24b04 100644 --- a/src/compiler/machines/svm/disassembler.scm +++ b/src/compiler/machines/svm/disassembler.scm @@ -80,16 +80,19 @@ USA. (let ((cursor (block-cursor block symbol-table?))) (write-string "Disassembly of ") (write block) - (call-with-values - (lambda () (compiled-code-block/filename-and-index block)) - (lambda (filename index) - (if filename - (begin - (write-string " (Block ") - (write index) - (write-string " in ") - (write-string filename) - (write-string "):\n"))))) + (receive (filename index library) + (compiled-code-block/filename-and-index block) + (if filename + (begin + (write-string " (Block ") + (write index) + (if library + (begin + (write-string " of library ") + (write library))) + (write-string " in ") + (write-string filename) + (write-string "):\n")))) (write-string "\nCode:\n") (write-instructions cursor) (write-string "\nConstants:\n") diff --git a/src/compiler/machines/x86-64/compiler.pkg b/src/compiler/machines/x86-64/compiler.pkg index 668b2e3e3..0c9e89aae 100644 --- a/src/compiler/machines/x86-64/compiler.pkg +++ b/src/compiler/machines/x86-64/compiler.pkg @@ -259,8 +259,11 @@ USA. *root-expression* *rtl-procedures* *rtl-graphs*) - (import (runtime compiler-info) - split-inf-structure!) + (import (runtime) + map-r7rs-scode-file + map-scode-library + r7rs-scode-file? + scode-library-name) (import (scode-optimizer build-utilities) directory-processor)) diff --git a/src/compiler/machines/x86-64/dassm1.scm b/src/compiler/machines/x86-64/dassm1.scm index 034951b16..2f4b88a64 100644 --- a/src/compiler/machines/x86-64/dassm1.scm +++ b/src/compiler/machines/x86-64/dassm1.scm @@ -88,16 +88,19 @@ USA. (let ((symbol-table (and info (dbg-info/labels info)))) (write-string "Disassembly of ") (write block) - (call-with-values - (lambda () (compiled-code-block/filename-and-index block)) - (lambda (filename index) - (if filename - (begin - (write-string " (Block ") - (write index) - (write-string " in ") - (write-string filename) - (write-string ")"))))) + (receive (filename index library) + (compiled-code-block/filename-and-index block) + (if filename + (begin + (write-string " (Block ") + (write index) + (if library + (begin + (write-string " of library ") + (write library))) + (write-string " in ") + (write-string filename) + (write-string ")")))) (write-string ":\n") (write-string "Code:\n\n") (disassembler/write-instruction-stream diff --git a/src/runtime/conpar.scm b/src/runtime/conpar.scm index 3bba777c8..5b1dade35 100644 --- a/src/runtime/conpar.scm +++ b/src/runtime/conpar.scm @@ -1000,15 +1000,14 @@ USA. (write-string "within ") (let ((block (stack-frame/ref frame hardware-trap/pc-info1-index))) (write block) - (call-with-values - (lambda () (compiled-code-block/filename-and-index block)) - (lambda (filename index) - index - (if filename - (begin - (write-string " (") - (write-string filename) - (write-string ")"))))))) + (receive (filename index library) + (compiled-code-block/filename-and-index block) + (declare (ignore index library)) + (if filename + (begin + (write-string " (") + (write-string filename) + (write-string ")")))))) ((3) ; probably compiled-code (write-string " at an unknown compiled-code location.")) ((4) ; builtin (i.e. hook) diff --git a/src/runtime/infstr.scm b/src/runtime/infstr.scm index a4611b98f..619b5cc9f 100644 --- a/src/runtime/infstr.scm +++ b/src/runtime/infstr.scm @@ -73,19 +73,9 @@ USA. (expression #f read-only #t) ;dbg-expression (procedures #f read-only #t) ;vector of dbg-procedure (continuations #f read-only #t) ;vector of dbg-continuation - (labels/desc #f read-only #f) ;vector of dbg-label, sorted by offset + (labels #f read-only #f) ;vector of dbg-label, sorted by offset ) -(define (dbg-info/labels dbg-info) - (let ((labels/desc (dbg-info/labels/desc dbg-info))) - (if (vector? labels/desc) - labels/desc - (let ((labels (read-labels labels/desc))) - (and labels - (begin - (set-dbg-info/labels/desc! dbg-info labels) - labels)))))) - (define-structure (dbg-expression (type vector) (named '|#[(runtime compiler-info)dbg-expression]|) @@ -202,15 +192,41 @@ USA. (define (compiled-code-block/debugging-wrapper block) (let ((wrapper (compiled-code-block/debugging-info block))) - (if (debugging-wrapper? wrapper) - wrapper - #f))) - -(define (debugging-wrapper? wrapper) + (cond ((debugging-wrapper-v2? wrapper) + (let ((v (vector-grow wrapper 7))) + (vector-set! v 1 3) + (vector-set! v 6 #f) + (set-compiled-code-block/debugging-info! block v) + v)) + ((debugging-wrapper-v3? wrapper) wrapper) + (else #f)))) + +(define (debugging-wrapper-v2? wrapper) (and (vector? wrapper) (fix:= (vector-length wrapper) 6) - (eq? (vector-ref wrapper 0) 'debugging-info-wrapper) - (fix:= (vector-ref wrapper 1) 2) + (eqv? (vector-ref wrapper 1) 2) + (debugging-wrapper-common? wrapper))) + +(define (debugging-wrapper-v3? wrapper) + (and (vector? wrapper) + (fix:= (vector-length wrapper) 7) + (eqv? (vector-ref wrapper 1) 3) + (debugging-wrapper-common? wrapper) + (debugging-library-name? (vector-ref wrapper 6)))) + +(define (debugging-library-name? object) + (or (not object) + (eq? object 'program) + (library-name? object))) + +(define (debugging-library-name=? n1 n2) + (or (eq? n1 n2) + (and (library-name? n1) + (library-name? n2) + (library-name=? n1 n2)))) + +(define (debugging-wrapper-common? wrapper) + (and (eq? (vector-ref wrapper 0) 'debugging-info-wrapper) (or (and (not (vector-ref wrapper 2)) (not (vector-ref wrapper 3)) (not (vector-ref wrapper 4)) @@ -241,12 +257,36 @@ USA. (define (set-debugging-wrapper/info! wrapper info) (vector-set! wrapper 5 info)) + +(define (debugging-wrapper/library-name wrapper) + (vector-ref wrapper 6)) -(define (debugging-file-wrapper? wrapper) +(define (canonicalize-file-wrapper wrapper) + (cond ((debugging-file-wrapper-v2? wrapper) + (let ((v (vector-grow wrapper 5))) + (vector-set! v 1 3) + (vector-set! v 4 #f) + v)) + ((or (debugging-file-wrapper-v3? wrapper) + (debugging-library-wrapper? wrapper)) + wrapper) + (else #f))) + +(define (debugging-file-wrapper-v2? wrapper) (and (vector? wrapper) (fix:= (vector-length wrapper) 4) - (eq? (vector-ref wrapper 0) 'debugging-file-wrapper) - (fix:= (vector-ref wrapper 1) 2) + (eqv? (vector-ref wrapper 1) 2) + (debugging-file-wrapper-common? wrapper))) + +(define (debugging-file-wrapper-v3? wrapper) + (and (vector? wrapper) + (fix:= (vector-length wrapper) 5) + (eqv? (vector-ref wrapper 1) 3) + (debugging-file-wrapper-common? wrapper) + (debugging-library-name? (vector-ref wrapper 4)))) + +(define (debugging-file-wrapper-common? wrapper) + (and (eq? (vector-ref wrapper 0) 'debugging-file-wrapper) (dbg-info-key? (vector-ref wrapper 2)) (let ((info (vector-ref wrapper 3))) (and (vector? info) @@ -262,20 +302,8 @@ USA. (define (debugging-file-wrapper/info wrapper) (vector-ref wrapper 3)) -(define (canonicalize-file-wrapper wrapper) - (cond ((debugging-file-wrapper? wrapper) - wrapper) - (else #f))) - -(define (get-wrapped-dbg-info file-wrapper wrapper) - (and (let ((k1 (debugging-wrapper/key wrapper)) - (k2 (debugging-file-wrapper/key file-wrapper))) - (or (and k1 k2 (dbg-info-key=? k1 k2)) - (and (not k1) (not k2)))) - (let ((v (debugging-file-wrapper/info file-wrapper)) - (index (debugging-wrapper/index wrapper))) - (and (fix:< index (vector-length v)) - (vector-ref v index))))) +(define (debugging-file-wrapper/library-name wrapper) + (vector-ref wrapper 4)) (define (dbg-info-key? object) (or (and (bytevector? object) @@ -284,8 +312,56 @@ USA. (and ((ucode-primitive string? 1) object) (fix:= ((ucode-primitive string-length 1) object) 32)))) -(define (dbg-info-key=? a b) - (equal? a b)) +(define (dbg-info-key=? k1 k2) + (or (and k1 k2 (equal? k1 k2)) + (and (not k1) (not k2)))) + +(define (debugging-library-wrapper? wrapper) + (and (vector? wrapper) + (fix:= (vector-length wrapper) 4) + (eq? (vector-ref wrapper 0) 'debugging-library-wrapper) + (eqv? (vector-ref wrapper 1) 3) + (dbg-info-key? (vector-ref wrapper 2)) + (let ((info (vector-ref wrapper 3))) + (and (vector? info) + (fix:>= (vector-length info) 1) + (vector-every debugging-file-wrapper-v3? info))))) + +(define (debugging-library-wrapper/version wrapper) + (vector-ref wrapper 1)) + +(define (debugging-library-wrapper/key wrapper) + (vector-ref wrapper 2)) + +(define (debugging-library-wrapper/file-wrappers wrapper) + (vector-ref wrapper 3)) + +(define (get-wrapped-dbg-info from-file from-block) + (let ((lookup-by-index + (lambda (from-file) + (let ((v (debugging-file-wrapper/info from-file)) + (index (debugging-wrapper/index from-block))) + (and (fix:< index (vector-length v)) + (vector-ref v index)))))) + (cond ((debugging-file-wrapper-v3? from-file) + (and (dbg-info-key=? (debugging-wrapper/key from-block) + (debugging-file-wrapper/key from-file)) + (lookup-by-index from-file))) + ((debugging-library-wrapper? from-file) + (and (dbg-info-key=? (debugging-wrapper/key from-block) + (debugging-library-wrapper/key from-file)) + (let ((name (debugging-wrapper/library-name from-block)) + (v (debugging-library-wrapper/file-wrappers from-file))) + (let ((n (vector-length v))) + (let loop ((i 0)) + (and (fix:< i n) + (if (debugging-library-name=? + name + (debugging-file-wrapper/library-name + (vector-ref v i))) + (lookup-by-index (vector-ref v i)) + (loop (fix:+ i 1))))))))) + (else #f)))) (define (debug-info-pathname? object) (or (string? object) diff --git a/src/runtime/infutl.scm b/src/runtime/infutl.scm index b4129cd89..9161e4fe4 100644 --- a/src/runtime/infutl.scm +++ b/src/runtime/infutl.scm @@ -44,8 +44,7 @@ USA. (and file-wrapper (let ((file-wrapper (canonicalize-file-wrapper file-wrapper))) (and file-wrapper - (let ((info - (get-wrapped-dbg-info file-wrapper wrapper))) + (let ((info (get-wrapped-dbg-info file-wrapper wrapper))) (if info (memoize-debugging-info! wrapper info)) info)))))))) @@ -153,9 +152,10 @@ USA. (let ((pathname (debugging-wrapper/pathname wrapper))) (if pathname (values (canonicalize-debug-info-filename pathname) - (debugging-wrapper/index wrapper)) - (values #f #f))) - (values #f #f)))) + (debugging-wrapper/index wrapper) + (debugging-wrapper/library-name wrapper)) + (values #f #f #f))) + (values #f #f #f)))) (define (dbg-labels/find-offset labels offset) (vector-binary-search labels < dbg-label/offset offset)) @@ -365,81 +365,6 @@ USA. (scode-lambda-body scode)))) entry))) -;;; Support of BSM files - -(define (read-labels descriptor) - (cond ((debug-info-pathname? descriptor) - (let ((bsm (read-bsm-file descriptor))) - (and bsm ;; bsm are either vectors of pairs or vectors of vectors - (if (vector? bsm) - (let ((first (and (not (zero? (vector-length bsm))) - (vector-ref bsm 0)))) - (cond ((pair? first) bsm) - ((vector? first) first) - (else #f))))))) - ((and (pair? descriptor) - (debug-info-pathname? (car descriptor)) - (exact-nonnegative-integer? (cdr descriptor))) - (let ((bsm (read-bsm-file (car descriptor)))) - (and bsm - (vector? bsm) - (< (cdr descriptor) (vector-length bsm)) - (vector-ref bsm (cdr descriptor))))) - (else #f))) - -(define (read-bsm-file name) - (let ((pathname - (let ((pathname - (canonicalize-debug-info-pathname - (rewrite-directory (merge-pathnames name))))) - (if (file-exists? pathname) - pathname - (let loop ((types '("bsm" "bcs"))) - (and (not (null? types)) - (let ((pathname - (pathname-new-type pathname (car types)))) - (if (file-exists? pathname) - pathname - (loop (cdr types)))))))))) - (and pathname - (if (equal? "bcs" (pathname-type pathname)) - (compressed-loader pathname) - (fasload-loader pathname))))) - -;;;; Splitting of info structures - -(define (inf->bif/bsm inffile) - (let* ((infpath (merge-pathnames inffile)) - (bifpath (pathname-new-type infpath "bif")) - (bsmpath (pathname-new-type infpath "bsm"))) - (let ((file-info (fasload infpath))) - (inf-structure->bif/bsm file-info bifpath bsmpath)))) - -(define (inf-structure->bif/bsm file-info bifpath bsmpath) - (let ((bifpath (merge-pathnames bifpath)) - (bsmpath (and bsmpath (merge-pathnames bsmpath)))) - (call-with-values (lambda () (split-inf-structure! file-info bsmpath)) - (lambda (file-wrapper bsm) - (fasdump file-wrapper bifpath #t) - (if bsmpath (fasdump bsm bsmpath #t)))))) - -(define (split-inf-structure! file-info bsmpath) - (let ((file-wrapper (canonicalize-file-wrapper file-info)) - (bsmname (and bsmpath (->namestring bsmpath)))) - (if (not file-wrapper) - (error "Unknown debugging-file format:" file-info)) - (let ((info (debugging-file-wrapper/info file-wrapper))) - (let ((n (vector-length info))) - (let ((bsm (make-vector n))) - (do ((i 0 (fix:+ i 1))) - ((fix:= i n)) - (let ((dbg-info (vector-ref info i))) - (let ((labels (dbg-info/labels/desc dbg-info))) - (vector-set! bsm i labels) - (set-dbg-info/labels/desc! dbg-info - (and bsmname (cons bsmname i)))))) - (values file-wrapper bsm)))))) - ;;;; UNCOMPRESS ;;; A simple extractor for compressed binary info files. diff --git a/src/runtime/library-scode.scm b/src/runtime/library-scode.scm index 0d1ad3666..3902fcdc3 100644 --- a/src/runtime/library-scode.scm +++ b/src/runtime/library-scode.scm @@ -134,6 +134,11 @@ USA. (strip-comments (scode-comment-expression object)) object)) +;; Unlike map, guarantees that procedure is called on the libraries in order. (define (map-r7rs-scode-file procedure scode) (guarantee r7rs-scode-file? scode 'map-r7rs-scode-file) - (make-scode-sequence (map procedure (r7rs-scode-file-libraries scode)))) \ No newline at end of file + (let loop ((libraries (r7rs-scode-file-libraries scode)) (results '())) + (if (pair? libraries) + (loop (cdr libraries) + (cons (procedure (car libraries)) results)) + (make-scode-sequence (reverse results))))) \ No newline at end of file diff --git a/src/runtime/printer.scm b/src/runtime/printer.scm index 798198203..35e6ad55f 100644 --- a/src/runtime/printer.scm +++ b/src/runtime/printer.scm @@ -357,6 +357,7 @@ USA. (bignum ,print-number) (bytevector ,print-bytevector) (character ,print-character) + (compiled-code-block ,print-compiled-code-block) (compiled-entry ,print-compiled-entry) (complex ,print-number) (constant ,print-constant) @@ -825,7 +826,7 @@ USA. (lambda (context*) (*print-char #\space context*) (print-name context*))))))) - + (define (print-compiled-entry entry context) (let* ((type (compiled-entry-type entry)) (procedure? (eq? type 'compiled-procedure)) @@ -838,7 +839,7 @@ USA. context (lambda (context*) (let ((name (and procedure? (compiled-procedure/name entry)))) - (receive (filename block-number) + (receive (filename block-number library) (compiled-entry/filename-and-index entry) (*print-char #\space context*) (*print-char #\( context*) @@ -848,11 +849,7 @@ USA. (begin (if name (*print-char #\space context*)) - (print-object (pathname-name filename) context*) - (if block-number - (begin - (*print-char #\space context*) - (*print-hex block-number context*))))) + (print-block-info filename block-number library context*))) (*print-char #\) context*))) (*print-char #\space context*) (*print-hex (compiled-entry/offset entry) context*) @@ -860,9 +857,34 @@ USA. (begin (*print-char #\space context*) (*print-datum (compiled-closure->entry entry) - context*))) + context*))) (*print-char #\space context*) (*print-datum entry context*))))) + +(define (print-compiled-code-block block context) + (*print-with-brackets 'compiled-code-block block context + (lambda (context*) + (receive (filename block-number library) + (compiled-code-block/filename-and-index block) + (*print-char #\space context*) + (if filename + (begin + (*print-char #\( context*) + (print-block-info filename block-number library context*) + (*print-char #\) context*)))) + (*print-char #\space context*) + (*print-datum block context*)))) + +(define (print-block-info filename block-number library context*) + (print-object (pathname-name filename) context*) + (if block-number + (begin + (*print-char #\space context*) + (*print-hex block-number context*))) + (if library + (begin + (*print-char #\space context*) + (print-object library context*)))) ;;;; Miscellaneous diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index ef89e7aaa..7f9c8abb4 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -5888,14 +5888,14 @@ USA. (files "library-parser") (parent (runtime library)) (export (runtime) + library-name=? + library-name? r7rs-source-program r7rs-source-libraries r7rs-source? read-r7rs-source register-r7rs-source!) (export (runtime library) - library-name=? - library-name? parsed-import-library parse-define-library-form parse-import-form