From acd462d58e3647c8c28a4fbce703fb510cd720f9 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 23 Feb 2009 02:02:44 +0000
Subject: [PATCH] Annotate compiled-code binary files with sets of bound and
free names. This allows the loader to incorporate a "module system".
---
v7/src/compiler/base/asstop.scm | 6 ++-
v7/src/compiler/base/toplev.scm | 79 ++++++++++++++++++++++-----------
v7/src/compiler/fggen/canon.scm | 41 +++++++++++------
v7/src/runtime/infstr.scm | 70 +++++++++++++++++++++++------
v7/src/runtime/infutl.scm | 21 +--------
5 files changed, 140 insertions(+), 77 deletions(-)
diff --git a/v7/src/compiler/base/asstop.scm b/v7/src/compiler/base/asstop.scm
index 666a60141..59341788b 100644
--- 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 c82d0c23f..8fa9f56c7 100644
--- 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 058e223b1..73091a440 100644
--- 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 bbc590511..9460d775d 100644
--- 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))
-(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))))
+
(define-structure (dbg-info
(type vector)
(named
diff --git a/v7/src/runtime/infutl.scm b/v7/src/runtime/infutl.scm
index 78a08bacb..8a3a5920c 100644
--- 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)))))
(define (fasload/update-debugging-info! value com-pathname)
(cond ((compiled-code-address? value)
--
2.25.1