From 544544e12f38f974dfa84c087adb0b97ee443977 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Sun, 27 May 2018 22:05:33 -0700 Subject: [PATCH] Implement target-metadata declaration. This declaration has a body that's an alist keyed by symbols. The information in the declaration is carried through the compiler and attached to the compiled code in the wrapper comment. The short-term purpose of this declaration is to attach R7RS library information to compiled code. But it's general enough for other uses too. --- src/compiler/base/asstop.scm | 5 +- src/compiler/base/crsend.scm | 25 +-- src/compiler/base/toplev.scm | 22 ++- src/compiler/fggen/declar.scm | 17 ++ src/compiler/machines/C/compiler.pkg | 2 +- src/compiler/machines/i386/compiler.pkg | 2 +- src/compiler/machines/svm/compiler.pkg | 2 +- src/compiler/machines/x86-64/compiler.pkg | 2 +- src/runtime/infstr.scm | 205 +++++++--------------- src/runtime/syntax-declaration.scm | 6 + src/sf/cgen.scm | 1 + 11 files changed, 124 insertions(+), 165 deletions(-) diff --git a/src/compiler/base/asstop.scm b/src/compiler/base/asstop.scm index 0a2fb5296..6fc2993cf 100644 --- a/src/compiler/base/asstop.scm +++ b/src/compiler/base/asstop.scm @@ -254,7 +254,8 @@ USA. info *code-vector* *tl-bound* - *tl-free*) + *tl-free* + *tl-metadata*) *recursive-compilation-results*)) (vector 'DEBUGGING-INFO-WRAPPER 2 @@ -299,7 +300,7 @@ USA. (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"))) diff --git a/src/compiler/base/crsend.scm b/src/compiler/base/crsend.scm index 934ad8db1..da71f0f69 100644 --- a/src/compiler/base/crsend.scm +++ b/src/compiler/base/crsend.scm @@ -129,17 +129,20 @@ USA. (if (null? others) expression (scode/make-comment - (make-dbg-info-vector - (let ((all-blocks - (list->vector - (cons - (compiled-code-address->block expression) - others)))) - (if compile-by-procedures? - (list 'COMPILED-BY-PROCEDURES - all-blocks - (list->vector others)) - all-blocks))) + ;; Keep in sync with "toplev.scm" and with "runtime/infstr.scm". + (vector + '|#[(runtime compiler-info)dbg-info-vector]| + (if compile-by-procedures? + 'compiled-by-procedures + 'compiled-as-unit) + (compiled-code-address->block expression) + (list->vector + (map (lambda (other) + (vector-ref other 2)) + others)) + '() + '() + '()) expression)))) (define (cross-link-end object) diff --git a/src/compiler/base/toplev.scm b/src/compiler/base/toplev.scm index fb9608984..4d9aed3be 100644 --- a/src/compiler/base/toplev.scm +++ b/src/compiler/base/toplev.scm @@ -395,6 +395,7 @@ USA. ;; Last used: [end] (define *tl-bound*) (define *tl-free*) +(define *tl-metadata*) ;; First set: phase/rtl-generation ;; Last used: phase/lap-linearization @@ -432,10 +433,13 @@ USA. (let ((others (recursive-compilation-results))) (if (compiled-code-address? expression) (scode/make-comment - (make-dbg-info-vector + ;; Keep in sync with "crsend.scm" and with + ;; "runtime/infstr.scm". + (vector + '|#[(runtime compiler-info)dbg-info-vector]| (if compiler:compile-by-procedures? - 'COMPILED-BY-PROCEDURES - 'COMPILED-AS-UNIT) + 'compiled-by-procedures + 'compiled-as-unit) (compiled-code-address->block expression) (list->vector (map (lambda (other) @@ -454,7 +458,14 @@ USA. *tl-free* (map (lambda (other) (vector-ref other 4)) - others)))) + others))) + (delete-duplicates + (append *tl-metadata* + (append-map (lambda (other) + (vector-ref other 5)) + others)) + (lambda (elt1 elt2) + (eq? (car elt1) (car elt2))))) expression) (vector compiler:compile-by-procedures? expression @@ -502,6 +513,7 @@ USA. (*root-block*) (*tl-bound*) (*tl-free*) + (*tl-metadata*) (*rtl-expression*) (*rtl-procedures*) (*rtl-continuations*) @@ -541,6 +553,7 @@ USA. (set! *root-block*) (set! *tl-bound*) (set! *tl-free*) + (set! *tl-metadata*) (set! *rtl-expression*) (set! *rtl-procedures*) (set! *rtl-continuations*) @@ -692,6 +705,7 @@ USA. (set! *lvalues* '()) (set! *applications* '()) (set! *parallels* '()) + (set! *tl-metadata* '()) (set! *root-expression* (construct-graph (last-reference *scode*))) (if *procedure-result?* (let ((node (expression-entry-node *root-expression*))) diff --git a/src/compiler/fggen/declar.scm b/src/compiler/fggen/declar.scm index ac8b21369..26033ea94 100644 --- a/src/compiler/fggen/declar.scm +++ b/src/compiler/fggen/declar.scm @@ -212,3 +212,20 @@ USA. (check-property block-range-checks set-block-range-checks! #t)) (define-pre-only-declaration 'NO-RANGE-CHECKS (check-property block-range-checks set-block-range-checks! #f))) + +;;;; Metadata to be included in output + +(define-pre-only-declaration 'target-metadata + (lambda (block keyword value) + (declare (ignore block)) + (if (list-of-type? value + (lambda (elt) + (and (pair? elt) + (symbol? (car elt)) + (list? (cdr elt))))) + (begin + (set! *tl-metadata* + (append! *tl-metadata* + (list-copy value))) + unspecific) + (warn "Ill-formed metadata declaration:" (cons keyword value))))) \ No newline at end of file diff --git a/src/compiler/machines/C/compiler.pkg b/src/compiler/machines/C/compiler.pkg index 832581e17..aa941b894 100644 --- a/src/compiler/machines/C/compiler.pkg +++ b/src/compiler/machines/C/compiler.pkg @@ -246,6 +246,7 @@ USA. c-output-extension canonicalize-label-name) (export (compiler fg-generator) + *tl-metadata* compile-recursively) (export (compiler rtl-generator) *ic-procedure-headers* @@ -271,7 +272,6 @@ USA. *rtl-procedures* *rtl-graphs*) (import (runtime compiler-info) - make-dbg-info-vector split-inf-structure!) (import (runtime load) fasload-object-file) diff --git a/src/compiler/machines/i386/compiler.pkg b/src/compiler/machines/i386/compiler.pkg index 429924bd5..3c58a52e5 100644 --- a/src/compiler/machines/i386/compiler.pkg +++ b/src/compiler/machines/i386/compiler.pkg @@ -240,6 +240,7 @@ USA. (export (compiler) canonicalize-label-name) (export (compiler fg-generator) + *tl-metadata* compile-recursively) (export (compiler rtl-generator) *ic-procedure-headers* @@ -256,7 +257,6 @@ USA. *rtl-procedures* *rtl-graphs*) (import (runtime compiler-info) - make-dbg-info-vector split-inf-structure!) (import (scode-optimizer build-utilities) directory-processor)) diff --git a/src/compiler/machines/svm/compiler.pkg b/src/compiler/machines/svm/compiler.pkg index 5986ef3d4..6e064618a 100644 --- a/src/compiler/machines/svm/compiler.pkg +++ b/src/compiler/machines/svm/compiler.pkg @@ -243,6 +243,7 @@ USA. (export (compiler) canonicalize-label-name) (export (compiler fg-generator) + *tl-metadata* compile-recursively) (export (compiler rtl-generator) *ic-procedure-headers* @@ -259,7 +260,6 @@ USA. *rtl-procedures* *rtl-graphs*) (import (runtime compiler-info) - make-dbg-info-vector split-inf-structure!) (import (scode-optimizer build-utilities) directory-processor)) diff --git a/src/compiler/machines/x86-64/compiler.pkg b/src/compiler/machines/x86-64/compiler.pkg index e9879bf3a..a36c86a21 100644 --- a/src/compiler/machines/x86-64/compiler.pkg +++ b/src/compiler/machines/x86-64/compiler.pkg @@ -243,6 +243,7 @@ USA. (export (compiler) canonicalize-label-name) (export (compiler fg-generator) + *tl-metadata* compile-recursively) (export (compiler rtl-generator) *ic-procedure-headers* @@ -259,7 +260,6 @@ USA. *rtl-procedures* *rtl-graphs*) (import (runtime compiler-info) - make-dbg-info-vector split-inf-structure!) (import (scode-optimizer build-utilities) directory-processor)) diff --git a/src/runtime/infstr.scm b/src/runtime/infstr.scm index dfd51d497..7ef74f23c 100644 --- a/src/runtime/infstr.scm +++ b/src/runtime/infstr.scm @@ -29,71 +29,46 @@ USA. (declare (usual-integrations)) -(define-structure (dbg-info-vector - (type vector) - (named - ((ucode-primitive string->symbol) - "#[(runtime compiler-info)dbg-info-vector]")) - (predicate new-dbg-info-vector?) - (conc-name dbg-info-vector/)) - (compilation-type #f read-only #t) - (root-block #f read-only #t) - (other-blocks #f read-only #t) - (tl-bound #f read-only #t) - (tl-free #f read-only #t)) +;;; Keep in sync with "compiler/base/toplev.scm" and "compiler/base/crsend.scm". (define (dbg-info-vector? object) - (or (new-dbg-info-vector? object) - (old-dbg-info-vector? object))) + (and (vector? object) + ;; Length 6 can be removed after 9.3 release. + (or (fix:= 6 (vector-length object)) + (fix:= 7 (vector-length object))) + (eq? '|#[(runtime compiler-info)dbg-info-vector]| + (vector-ref object 0)))) + +(define-integrable (dbg-info-vector/compilation-type v) + (vector-ref v 1)) + +(define-integrable (dbg-info-vector/root-block v) + (vector-ref v 2)) + +(define-integrable (dbg-info-vector/other-blocks v) + (vector-ref v 3)) + +(define-integrable (dbg-info-vector/tl-bound v) + (vector-ref v 4)) + +(define-integrable (dbg-info-vector/tl-free v) + (vector-ref v 5)) -(define (old-dbg-info-vector? object) - (and (pair? object) - (eq? (car object) - '|#[(runtime compiler-info)dbg-info-vector-tag]|))) +(define-integrable (dbg-info-vector/tl-metadata v) + (vector-ref v 6)) (define (dbg-info-vector/blocks-vector info) - (let ((lose - (lambda () - (error:wrong-type-argument info "dbg-info-vector" - 'dbg-info-vector/blocks-vector)))) - (cond ((new-dbg-info-vector? info) - (vector-append (vector (dbg-info-vector/root-block info)) - (dbg-info-vector/other-blocks info))) - ((old-dbg-info-vector? info) - (let ((items (cdr info))) - (cond ((vector? items) items) - ((%compound-items? items) (cadr items)) - (else (lose))))) - (else (lose))))) + (guarantee dbg-info-vector? info 'dbg-info-vector/blocks-vector) + (vector-append (vector (dbg-info-vector/root-block info)) + (dbg-info-vector/other-blocks info))) (define (dbg-info-vector/purification-root info) - (let ((lose - (lambda () - (error:wrong-type-argument info "dbg-info-vector" - 'dbg-info-vector/purification-root)))) - (cond ((new-dbg-info-vector? info) - (dbg-info-vector/other-blocks info)) - ((old-dbg-info-vector? info) - (let ((items (cdr info))) - (cond ((vector? items) #f) - ((%compound-items? items) (caddr items)) - (else (lose))))) - (else (lose))))) - -(define (%compound-items? items) - (and (pair? items) - (eq? (car items) 'compiled-by-procedures) - (pair? (cdr items)) - (vector? (cadr items)) - (pair? (cddr items)) - (vector? (caddr items)) - (null? (cdddr items)))) + (guarantee dbg-info-vector? info 'dbg-info-vector/purification-root) + (dbg-info-vector/other-blocks info)) (define-structure (dbg-info (type vector) - (named - ((ucode-primitive string->symbol) - "#[(runtime compiler-info)dbg-info]")) + (named '|#[(runtime compiler-info)dbg-info]|) (conc-name dbg-info/)) (expression #f read-only #t) ;dbg-expression (procedures #f read-only #t) ;vector of dbg-procedure @@ -113,9 +88,7 @@ USA. (define-structure (dbg-expression (type vector) - (named - ((ucode-primitive string->symbol) - "#[(runtime compiler-info)dbg-expression]")) + (named '|#[(runtime compiler-info)dbg-expression]|) (conc-name dbg-expression/)) (block #f read-only #t) ;dbg-block (label #f) ;dbg-label @@ -126,9 +99,7 @@ USA. (define-structure (dbg-procedure (type vector) - (named - ((ucode-primitive string->symbol) - "#[(runtime compiler-info)dbg-procedure]")) + (named '|#[(runtime compiler-info)dbg-procedure]|) (constructor make-dbg-procedure (block label type name required optional rest auxiliary @@ -156,9 +127,7 @@ USA. (define-structure (dbg-continuation (type vector) - (named - ((ucode-primitive string->symbol) - "#[(runtime compiler-info)dbg-continuation]")) + (named '|#[(runtime compiler-info)dbg-continuation]|) (conc-name dbg-continuation/)) (block #f read-only #t) ;dbg-block (label #f) ;dbg-label @@ -175,9 +144,7 @@ USA. (define-structure (dbg-block (type vector) - (named - ((ucode-primitive string->symbol) - "#[(runtime compiler-info)dbg-block]")) + (named '|#[(runtime compiler-info)dbg-block]|) (constructor make-dbg-block (type parent original-parent layout stack-link)) @@ -192,32 +159,30 @@ USA. (define-structure (dbg-variable (type vector) - (named - ((ucode-primitive string->symbol) - "#[(runtime compiler-info)dbg-variable]")) + (named '|#[(runtime compiler-info)dbg-variable]|) (conc-name dbg-variable/)) (name #f read-only #t) ;symbol (type #f read-only #t) ;normal, cell, integrated value ;for integrated, the value ) -(let-syntax - ((dbg-block-name - (sc-macro-transformer - (lambda (form environment) - (let ((symbol (symbol 'dbg-block-name/ (cadr form)))) - `(define-integrable ,symbol - ',((ucode-primitive string->symbol) - (string-append "#[(runtime compiler-info)" - (string-downcase (symbol->string symbol)) - "]")))))))) - ;; Various names used in `layout' to identify things that wouldn't - ;; otherwise have names. - (dbg-block-name dynamic-link) - (dbg-block-name ic-parent) - (dbg-block-name normal-closure) - (dbg-block-name return-address) - (dbg-block-name static-link)) +;;; Various names used in `layout' to identify things that wouldn't otherwise +;;; have names. + +(define-integrable dbg-block-name/dynamic-link + '|#[(runtime compiler-info)dynamic-link]|) + +(define-integrable dbg-block-name/ic-parent + '|#[(runtime compiler-info)ic-parent]|) + +(define-integrable dbg-block-name/normal-closure + '|#[(runtime compiler-info)normal-closure]|) + +(define-integrable dbg-block-name/return-address + '|#[(runtime compiler-info)return-address]|) + +(define-integrable dbg-block-name/static-link + '|#[(runtime compiler-info)static-link]|) (define-integrable make-dbg-label-2 cons) (define-integrable dbg-label/name car) @@ -239,24 +204,18 @@ USA. (let ((wrapper (compiled-code-block/debugging-info block))) (if (debugging-wrapper? wrapper) wrapper - (let ((wrapper (convert-old-debugging-wrapper wrapper))) - (if wrapper - (set-compiled-code-block/debugging-info! block wrapper)) - wrapper)))) + #f))) (define (debugging-wrapper? wrapper) (and (vector? wrapper) (fix:= (vector-length wrapper) 6) (eq? (vector-ref wrapper 0) 'debugging-info-wrapper) - (or (fix:= (vector-ref wrapper 1) 1) - (fix:= (vector-ref wrapper 1) 2)) + (fix:= (vector-ref wrapper 1) 2) (or (and (not (vector-ref wrapper 2)) (not (vector-ref wrapper 3)) (not (vector-ref wrapper 4)) (dbg-info? (vector-ref wrapper 5))) - (and (if (fix:= (vector-ref wrapper 1) 1) - (not (vector-ref wrapper 2)) - (dbg-info-key? (vector-ref wrapper 2))) + (and (dbg-info-key? (vector-ref wrapper 2)) (debug-info-pathname? (vector-ref wrapper 3)) (index-fixnum? (vector-ref wrapper 4)) (or (not (vector-ref wrapper 5)) @@ -282,50 +241,17 @@ USA. (define (set-debugging-wrapper/info! wrapper info) (vector-set! wrapper 5 info)) - -(define (convert-old-debugging-wrapper wrapper) - (let ((make-wrapper - (lambda (pathname index info) - (vector 'debugging-info-wrapper 1 #f - (convert-old-style-pathname pathname) - index info)))) - (cond ((dbg-info? wrapper) - (make-wrapper #f #f wrapper)) - ((debug-info-pathname? wrapper) - (make-wrapper wrapper 0 #f)) - ((and (pair? wrapper) - (debug-info-pathname? (car wrapper)) - (dbg-info? (cdr wrapper))) - (make-wrapper (car wrapper) 0 (cdr wrapper))) - ((and (pair? wrapper) - (debug-info-pathname? (car wrapper)) - (index-fixnum? (cdr wrapper)) - (fix:> (cdr wrapper) 0)) - (make-wrapper (car wrapper) (cdr wrapper) #f)) - ((and (pair? wrapper) - (pair? (car wrapper)) - (debug-info-pathname? (caar wrapper)) - (index-fixnum? (cdar wrapper)) - (fix:> (cdar wrapper) 0) - (dbg-info? (cdr wrapper))) - (make-wrapper (caar wrapper) (cdar wrapper) (cdr wrapper))) - (else #f)))) (define (debugging-file-wrapper? wrapper) (and (vector? wrapper) (fix:= (vector-length wrapper) 4) (eq? (vector-ref wrapper 0) 'debugging-file-wrapper) - (or (and (fix:= (vector-ref wrapper 1) 1) - (not (vector-ref wrapper 2))) - (and (fix:= (vector-ref wrapper 1) 2) - (dbg-info-key? (vector-ref wrapper 2)))) + (fix:= (vector-ref wrapper 1) 2) + (dbg-info-key? (vector-ref wrapper 2)) (let ((info (vector-ref wrapper 3))) - (let ((n (vector-length info))) - (and (fix:>= n 1) - (let loop ((i 0)) - (or (fix:= i n) - (and (dbg-info? (vector-ref info i)) - (loop (fix:+ i 1)))))))))) + (and (vector? info) + (fix:>= (vector-length info) 1) + (vector-every dbg-info? info))))) (define (debugging-file-wrapper/version wrapper) (vector-ref wrapper 1)) @@ -339,16 +265,6 @@ USA. (define (canonicalize-file-wrapper wrapper) (cond ((debugging-file-wrapper? wrapper) wrapper) - ((dbg-info? wrapper) - (vector 'debugging-file-wrapper 1 #f (vector wrapper))) - ((and (vector? wrapper) - (let ((n (vector-length wrapper))) - (and (fix:>= n 1) - (let loop ((i 0)) - (or (fix:= i n) - (and (dbg-info? (vector-ref wrapper i)) - (loop (fix:+ i 1)))))))) - (vector 'debugging-file-wrapper 1 #f wrapper)) (else #f))) (define (get-wrapped-dbg-info file-wrapper wrapper) @@ -364,6 +280,7 @@ USA. (define (dbg-info-key? object) (or (and (bytevector? object) (fix:= (bytevector-length object) 32)) + ;; The following can be removed after 9.3 release: (and ((ucode-primitive string? 1) object) (fix:= ((ucode-primitive string-length 1) object) 32)))) diff --git a/src/runtime/syntax-declaration.scm b/src/runtime/syntax-declaration.scm index b99ff000f..80104e630 100644 --- a/src/runtime/syntax-declaration.scm +++ b/src/runtime/syntax-declaration.scm @@ -91,6 +91,12 @@ USA. (lambda (procedure declaration selector) (declare (ignore procedure selector)) declaration)) + +(define-declaration 'target-metadata + `(* (symbol * datum)) + (lambda (procedure declaration selector) + (declare (ignore procedure selector)) + declaration)) (for-each (lambda (keyword) diff --git a/src/sf/cgen.scm b/src/sf/cgen.scm index 6606d43f5..c11792783 100644 --- a/src/sf/cgen.scm +++ b/src/sf/cgen.scm @@ -91,6 +91,7 @@ USA. pure-function range-checks side-effect-free + target-metadata type-checks usual-definition uuo-link -- 2.25.1