From: Chris Hanson Date: Mon, 23 Feb 2009 02:02:44 +0000 (+0000) Subject: Annotate compiled-code binary files with sets of bound and free names. X-Git-Tag: 20090517-FFI~65 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=acd462d58e3647c8c28a4fbce703fb510cd720f9;p=mit-scheme.git 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 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)