From dbab8e22ae3692ad73ea110a74c26c17d42cb89d Mon Sep 17 00:00:00 2001 From: "Guillermo J. Rozas" Date: Sat, 26 Nov 1994 22:07:13 +0000 Subject: [PATCH] Some minor changes for environment information. --- v8/src/compiler/midend/alpha.scm | 52 ++++++++++++------ v8/src/compiler/midend/dbgstr.scm | 9 ++-- v8/src/compiler/midend/envconv.scm | 84 +++++++++++++++--------------- v8/src/compiler/midend/expand.scm | 69 +++++++++++++----------- v8/src/compiler/midend/utils.scm | 23 ++++++-- 5 files changed, 141 insertions(+), 96 deletions(-) diff --git a/v8/src/compiler/midend/alpha.scm b/v8/src/compiler/midend/alpha.scm index 87cea0927..0a7ff34d4 100644 --- a/v8/src/compiler/midend/alpha.scm +++ b/v8/src/compiler/midend/alpha.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: alpha.scm,v 1.3 1994/11/25 22:58:37 adams Exp $ +$Id: alpha.scm,v 1.4 1994/11/26 22:07:13 gjr Exp $ Copyright (c) 1988-1994 Massachusetts Institute of Technology @@ -42,21 +42,26 @@ MIT in each case. |# (define-macro (define-alphaconv keyword bindings . body) (let ((proc-name (symbol-append 'ALPHACONV/ keyword))) (call-with-values - (lambda () (%matchup (cddr bindings) '(handler state env) '(cdr form))) - (lambda (names code) - `(define ,proc-name - (let ((handler (lambda ,(cons* (car bindings) (cadr bindings) names) ,@body))) - (named-lambda (,proc-name state env form) - ,code))))))) + (lambda () (%matchup (cddr bindings) '(handler state env) '(cdr form))) + (lambda (names code) + `(define ,proc-name + (named-lambda (,proc-name state env form) + ;; All handlers inherit FORM (and others) from the + ;; surrounding scope. + (let ((handler + (lambda ,(cons* (car bindings) (cadr bindings) names) + ,@body))) + ,code))))))) (define-alphaconv LOOKUP (state env name) - env ; ignored + state env ; ignored `(LOOKUP ,(alphaconv/env/lookup name env))) (define-alphaconv LAMBDA (state env lambda-list body) (let* ((names (lambda-list->names lambda-list)) (new-names (alphaconv/renamings env names)) (env* (alphaconv/env/extend env names new-names))) + (alphaconv/remember-renames form env*) `(LAMBDA ,(alphaconv/rename-lambda-list lambda-list new-names) ,(alphaconv/expr state env* body)))) @@ -68,6 +73,20 @@ MIT in each case. |# (else (loop (cdr ll) (cdr nn) (cons (car nn) result)))))) +(define (alphaconv/remember-renames form env*) + (let ((info (code-rewrite/original-form/previous form))) + (and info + (new-dbg-procedure? info) + (let ((block (new-dbg-procedure/block info))) + (and block + (for-each + (lambda (var) + (set-new-dbg-variable/name! + var + (alphaconv/env/lookup (new-dbg-variable/original-name var) + env*))) + (new-dbg-block/variables block))))))) + (define-alphaconv CALL (state env rator cont #!rest rands) `(CALL ,(alphaconv/expr state env rator) ,(alphaconv/expr state env cont) @@ -84,19 +103,20 @@ MIT in each case. |# (new-names (alphaconv/renamings env names)) (inner-env (alphaconv/env/extend env names new-names)) (expr-env (if (eq? keyword 'LETREC) inner-env env)) - (bindings* (map (lambda (new-name binding) - (list new-name - (alphaconv/expr state expr-env (second binding)))) - new-names - bindings))) + (bindings* + (map (lambda (new-name binding) + (list new-name + (alphaconv/expr state expr-env (second binding)))) + new-names + bindings))) `(,keyword ,bindings* ,(alphaconv/expr state inner-env body)))) (define-alphaconv QUOTE (state env object) - env ; ignored + state env ; ignored `(QUOTE ,object)) (define-alphaconv DECLARE (state env #!rest anything) - env ; ignored + state env ; ignored `(DECLARE ,@anything)) (define-alphaconv BEGIN (state env #!rest actions) @@ -111,7 +131,7 @@ MIT in each case. |# `(SET! ,(alphaconv/env/lookup name env) ,(alphaconv/expr state env value))) (define-alphaconv UNASSIGNED? (state env name) - env ; ignored + state env ; ignored `(UNASSIGNED? ,(alphaconv/env/lookup name env))) (define-alphaconv OR (state env pred alt) diff --git a/v8/src/compiler/midend/dbgstr.scm b/v8/src/compiler/midend/dbgstr.scm index 5061307cb..b609e80b1 100644 --- a/v8/src/compiler/midend/dbgstr.scm +++ b/v8/src/compiler/midend/dbgstr.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: dbgstr.scm,v 1.3 1994/11/25 23:03:33 adams Exp $ +$Id: dbgstr.scm,v 1.4 1994/11/26 22:05:20 gjr Exp $ Copyright (c) 1994 Massachusetts Institute of Technology @@ -36,7 +36,8 @@ MIT in each case. |# (define-structure (new-dbg-expression (conc-name new-dbg-expression/) - (constructor new-dbg-expression/make (expr))) + (constructor new-dbg-expression/make (expr)) + (constructor new-dbg-expression/make2 (expr block))) (expr false read-only true) (block false read-only false)) @@ -63,8 +64,8 @@ MIT in each case. |# (define-structure (new-dbg-variable (conc-name new-dbg-variable/) - (constructor new-dbg-variable/make (name block))) - (name false read-only true) + (constructor new-dbg-variable/make (original-name block))) + (name original-name read-only false) (original-name name read-only true) (block false read-only false) (original-block block read-only false) diff --git a/v8/src/compiler/midend/envconv.scm b/v8/src/compiler/midend/envconv.scm index 4c103d9fd..541c1f5c6 100644 --- a/v8/src/compiler/midend/envconv.scm +++ b/v8/src/compiler/midend/envconv.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: envconv.scm,v 1.4 1994/11/26 00:23:24 jmiller Exp $ +$Id: envconv.scm,v 1.5 1994/11/26 22:06:52 gjr Exp $ Copyright (c) 1994 Massachusetts Institute of Technology @@ -116,38 +116,40 @@ MIT in each case. |# (envconv/new-reference env name `(SET! ,name ,value*)))) (define (envconv/lambda env form name) - (let ((form* - (let ((lambda-list (lambda/formals form)) - (body (lambda/body form))) - (if (or (not (eq? (envconv/env/context env) 'TOP-LEVEL)) - (not *envconv/compile-by-procedures?*) - *envconv/procedure-result?* - (eq? form *envconv/top-level-program*)) - (envconv/lambda* 'ARBITRARY env lambda-list body) - (envconv/compile-separately form name true env))))) - (envconv/remember form* - form - (if (LAMBDA/? form*) - (let* ((body (lambda/body form*)) - (body-info (code-rewrite/original-form body))) - (cond ((not body-info) false) - ((new-dbg-procedure? body-info) - (new-dbg-block/parent - (new-dbg-procedure/block body-info))) - (else - (new-dbg-expression/block body-info)))) - (envconv/env/block env))))) - - -(define (envconv/lambda* context* env lambda-list body) - (envconv/binding-body context* - env - ;; Ignore continuation - (cdr (lambda-list->names lambda-list)) - body - (lambda (body*) - `(LAMBDA ,lambda-list - ,body*)))) + (let ((lambda-list (lambda/formals form)) + (body (lambda/body form))) + (if (or (not (eq? (envconv/env/context env) 'TOP-LEVEL)) + (not *envconv/compile-by-procedures?*) + *envconv/procedure-result?* + (eq? form *envconv/top-level-program*)) + (envconv/lambda* 'ARBITRARY env form) + (envconv/compile-separately form name true env)))) + +(define (envconv/lambda* context* env form) + (let ((lambda-list (lambda/formals form)) + (body (lambda/body form))) + (let ((form* + (envconv/binding-body context* + env + ;; Ignore continuation + (cdr (lambda-list->names lambda-list)) + body + (lambda (body*) + `(LAMBDA ,lambda-list + ,body*))))) + (envconv/remember form* + form + (if (LAMBDA/? form*) + (let* ((body (lambda/body form*)) + (body-info + (code-rewrite/original-form body))) + (cond ((not body-info) false) + ((new-dbg-procedure? body-info) + (new-dbg-block/parent + (new-dbg-procedure/block body-info))) + (else + (new-dbg-expression/block body-info)))) + (envconv/env/block env)))))) (define-environment-converter LET (env bindings body) (let ((bindings* (lmap (lambda (binding) @@ -227,16 +229,12 @@ MIT in each case. |# (define-environment-converter CALL (env rator cont #!rest rands) (define (default) `(CALL ,(if (LAMBDA/? rator) - (envconv/remember - (envconv/lambda* + (envconv/lambda* (if (eq? (envconv/env/context env) 'ARBITRARY) 'ARBITRARY 'ONCE-ONLY) - env (lambda/formals rator) (lambda/body rator)) - rator - (envconv/env/block env)) + env rator) (envconv/expr env rator)) - ,(envconv/expr env cont) ,@(envconv/expr* env rands))) @@ -303,8 +301,6 @@ MIT in each case. |# (envconv/lookup env expr)) ((LAMBDA) (envconv/lambda env expr name)) - ((LET) - (envconv/let env expr)) ((DECLARE) (envconv/declare env expr)) ((CALL) @@ -329,7 +325,11 @@ MIT in each case. |# (envconv/in-package env expr)) ((THE-ENVIRONMENT) (envconv/the-environment env expr)) - ((LETREC) +#| + ((LET) + (envconv/let env expr)) +|# + ((LET LETREC) (not-yet-legal expr)) (else (illegal expr)))) diff --git a/v8/src/compiler/midend/expand.scm b/v8/src/compiler/midend/expand.scm index faee124df..cc517e6f2 100644 --- a/v8/src/compiler/midend/expand.scm +++ b/v8/src/compiler/midend/expand.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: expand.scm,v 1.1 1994/11/19 02:04:29 adams Exp $ +$Id: expand.scm,v 1.2 1994/11/26 22:05:28 gjr Exp $ Copyright (c) 1994 Massachusetts Institute of Technology @@ -63,23 +63,41 @@ MIT in each case. |# (define-expander SET! (name value) `(SET! ,name ,(expand/expr value))) +#| (define-expander LAMBDA (lambda-list body) (expand/rewrite/lambda lambda-list (expand/expr body))) - -(define (expand/rewrite/lambda lambda-list body) - (cond ((memq '#!AUX lambda-list) - => (lambda (tail) - (let ((rest (list-prefix lambda-list tail)) - (auxes (cdr tail))) - `(LAMBDA ,rest - ,(if (null? auxes) - body - `(LET ,(lmap (lambda (aux) - (list aux `(QUOTE ,%unassigned))) - auxes) - ,(expand/aux/sort auxes body))))))) - (else - `(LAMBDA ,lambda-list ,body)))) +|# + +(define (expand/lambda form) + (expand/remember + (let ((lambda-list (lambda/formals form)) + (body (expand/expr (lambda/body form)))) + (cond ((memq '#!AUX lambda-list) + => (lambda (tail) + (let ((rest (list-prefix lambda-list tail)) + (auxes (cdr tail))) + (if (null? auxes) + `(LAMBDA ,rest ,body) + (let ((body* + `(LET ,(lmap (lambda (aux) + (list aux `(QUOTE ,%unassigned))) + auxes) + ,(expand/aux/sort auxes body)))) + (expand/split-block body* form) + `(LAMBDA ,rest + ,body*)))))) + (else + `(LAMBDA ,lambda-list ,body)))) + form)) + +(define (expand/split-block new-form form) + (let ((info (code-rewrite/original-form/previous form))) + (and info + (new-dbg-procedure? info) + (expand/remember* + new-form + (new-dbg-expression/make2 false + (new-dbg-procedure/block info)))))) (define-expander LET (bindings body) (expand/let* expand/letify bindings body)) @@ -88,19 +106,9 @@ MIT in each case. |# `(DECLARE ,@anything)) (define-expander CALL (rator cont #!rest rands) - (if (and (pair? rator) (eq? (car rator) 'LAMBDA)) - (let ((result - (let ((rator* (expand/rewrite/lambda (cadr rator) (caddr rator)))) - (expand/let* (lambda (bindings body) - (expand/pseudo-letify rator bindings body)) - (expand/bindify (cadr rator*) - (cons cont rands)) - (caddr rator*))))) - (expand/remember (cadr result) rator) - result) - `(CALL ,(expand/expr rator) - ,(expand/expr cont) - ,@(expand/expr* rands)))) + `(CALL ,(expand/expr rator) + ,(expand/expr cont) + ,@(expand/expr* rands))) (define-expander BEGIN (#!rest actions) (expand/code-compress (expand/expr* actions))) @@ -247,6 +255,9 @@ MIT in each case. |# (define (expand/remember new old) (code-rewrite/remember new old)) +(define (expand/remember* new old) + (code-rewrite/remember* new old)) + (define (expand/new-name prefix) (new-variable prefix)) diff --git a/v8/src/compiler/midend/utils.scm b/v8/src/compiler/midend/utils.scm index a1e50eeb1..45040e142 100644 --- a/v8/src/compiler/midend/utils.scm +++ b/v8/src/compiler/midend/utils.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: utils.scm,v 1.5 1994/11/26 17:43:21 adams Exp $ +$Id: utils.scm,v 1.6 1994/11/26 22:06:43 gjr Exp $ Copyright (c) 1994 Massachusetts Institute of Technology @@ -83,6 +83,7 @@ MIT in each case. |# (*unparse-string (substring name 1 (string-length name)))) ((new-variable->index symbol) => (lambda (index) + index ; ignored (*unparse-string name) ;;(*unparse-string kmp/pp-symbol-glue) ;;(*unparse-string (number->string index)) @@ -194,7 +195,8 @@ MIT in each case. |# `(BEGIN ,@actions*) (car actions*))) ((not (pair? (car actions))) - (internal-warning "BEGINNIFY: Non-pair form in BEGIN:" (car actions)) + (internal-warning "BEGINNIFY: Non-pair form in BEGIN:" + (car actions)) (loop (cdr actions) (cons (car actions) actions*))) ((eq? (caar actions) 'BEGIN) @@ -847,8 +849,7 @@ MIT in each case. |# set (loop (union (proc (car l)) set) (cdr l))))) - - + (define (remove-duplicates l) (let loop ((l l) (l* '())) (cond ((null? l) (reverse! l*)) @@ -861,7 +862,6 @@ MIT in each case. |# ((memq (car set1) set2) #F) (else (null-intersection? (cdr set1) set2)))) - (define (list-split ol predicate) ;; (values yes no) (let loop ((l (reverse ol)) @@ -897,6 +897,19 @@ MIT in each case. |# (internal-error "vector-index: component not found" vector name))))) +(define (pair-up oone otwo) + (let loop ((one oone) (two otwo) (result '())) + (cond ((and (not (null? one)) + (not (null? two))) + (loop (cdr one) + (cdr two) + (cons (cons (car one) (car two)) + result))) + ((or (null? one) + (null? two)) + (internal-error "pair-up: Mismatched lengths" oone otwo)) + (else + (reverse! result))))) (define-structure (queue (conc-name queue/) -- 2.25.1