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.

diff --git a/src/compiler/base/asstop.scm b/src/compiler/base/asstop.scm
index 0a2fb5296b8ad7407badae08a0964fa466824784..6fc2993cf915d67c445aa2f80585a56f10eda4c4 100644 (file)
--- 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 934ad8db1e3dd9a0c929459e9a067f39528ec2cc..da71f0f693d434ff40fccaa067a907f025aeb31c 100644 (file)
--- 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))))
 \f
 (define (cross-link-end object)

diff --git a/src/compiler/base/toplev.scm b/src/compiler/base/toplev.scm
index fb9608984d70c4f3865bb35e6c8495d2f914bced..4d9aed3be9d509e2f9b275b7403dfad289b11d46 100644 (file)
--- 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 ac8b21369995d122d33138ff5717dd89b5b92897..26033ea94c521189abd4a5863af369e26f3f7438 100644 (file)
--- 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)))
+\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 832581e17186e03a98d1165e700fd3e8fb51f641..aa941b8940a7603811d39b728eb911aa0f6928bd 100644 (file)
--- 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 429924bd5c73842537e6e4c293aca4ee741defe0..3c58a52e588189884348fbfc0239198e54b6a591 100644 (file)
--- 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 5986ef3d421e9301a78bc0182eaeabba5e8552cc..6e064618a22b7d100568c3d5ad92a2b1e8e0f6bf 100644 (file)
--- 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 e9879bf3a3037039967f4813fff53db0a688c0a9..a36c86a21321f05a8e6389b17ff8a17569eb95d0 100644 (file)
--- 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 dfd51d4974c413c7e0ff0428c710b60f150247ca..7ef74f23c8d0ebdb4de1dbba952883f6b92d09c0 100644 (file)
--- a/src/runtime/infstr.scm
+++ b/src/runtime/infstr.scm
@@ -29,71 +29,46 @@ USA.
 
 (declare (usual-integrations))
 \f
-(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))
 \f
 (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.
 \f
 (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))))
 \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 b99ff000f0c4802b0506f0ecd5183964cde937ff..80104e630e10a701c19fdb7cb0b1bf340b6dafb2 100644 (file)
--- 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))
 \f
 (for-each
  (lambda (keyword)

diff --git a/src/sf/cgen.scm b/src/sf/cgen.scm
index 6606d43f58dca0d102dec63cb478eda1b425416f..c1179278359871eff08c73ccea5d41e19f735703 100644 (file)
--- 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