Annotate compiled-code binary files with sets of bound and free names.

This allows the loader to incorporate a "module system".

diff --git a/v7/src/compiler/base/asstop.scm b/v7/src/compiler/base/asstop.scm
index 666a60141e0693f6d05b454978cc30c0083badfd..59341788bd2a41aba9e679ae1ddd51c2a269f931 100644 (file)
--- a/v7/src/compiler/base/asstop.scm
+++ b/v7/src/compiler/base/asstop.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: asstop.scm,v 1.22 2008/09/10 15:12:07 riastradh Exp $
+$Id: asstop.scm,v 1.23 2009/02/23 02:02:44 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -253,7 +253,9 @@ USA.
                (set! *recursive-compilation-results*
                      (cons (vector *recursive-compilation-number*
                                    info
-                                   *code-vector*)
+                                   *code-vector*
+                                   *tl-bound*
+                                   *tl-free*)
                            *recursive-compilation-results*))
                (vector 'DEBUGGING-INFO-WRAPPER
                        2

diff --git a/v7/src/compiler/base/toplev.scm b/v7/src/compiler/base/toplev.scm
index c82d0c23f6b9f4fc24fdaaf5525771287d66ed14..8fa9f56c7918f2e0e7dbd48b6dea3e57d76cecf2 100644 (file)
--- a/v7/src/compiler/base/toplev.scm
+++ b/v7/src/compiler/base/toplev.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: toplev.scm,v 4.78 2008/09/10 15:12:07 riastradh Exp $
+$Id: toplev.scm,v 4.79 2009/02/23 02:02:44 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -382,6 +382,11 @@ USA.
 (define *root-expression*)
 (define *root-procedure*)
 
+;; First set: phase/fg-generation
+;; Last used: [end]
+(define *tl-bound*)
+(define *tl-free*)
+
 ;; First set: phase/rtl-generation
 ;; Last used: phase/lap-linearization
 (define *rtl-expression*)
@@ -415,30 +420,38 @@ USA.
         (lambda ()
           (let ((value
                  (let ((expression (thunk)))
-                   (let ((others
-                          (map (lambda (other) (vector-ref other 2))
-                               (recursive-compilation-results))))
-                     (cond ((not (compiled-code-address? expression))
-                            (vector compiler:compile-by-procedures?
-                                    expression
-                                    others))
-                           ((null? others)
-                            expression)
-                           (else
-                            (scode/make-comment
-                             (make-dbg-info-vector
-                              (let ((all-blocks
-                                     (list->vector
-                                      (cons
-                                       (compiled-code-address->block
-                                        expression)
-                                       others))))
-                                (if compiler:compile-by-procedures?
-                                    (list 'COMPILED-BY-PROCEDURES
-                                          all-blocks
-                                          (list->vector others))
-                                    all-blocks)))
-                             expression)))))))
+                   (let ((others (recursive-compilation-results)))
+                     (if (compiled-code-address? expression)
+                         (scode/make-comment
+                          (make-dbg-info-vector
+                           (if compiler:compile-by-procedures?
+                               'COMPILED-BY-PROCEDURES
+                               'COMPILED-AS-UNIT)
+                           (compiled-code-address->block expression)
+                           (list->vector
+                            (map (lambda (other)
+                                   (vector-ref other 2))
+                                 others))
+                           (list->vector
+                            (apply lset-union
+                                   equal?
+                                   *tl-bound*
+                                   (map (lambda (other)
+                                          (vector-ref other 3))
+                                        others)))
+                           (list->vector
+                            (apply lset-union
+                                   equal?
+                                   *tl-free*
+                                   (map (lambda (other)
+                                          (vector-ref other 4))
+                                        others))))
+                          expression)
+                         (vector compiler:compile-by-procedures?
+                                 expression
+                                 (map (lambda (other)
+                                        (vector-ref other 2))
+                                      others)))))))
             (if compiler:show-time-reports?
                 (compiler-time-report "Total compilation time"
                                       *process-time*
@@ -478,6 +491,8 @@ USA.
                (*root-expression*)
                (*root-procedure*)
                (*root-block*)
+               (*tl-bound*)
+               (*tl-free*)
                (*rtl-expression*)
                (*rtl-procedures*)
                (*rtl-continuations*)
@@ -515,6 +530,8 @@ USA.
   (set! *root-expression*)
   (set! *root-procedure*)
   (set! *root-block*)
+  (set! *tl-bound*)
+  (set! *tl-free*)
   (set! *rtl-expression*)
   (set! *rtl-procedures*)
   (set! *rtl-continuations*)
@@ -649,8 +666,11 @@ USA.
 (define (phase/canonicalize-scode)
   (compiler-subphase "Scode Canonicalization"
     (lambda ()
-      (set! *scode* (canonicalize/top-level (last-reference *input-scode*)))
-      unspecific)))
+      (receive (scode bound)
+         (canonicalize/top-level (last-reference *input-scode*))
+       (set! *scode* scode)
+       (set! *tl-bound* bound)
+       unspecific))))
 
 (define (phase/translate-scode)
   (compiler-subphase "Translation of Scode into Flow Graph"
@@ -674,6 +694,11 @@ USA.
                  (error "Value of procedure compilation not procedure" node))
              (set! *root-procedure* operand))))
       (set! *root-block* (expression-block *root-expression*))
