From: Stephen Adams Date: Fri, 19 May 1995 03:41:26 +0000 (+0000) Subject: Added call to DBG-INFO/REMEMBER. X-Git-Tag: 20090517-FFI~6303 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=4942ac23dddfcb823a51410b9b47fa0e6d6830c7;p=mit-scheme.git Added call to DBG-INFO/REMEMBER. --- diff --git a/v8/src/compiler/midend/coerce.scm b/v8/src/compiler/midend/coerce.scm index 4fd8e634a..1a19e9c41 100644 --- a/v8/src/compiler/midend/coerce.scm +++ b/v8/src/compiler/midend/coerce.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: coerce.scm,v 1.4 1995/04/29 22:26:36 adams Exp $ +$Id: coerce.scm,v 1.5 1995/05/19 03:41:26 adams Exp $ Copyright (c) 1995 Massachusetts Institute of Technology @@ -159,6 +159,7 @@ wins by about 10%. (name* (variable/rename name)) (form (coerce/env/form coercion-env)) (body (form/preserve form))) + (dbg-info/remember name `(CALL 'uncoerce '#F (LOOKUP ,name*))) (form/rewrite! form (bind name* (coerce/make-coercion name arity) body)) (let loop ((refs refs) (replaced 0) (kept 0)) diff --git a/v8/src/compiler/midend/lamlift.scm b/v8/src/compiler/midend/lamlift.scm index b12a43442..0b1a39ead 100644 --- a/v8/src/compiler/midend/lamlift.scm +++ b/v8/src/compiler/midend/lamlift.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: lamlift.scm,v 1.6 1995/04/29 01:02:49 adams Exp $ +$Id: lamlift.scm,v 1.7 1995/05/19 03:41:13 adams Exp $ Copyright (c) 1994-1995 Massachusetts Institute of Technology @@ -48,13 +48,13 @@ MIT in each case. |# (define-macro (define-lambda-lifter keyword bindings . body) (let ((proc-name (symbol-append 'LAMLIFT/ keyword))) (call-with-values - (lambda () (%matchup (cdr bindings) '(handler env) '(cdr form))) - (lambda (names code) - `(define ,proc-name - (let ((handler (lambda ,(cons (car bindings) names) ,@body))) - (named-lambda (,proc-name env form) - (lamlift/remember ,code - form)))))))) + (lambda () (%matchup (cdr bindings) '(handler env) '(cdr form))) + (lambda (names code) + `(DEFINE ,proc-name + (LET ((HANDLER (LAMBDA ,(cons (car bindings) names) ,@body))) + (NAMED-LAMBDA (,proc-name ENV FORM) + (LAMLIFT/REMEMBER ,code + FORM)))))))) (define-lambda-lifter LOOKUP (env name) (call-with-values @@ -66,11 +66,11 @@ MIT in each case. |# (define-lambda-lifter LAMBDA (env lambda-list body) (call-with-values - (lambda () - (lamlift/lambda* 'DYNAMIC env lambda-list body)) - (lambda (expr* env*) - env* ; ignored - expr*))) + (lambda () + (lamlift/lambda* 'DYNAMIC env lambda-list body)) + (lambda (expr* env*) + env* ; ignored + expr*))) (define (lamlift/lambda* context env lambda-list body) ;; (values expr* env*) @@ -163,8 +163,6 @@ MIT in each case. |# ((BEGIN) (lamlift/begin env expr)) ((IF) (lamlift/if env expr)) ((LETREC) (lamlift/letrec env expr)) - ((SET! UNASSIGNED? OR DELAY ACCESS DEFINE IN-PACKAGE THE-ENVIRONMENT) - (no-longer-legal expr)) (else (illegal expr)))) @@ -189,18 +187,19 @@ MIT in each case. |# (define (lamlift/new-name prefix) (new-variable prefix)) -(define-structure (lamlift/env - (conc-name lamlift/env/) - (constructor lamlift/env/%make (context parent depth)) - (print-procedure - (standard-unparser-method 'LAMLIFT/ENV - (lambda (env port) - (write-char #\space port) - (write (lamlift/env/context env) port) - (write-char #\space port) - (write (car (or (lamlift/env/form env) '(ROOT))) port) - (write-char #\space port) - (write (lamlift/env/depth env) port))))) +(define-structure + (lamlift/env + (conc-name lamlift/env/) + (constructor lamlift/env/%make (context parent depth)) + (print-procedure + (standard-unparser-method 'LAMLIFT/ENV + (lambda (env port) + (write-char #\space port) + (write (lamlift/env/context env) port) + (write-char #\space port) + (write (car (or (lamlift/env/form env) '(ROOT))) port) + (write-char #\space port) + (write (lamlift/env/depth env) port))))) (context false read-only true) ; STATIC or DYNAMIC (parent false read-only true) ; #F or another environment @@ -234,15 +233,16 @@ MIT in each case. |# (drift-frame #F read-only false) ) -(define-structure (lamlift/binding - (conc-name lamlift/binding/) - (constructor lamlift/binding/make (name env)) - (print-procedure - (standard-unparser-method 'LAMLIFT/BINDING - (lambda (v port) - (write-char #\space port) - (write-string (symbol-name (lamlift/binding/name v)) - port))))) +(define-structure + (lamlift/binding + (conc-name lamlift/binding/) + (constructor lamlift/binding/make (name env)) + (print-procedure + (standard-unparser-method 'LAMLIFT/BINDING + (lambda (v port) + (write-char #\space port) + (write-string (symbol-name (lamlift/binding/name v)) + port))))) (name #F read-only true) (env #F read-only true) ; a LAMLIFT/ENV @@ -275,14 +275,14 @@ MIT in each case. |# binding))) (else (call-with-values - (lambda () (walk-spine (lamlift/env/parent env))) - (lambda (ref binding) - (let* ((free (fetch env)) - (place (assq binding free))) - (if (not place) - (store! env (cons (list binding ref) free)) - (set-cdr! place (cons ref (cdr place)))) - (values ref binding)))))))) + (lambda () (walk-spine (lamlift/env/parent env))) + (lambda (ref binding) + (let* ((free (fetch env)) + (place (assq binding free))) + (if (not place) + (store! env (cons (list binding ref) free)) + (set-cdr! place (cons ref (cdr place)))) + (values ref binding)))))))) (case kind ((ORDINARY) @@ -700,13 +700,19 @@ MIT in each case. |# referenced-continuation-variable?))) (if (or (null? cont-vars) (not (null? (cdr cont-vars)))) - (internal-error "Creating LAMBDA with non-unique continuation" - env)) + (internal-error + "Creating LAMBDA with non-unique continuation" + env)) (append cont-vars other-vars)))))) ;; If this LAMBDA expression has a name, find all call sites and ;; rewrite to pass additional arguments (cond ((lamlift/env/binding env) => (lambda (binding) + (dbg-info/remember + (lamlift/binding/name binding) + (if (null? extra-formals) + `(LOOKUP ,lifted-name) + `(CALL 'un-lambda-lift '#F (LOOKUP ,lifted-name)))) (let ((reorder (lamlift/reorderer lambda-list** lifted-lambda-list))) (for-each