+      (if (not *tl-bound*)
+         (set! *tl-bound*
+               (map variable-name (block-bound-variables *root-block*))))
+      (set! *tl-free*
+           (map variable-name (block-free-variables *root-block*)))
       (if (or (null? *expressions*)
              (not (null? (cdr *expressions*))))
          (error "Multiple expressions"))

diff --git a/v7/src/compiler/fggen/canon.scm b/v7/src/compiler/fggen/canon.scm
index 058e223b1b612090e8f44f05fe9568f62cb9d007..73091a4408374327a276e23f3e1553bee0a10652 100644 (file)
--- a/v7/src/compiler/fggen/canon.scm
+++ b/v7/src/compiler/fggen/canon.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: canon.scm,v 1.28 2008/01/30 20:01:44 cph Exp $
+$Id: canon.scm,v 1.29 2009/02/23 02:02:44 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -91,11 +91,13 @@ ARBITRARY:  The expression may be executed more than once.  It
   splice?)                             ; top level can be moved
 
 (define *top-level-declarations*)
+(define *top-level-definitions*)
 
 (define (canonicalize/top-level expression)
   (if (eq? compiler:package-optimization-level 'NONE)
-      expression
-      (fluid-let ((*top-level-declarations* '()))
+      (values expression #f)
+      (fluid-let ((*top-level-declarations* '())
+                 (*top-level-definitions* '()))
        (let ((result
               (canonicalize/expression
                expression '()
@@ -103,11 +105,13 @@ ARBITRARY:        The expression may be executed more than once.  It
                         (not (eq? compiler:package-optimization-level 'LOW)))
                    'TOP-LEVEL
                    'FIRST-CLASS))))
-         (if (canout-needs? result)
-             (canonicalize/bind-environment (canout-expr result)
-                                            (scode/make-the-environment)
-                                            expression)
-             (canout-expr result))))))
+         (values
+          (if (canout-needs? result)
+              (canonicalize/bind-environment (canout-expr result)
+                                             (scode/make-the-environment)
+                                             expression)
+              (canout-expr result))
+          *top-level-definitions*)))))
 
 (define (canonicalize/optimization-low? context)
   (or (eq? context 'FIRST-CLASS)
@@ -302,7 +306,7 @@ ARBITRARY:  The expression may be executed more than once.  It
        (if (memq context '(ONCE-ONLY ARBITRARY))
            (error "canonicalize/definition: unscanned definition"
                   expression))
-       (single-definition name value)))))
+       (single-definition name value context)))))
 
 (define (canonicalize/the-environment expr bound context)
   expr bound context ;; ignored
@@ -370,7 +374,10 @@ ARBITRARY: The expression may be executed more than once.  It
         name
         (canout-expr value))))
 
-(define (single-definition name value)
+(define (single-definition name value context)
+  (if (and (eq? context 'TOP-LEVEL)
+          (not (memq name *top-level-definitions*)))
+      (set! *top-level-definitions* (cons name *top-level-definitions*)))
   (make-canout (%single-definition name value)
               (canout-safe? value)
               true
@@ -379,7 +386,7 @@ ARBITRARY:  The expression may be executed more than once.  It
 ;; To reduce code space, split into two blocks, one with constants,
 ;; the other with expressions to be evaluated.
 
-(define (multi-definition names* values*)
+(define (multi-definition names* values* context)
   (define (collect names values wrapper)
     (if (null? (cdr values))
        (%single-definition (car names) (car values))
@@ -405,6 +412,9 @@ ARBITRARY:  The expression may be executed more than once.  It
               (scode/comment-directive? (scode/comment-text value)
                                         'COMPILE-PROCEDURE)))))
 
+  (if (eq? context 'TOP-LEVEL)
+      (set! *top-level-definitions*
+           (lset-union eq? names* *top-level-definitions*)))
   (let loop ((names names*) (values values*) (last 'NONE)
             (knames '()) (kvals '()) (vnames '()) (vvals '()))
     (cond ((null? names)
@@ -460,12 +470,14 @@ ARBITRARY:        The expression may be executed more than once.  It
                 ((null? (cdr group))
                  (let ((element (car group)))
                    (cons (single-definition (car element)
-                                            (cadr element))
+                                            (cadr element)
+                                            context)
                          groups)))
                 (else
                  (let ((group (reverse group)))
                    (cons (multi-definition (map car group)
-                                           (map cadr group))
+                                           (map cadr group)
+                                           context)
                          groups)))))
 
         (define (collect actions groups group)
@@ -500,7 +512,8 @@ ARBITRARY:  The expression may be executed more than once.  It
                                                group)))
                                (else
                                 (collect (cdr actions)
-                                         (cons (single-definition name value*)
+                                         (cons (single-definition name value*
+                                                                  context)
                                                (add-group group groups))
                                          '()))))))))))
 

diff --git a/v7/src/runtime/infstr.scm b/v7/src/runtime/infstr.scm
index bbc5905110e7e047a333ec8ae13a3cc140451feb..9460d775d78c1fc141fefc7fb8af71e9c7ebde58 100644 (file)
--- a/v7/src/runtime/infstr.scm
+++ b/v7/src/runtime/infstr.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: infstr.scm,v 1.21 2008/01/30 20:02:31 cph Exp $
+$Id: infstr.scm,v 1.22 2009/02/23 02:02:44 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -30,19 +30,61 @@ USA.
 
 (declare (usual-integrations))
 \f
-(define-integrable (make-dbg-info-vector info-vector)
-  (cons dbg-info-vector-tag info-vector))
-
-(define (dbg-info-vector? object)
-  (and (pair? object) (eq? (car object) dbg-info-vector-tag)))
-
-(define-integrable (dbg-info-vector/items info-vector)
-  (cdr info-vector))
-
-(define-integrable dbg-info-vector-tag
-  ((ucode-primitive string->symbol)
-   "#[(runtime compiler-info)dbg-info-vector-tag]"))
-
+(define-structure (dbg-info-vector
+                  (type vector)
+                  (named
+                   ((ucode-primitive string->symbol)
+                    "#[(runtime compiler-info)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))
+
+(define (old-dbg-info-vector? object)
+  (and (pair? object)
+       (eq? (car object)
+           '|#[(runtime compiler-info)dbg-info-vector-tag]|)))
+
+(define (dbg-info-vector/blocks-vector info)
+  (let ((lose
+        (lambda ()
+          (error:wrong-type-argument info "dbg-info-vector"
+                                     'DBG-INFO-VECTOR/BLOCKS-VECTOR))))
+    (cond ((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)))))
+
+(define (dbg-info-vector/purification-root info)
+  (let ((lose
+        (lambda ()
+          (error:wrong-type-argument info "dbg-info-vector"
+                                     'DBG-INFO-VECTOR/PURIFICATION-ROOT))))
+    (cond ((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))))
+\f
 (define-structure (dbg-info
                   (type vector)
                   (named

diff --git a/v7/src/runtime/infutl.scm b/v7/src/runtime/infutl.scm
index 78a08bacb7a9af19d64bca4b93261adfcd3ab505..8a3a5920c361be79f26697884529f69579004462 100644 (file)
--- a/v7/src/runtime/infutl.scm
+++ b/v7/src/runtime/infutl.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: infutl.scm,v 1.78 2008/09/03 19:36:59 riastradh Exp $
+$Id: infutl.scm,v 1.79 2009/02/23 02:02:44 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -163,25 +163,6 @@ USA.
 
 (define (dbg-labels/find-offset labels offset)
   (vector-binary-search labels < dbg-label/offset offset))
-
-(define (dbg-info-vector/blocks-vector info)
-  (let ((items (dbg-info-vector/items info)))
-    (cond ((vector? items) items)
-         ((and (pair? items)
-               (pair? (cdr items))
-               (vector? (cadr items)))
-          (cadr items))
-         (else (error "Illegal dbg-info-vector" info)))))
-
-(define (dbg-info-vector/purification-root info)
-  (let ((items (dbg-info-vector/items info)))
-    (cond ((vector? items) #f)
-         ((and (pair? items)
-               (eq? (car items) 'COMPILED-BY-PROCEDURES)
-               (pair? (cdr items))
-               (pair? (cddr items)))
-          (caddr items))
-         (else (error "Illegal dbg-info-vector" info)))))
 \f
 (define (fasload/update-debugging-info! value com-pathname)
   (cond ((compiled-code-address? value)