From 07c0ec883ed82dc64abfe71691c28562605fa9c3 Mon Sep 17 00:00:00 2001 From: Stephen Adams Date: Thu, 27 Apr 1995 23:23:18 +0000 Subject: [PATCH] Converted to new dbg-info scheme. --- v8/src/compiler/midend/alpha.scm | 32 +++--- v8/src/compiler/midend/assconv.scm | 103 +++-------------- v8/src/compiler/midend/cleanup.scm | 79 +++++++------ v8/src/compiler/midend/closconv.scm | 168 ++++++++++------------------ v8/src/compiler/midend/midend.scm | 15 ++- v8/src/compiler/midend/simplify.scm | 106 +++++++++++------- 6 files changed, 208 insertions(+), 295 deletions(-) diff --git a/v8/src/compiler/midend/alpha.scm b/v8/src/compiler/midend/alpha.scm index 8159e5b28..1a9ca6030 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.6 1995/03/12 05:53:10 adams Exp $ +$Id: alpha.scm,v 1.7 1995/04/27 23:23:05 adams Exp $ Copyright (c) 1988-1994 Massachusetts Institute of Technology @@ -42,16 +42,16 @@ 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 - (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))))))) + (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) state env ; ignored @@ -81,12 +81,10 @@ MIT in each case. |# (and block (for-each (lambda (var) - (let ((expr (new-dbg-variable/expression var))) - (if (not (LOOKUP/? expr)) - (internal-error "expression not a LOOKUP" var)) - (set-car! (cdr expr) - (alphaconv/env/lookup (new-dbg-variable/name var) - env*)))) + (let ((new-name + (alphaconv/env/lookup (new-dbg-variable/name var) + env*))) + (dbg-info/remember var `(LOOKUP ,new-name)))) (new-dbg-block/variables block))))))) (define-alphaconv CALL (state env rator cont #!rest rands) diff --git a/v8/src/compiler/midend/assconv.scm b/v8/src/compiler/midend/assconv.scm index c69c016b1..cf47bb93e 100644 --- a/v8/src/compiler/midend/assconv.scm +++ b/v8/src/compiler/midend/assconv.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: assconv.scm,v 1.9 1995/04/24 16:06:45 adams Exp $ +$Id: assconv.scm,v 1.10 1995/04/27 23:22:39 adams Exp $ Copyright (c) 1994-1995 Massachusetts Institute of Technology @@ -41,51 +41,6 @@ MIT in each case. |# (fluid-let ((*assconv/effect-only-forms* (make-eq-hash-table))) (assconv/expr '() program))) -;;(define-macro (define-assignment-converter keyword bindings . body) -;; (let ((proc-name (symbol-append 'ASSCONV/ 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) -;; (assconv/remember ,code form)))))))) - -;;_____________________________________________________________________________ -;; -;; This version of assconv is an early attempt at getting a data -;; representation transformation into the debugging info. -;; -;; Comments: -;; -;; . Nothing special is done for LAMBDA & LET, so the environment used for -;; these forms is missing the new bindings. Does this matter? It -;; certainly would matter if assconv/get-dbg-info edited the blocks -;; to remove bindings that were unavailable, but this allows us to -;; distinguish the occurences: -;; -;; (lambda (n-17) [1] -;; (let ((n-17-cell (make-cell n-17 'n))) -;; [2]...[3]...)) -;; -;; At [1] the user variable N is the alpha renamed parameter N-17. -;; At [2] the user variable is available also as (CELL-REF N-17-CELL) -;; -;; If LAMBDA was done `right' something would have to distinguish these -;; two cases. -;; -;; . Note that there are two access paths for N, but we keep only one. -;; Let us assume also that at [3] the CELL-REF version is available. -;; How do we know which one to keep at [2]? Perhaps the right -;; thing is to generate all of the access paths and discard those -;; which use information which is not available. Discarding -;; infeasible access paths would leave just N-17 at [1], both at -;; [2] and the just (CELL-REF N-17-CELL) at [3]. -;; -;; The filtering might be done frequently to avoid a great many -;; descriptions, or rarely. - - (define-macro (define-assignment-converter keyword bindings . body) (let ((proc-name (symbol-append 'ASSCONV/ keyword))) (call-with-values @@ -94,11 +49,7 @@ MIT in each case. |# `(DEFINE ,proc-name (LET ((HANDLER (LAMBDA ,(cons (car bindings) names) ,@body))) (NAMED-LAMBDA (,proc-name ENV FORM) - (LET ((INFO (ASSCONV/GET-DBG-INFO ENV FORM))) - (LET ((CODE ,code)) - (IF INFO - (CODE-REWRITE/REMEMBER* CODE INFO)) - CODE))))))))) + (ASSCONV/REMEMBER ,code form)))))))) ;;;; Variable manipulation forms @@ -226,39 +177,6 @@ MIT in each case. |# (define (assconv/form/effect-only? form) (hash-table/get *assconv/effect-only-forms* form #F)) - - -(define (assconv/get-dbg-info env expr) - (cond ((code-rewrite/original-form/previous expr) - => (lambda (dbg-info) - (assconv/has-dbg-info env expr dbg-info))) - (else #F))) - -(define (assconv/has-dbg-info env expr dbg-info) - expr - ;; Copy the dbg info, keeping dbg-references in the environment which - ;; will later be ocerwritten - (let* ((block (new-dbg-form/block dbg-info)) - (block* (new-dbg-block/copy-transforming - (lambda (expr) - (assconv/copy-dbg-kmp expr env)) - block)) - (dbg-info* (new-dbg-form/new-block dbg-info block*))) - dbg-info*)) - -(define (assconv/copy-dbg-kmp expr env) - (form/copy-transforming - (lambda (form copy uninteresting) - copy - (cond ((and (LOOKUP/? form) (assconv/env-lookup env (lookup/name form))) - => (lambda (binding) - (let ((form* `(LOOKUP ,(lookup/name form)))) - (set-assconv/binding/dbg-references! - binding - (cons form* (assconv/binding/dbg-references binding))) - form*))) - (else (uninteresting form)))) - expr)) ;;;; Utilities for variable manipulation forms @@ -270,7 +188,8 @@ MIT in each case. |# (multicell-layout false read-only false) (references '() read-only false) (assignments '() read-only false) - (dbg-references '() read-only false)) + ;;(dbg-references '() read-only false) + ) (define (assconv/binding-body env names body) ;; (values shadowed-names body*) @@ -469,11 +388,15 @@ MIT in each case. |# ass (assconv/cell-assignment binding (set!/expr ass) ass))) (assconv/binding/assignments binding)) - (for-each (lambda (ref) - (form/rewrite! - ref - (assconv/cell-reference binding))) - (assconv/binding/dbg-references binding))) + ;;(for-each (lambda (ref) + ;; (form/rewrite! + ;; ref + ;; (assconv/cell-reference binding))) + ;; (assconv/binding/dbg-references binding)) + + (dbg-info/remember (assconv/binding/name binding) + (assconv/cell-reference binding)) + ) (define (assconv/env-lookup env name) (let spine-loop ((env env)) diff --git a/v8/src/compiler/midend/cleanup.scm b/v8/src/compiler/midend/cleanup.scm index 5708ad782..1af08f348 100644 --- a/v8/src/compiler/midend/cleanup.scm +++ b/v8/src/compiler/midend/cleanup.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: cleanup.scm,v 1.15 1995/04/20 03:23:02 adams Exp $ +$Id: cleanup.scm,v 1.16 1995/04/27 23:18:34 adams Exp $ Copyright (c) 1994-1995 Massachusetts Institute of Technology @@ -40,6 +40,21 @@ MIT in each case. |# (define (cleanup/top-level program) (cleanup/expr (cleanup/env/initial) program)) +;;(define-macro (define-cleanup-handler keyword bindings . body) +;; (let ((proc-name (symbol-append 'CLEANUP/ 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) +;; (LET ((TRANSFORM-CODE (LAMBDA () ,code))) +;; (LET ((INFO (CLEANUP/GET-DBG-INFO ENV FORM))) +;; (LET ((CODE (TRANSFORM-CODE))) +;; (IF INFO +;; (CODE-REWRITE/REMEMBER* CODE INFO)) +;; CODE)))))))))) + (define-macro (define-cleanup-handler keyword bindings . body) (let ((proc-name (symbol-append 'CLEANUP/ keyword))) (call-with-values @@ -48,12 +63,7 @@ MIT in each case. |# `(DEFINE ,proc-name (LET ((HANDLER (LAMBDA ,(cons (car bindings) names) ,@body))) (NAMED-LAMBDA (,proc-name ENV FORM) - (LET ((TRANSFORM-CODE (LAMBDA () ,code))) - (LET ((INFO (CLEANUP/GET-DBG-INFO ENV FORM))) - (LET ((CODE (TRANSFORM-CODE))) - (IF INFO - (CODE-REWRITE/REMEMBER* CODE INFO)) - CODE)))))))))) + (CLEANUP/REMEMBER ,code FORM)))))))) (define-cleanup-handler LOOKUP (env name) (let ((value (cleanup/env/lookup name env))) @@ -595,7 +605,10 @@ MIT in each case. |# (if (or (not value) (QUOTE/? value)) (cleanup/binding/make name `(LOOKUP ,name)) - (cleanup/binding/make name `(LOOKUP ,(variable/rename name)))))) + (let ((renamed-form + `(LOOKUP ,(variable/rename name)))) + (dbg-info/remember name renamed-form) + (cleanup/binding/make name renamed-form))))) names)) ;; Environment is a list of frames. Frames are a list of bindings. @@ -654,28 +667,28 @@ MIT in each case. |# (define (cleanup/remember new old) (code-rewrite/remember new old)) -(define (cleanup/get-dbg-info env expr) - (cond ((code-rewrite/original-form/previous expr) - => (lambda (dbg-info) - ;; Copy the dbg info, rewriting the expressions - (let* ((block (new-dbg-form/block dbg-info)) - (block* (new-dbg-block/copy-transforming - (lambda (expr) - (cleanup/copy-dbg-kmp expr env)) - block)) - (dbg-info* (new-dbg-form/new-block dbg-info block*))) - dbg-info*))) - (else #F))) - - -(define (cleanup/copy-dbg-kmp expr env) - (form/copy-transforming - (lambda (form copy uninteresting) - copy - (cond ((and (LOOKUP/? form) - (cleanup/env/lookup (lookup/name form) env)) - => (lambda (value) - (form/copy value))) - (else - (uninteresting form)))) - expr)) +;;(define (cleanup/get-dbg-info env expr) +;; (cond ((code-rewrite/original-form/previous expr) +;; => (lambda (dbg-info) +;; ;; Copy the dbg info, rewriting the expressions +;; (let* ((block (new-dbg-form/block dbg-info)) +;; (block* (new-dbg-block/copy-transforming +;; (lambda (expr) +;; (cleanup/copy-dbg-kmp expr env)) +;; block)) +;; (dbg-info* (new-dbg-form/new-block dbg-info block*))) +;; dbg-info*))) +;; (else #F))) +;; +;; +;;(define (cleanup/copy-dbg-kmp expr env) +;; (form/copy-transforming +;; (lambda (form copy uninteresting) +;; copy +;; (cond ((and (LOOKUP/? form) +;; (cleanup/env/lookup (lookup/name form) env)) +;; => (lambda (value) +;; (form/copy value))) +;; (else +;; (uninteresting form)))) +;; expr)) diff --git a/v8/src/compiler/midend/closconv.scm b/v8/src/compiler/midend/closconv.scm index 2a9485e09..b5365cbdd 100644 --- a/v8/src/compiler/midend/closconv.scm +++ b/v8/src/compiler/midend/closconv.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: closconv.scm,v 1.5 1995/04/17 03:55:03 adams Exp $ +$Id: closconv.scm,v 1.6 1995/04/27 23:20:22 adams Exp $ Copyright (c) 1994 Massachusetts Institute of Technology @@ -48,30 +48,16 @@ MIT in each case. |# (program* (closconv/expr env (lifter/letrecify program)))) (closconv/analyze! env program*))))) -;;(define-macro (define-closure-converter keyword bindings . body) -;; (let ((proc-name (symbol-append 'CLOSCONV/ 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) -;; (CLOSCONV/REMEMBER ,code -;; FORM)))))))) - (define-macro (define-closure-converter keyword bindings . body) (let ((proc-name (symbol-append 'CLOSCONV/ 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) - (LET ((INFO (CLOSCONV/GET-DBG-INFO ENV FORM))) - (LET ((CODE ,code)) - (IF INFO - (CODE-REWRITE/REMEMBER* CODE INFO)) - CODE))))))))) + (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) + (CLOSCONV/REMEMBER ,code + FORM)))))))) (define-closure-converter LOOKUP (env name) @@ -90,7 +76,7 @@ MIT in each case. |# (closconv/env/context env) bindings) env - (lmap car bindings))) + (map car bindings))) (expr* `(LET ,(closconv/bindings env* env bindings) ,(closconv/expr env* body)))) (set-closconv/env/form! env* expr*) @@ -102,7 +88,7 @@ MIT in each case. |# (closconv/env/context env) bindings) env - (lmap car bindings))) + (map car bindings))) (expr* `(LETREC ,(closconv/bindings env* env* bindings) ,(closconv/expr env* body)))) (set-closconv/env/form! env* expr*) @@ -137,7 +123,7 @@ MIT in each case. |# (lambda (rator* env*) (let ((bindings* (closconv/bindings env* env bindings))) `(CALL ,(closconv/remember rator* rator) - ,@(lmap cadr bindings*)))))))) + ,@(map cadr bindings*)))))))) (else (default))))) @@ -164,34 +150,21 @@ MIT in each case. |# (if (not (pair? expr)) (illegal expr)) (case (car expr) - ((QUOTE) - (closconv/quote env expr)) - ((LOOKUP) - (closconv/lookup env expr)) - ((LAMBDA) - (closconv/lambda env expr)) - ((LET) - (closconv/let env expr)) - ((DECLARE) - (closconv/declare env expr)) - ((CALL) - (closconv/call env expr)) - ((BEGIN) - (closconv/begin env expr)) - ((IF) - (closconv/if env expr)) - ((LETREC) - (closconv/letrec env expr)) - ((SET! UNASSIGNED? OR DELAY - ACCESS DEFINE IN-PACKAGE THE-ENVIRONMENT) - (no-longer-legal expr)) - (else - (illegal expr)))) + ((QUOTE) (closconv/quote env expr)) + ((LOOKUP) (closconv/lookup env expr)) + ((LAMBDA) (closconv/lambda env expr)) + ((LET) (closconv/let env expr)) + ((DECLARE) (closconv/declare env expr)) + ((CALL) (closconv/call env expr)) + ((BEGIN) (closconv/begin env expr)) + ((IF) (closconv/if env expr)) + ((LETREC) (closconv/letrec env expr)) + (else (illegal expr)))) (define (closconv/expr* env exprs) - (lmap (lambda (expr) - (closconv/expr env expr)) - exprs)) + (map (lambda (expr) + (closconv/expr env expr)) + exprs)) (define (closconv/remember new old) (code-rewrite/remember new old)) @@ -207,29 +180,6 @@ MIT in each case. |# (define (closconv/new-name prefix) (new-variable prefix)) -(define (closconv/get-dbg-info env expr) - (cond ((code-rewrite/original-form/previous expr) - => (lambda (dbg-info) - ;; Copy the dbg info, keeping dbg-references in the - ;; environment which will later be overwritten - (let* ((block (new-dbg-form/block dbg-info)) - (block* (new-dbg-block/copy-transforming - (lambda (expr) - (closconv/copy-dbg-kmp expr env)) - block)) - (dbg-info* (new-dbg-form/new-block dbg-info block*))) - dbg-info*))) - (else #F))) - -(define (closconv/copy-dbg-kmp expr env) - (form/copy-transforming - (lambda (form copy uninteresting) - copy - (or (and (LOOKUP/? form) - (closconv/lookup*/dbg env (lookup/name form))) - (uninteresting form))) - expr)) - ;;;; Parameterization for invocation before and after cps conversion ;; Before CPS @@ -383,9 +333,9 @@ MIT in each case. |# (let ((env (closconv/env/%make context parent))) (set-closconv/env/bound! env - (lmap (lambda (name) - (closconv/binding/make name env)) - bound-names)) + (map (lambda (name) + (closconv/binding/make name env)) + bound-names)) (set-closconv/env/children! parent (cons env (closconv/env/children parent))) env)) @@ -474,7 +424,7 @@ MIT in each case. |# ;; ENV is the environment in which the form part of the binding is ;; to be evaluated (i.e. it will be EQ? to ENV* for LETREC but ;; not for LET) - (lmap (lambda (binding) + (map (lambda (binding) (let ((name (car binding)) (value (cadr binding))) (list @@ -607,15 +557,15 @@ MIT in each case. |# (else closed-over*))) (closed-over-names - (list->vector (lmap (lambda (binding.refs) - (closconv/binding/name (car binding.refs))) - closed-over))) + (list->vector (map (lambda (binding.refs) + (closconv/binding/name (car binding.refs))) + closed-over))) (captured - (lmap (lambda (binding.refs) - (if (memq (car binding.refs) circular) - `(QUOTE ,#f) - (form/preserve (cadr binding.refs)))) - closed-over)) + (map (lambda (binding.refs) + (if (memq (car binding.refs) circular) + `(QUOTE ,#f) + (form/preserve (cadr binding.refs)))) + closed-over)) (form (closconv/env/form env))) ;; Rewrite references to closed variables and self @@ -624,30 +574,34 @@ MIT in each case. |# (let* ((binding (car free-ref)) (name (closconv/binding/name binding)) (references (cdr free-ref)) - (references-and-dbg-references - (cond ((assq binding (closconv/env/dbg-free env)) - => (lambda (dbg-ref) - (append references (cdr dbg-ref)))) - (else references)))) - + ;;(references-and-dbg-references + ;; (cond ((assq binding (closconv/env/dbg-free env)) + ;; => (lambda (dbg-ref) + ;; (append references (cdr dbg-ref)))) + ;; (else references))) + ) + + (define (reference-expression) + `(CALL (QUOTE ,%closure-ref) + (QUOTE #F) + (LOOKUP ,closure-name) + (CALL (QUOTE ,%vector-index) + (QUOTE #F) + (QUOTE ,closed-over-names) + (QUOTE ,name)) + (QUOTE ,name))) (define (rewrite-self-reference! ref) (form/rewrite! ref `(LOOKUP ,closure-name))) (define (rewrite-other-reference! ref) - (form/rewrite! ref - `(CALL (QUOTE ,%closure-ref) - (QUOTE #F) - (LOOKUP ,closure-name) - (CALL (QUOTE ,%vector-index) - (QUOTE #F) - (QUOTE ,closed-over-names) - (QUOTE ,name)) - (QUOTE ,name)))) + (form/rewrite! ref (reference-expression))) + + (dbg-info/remember name (reference-expression)) (for-each (if (eq? (car free-ref) self-binding) rewrite-self-reference! rewrite-other-reference!) - references-and-dbg-references))) + references))) closed-over*) ;; Convert to closure and maybe lift to top level @@ -707,9 +661,9 @@ MIT in each case. |# (closconv/remember*! ref val-form))) (closconv/binding/ordinary-refs binding)))) trivial) - (let* ((envs (lmap closconv/binding/value closed)) + (let* ((envs (map closconv/binding/value closed)) (circular - (lmap + (map (lambda (env) (let ((closed-over (closconv/env/closed-over env))) (list-transform-positive closed @@ -721,15 +675,15 @@ MIT in each case. |# (form/rewrite! form - (bind* (lmap closconv/binding/name closed) - (lmap closconv/env/form envs) + (bind* (map closconv/binding/name closed) + (map closconv/env/form envs) (beginnify (append-map* (list (let ((ok (delq* closed (closconv/env/bound env)))) (if (null? ok) (caddr form) - (let ((ok-names (lmap closconv/binding/name ok))) + (let ((ok-names (map closconv/binding/name ok))) `(LETREC ,(list-transform-positive (cadr form) (lambda (binding) (memq (car binding) ok-names))) diff --git a/v8/src/compiler/midend/midend.scm b/v8/src/compiler/midend/midend.scm index 550c34464..4895243d5 100644 --- a/v8/src/compiler/midend/midend.scm +++ b/v8/src/compiler/midend/midend.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: midend.scm,v 1.10 1995/03/13 23:23:16 adams Exp $ +$Id: midend.scm,v 1.11 1995/04/27 23:23:18 adams Exp $ Copyright (c) 1994 Massachusetts Institute of Technology @@ -124,7 +124,7 @@ MIT in each case. |# (show-program "Output from phase " result)))) result))))) (phase/post-hook program result) - (gather-phase-statistics program result) + ;;(gather-phase-statistics program result) result))))) (define (phase-wrapper rewrite) @@ -208,13 +208,16 @@ Example: assconv/top-level ; eliminate SET! and introduce LETREC ; rewriting LOOKUP and SET! cleanup/top-level/1 ; as below - ;;coerce/top-level - ;;simplify/top-level - ;;cleanup/top-level/1.5 + coerce/top-level earlyrew/top-level ; rewrite -1+ into -, etc. + + ;;!frag/top-level lamlift/top-level/1 ; flatten environment structure ; splitting lambda nodes if necessary + ;;!cleanup/top-level/1.5 + ;;!arity/top-level + closconv/top-level/1 ; introduce %make-heap-closure ; and %heap-closure-ref ; after this pass there are no @@ -284,6 +287,8 @@ Example: (copy-variable-properties))) (*after-cps-conversion?* false) (*previous-code-rewrite-table* false) + (*dbg-rewrites* + (if (not recursive?) (dbg-info/make-rewrites) *dbg-rewrites*)) (*code-rewrite-table* (if (not recursive?) (code/rewrite-table/make) diff --git a/v8/src/compiler/midend/simplify.scm b/v8/src/compiler/midend/simplify.scm index 205323f23..f9cdceafb 100644 --- a/v8/src/compiler/midend/simplify.scm +++ b/v8/src/compiler/midend/simplify.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: simplify.scm,v 1.10 1995/04/09 04:45:59 adams Exp $ +$Id: simplify.scm,v 1.11 1995/04/27 23:18:52 adams Exp $ Copyright (c) 1994 Massachusetts Institute of Technology @@ -40,6 +40,21 @@ MIT in each case. |# (define (simplify/top-level program) (simplify/expr #F program)) +;;(define-macro (define-simplifier keyword bindings . body) +;; (let ((proc-name (symbol-append 'SIMPLIFY/ 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) +;; (LET ((TRANSFORM-CODE (LAMBDA () ,code))) +;; (LET ((INFO (SIMPLIFY/GET-DBG-INFO ENV FORM))) +;; (LET ((CODE (TRANSFORM-CODE))) +;; (IF INFO +;; (CODE-REWRITE/REMEMBER* CODE INFO)) +;; CODE)))))))))) + (define-macro (define-simplifier keyword bindings . body) (let ((proc-name (symbol-append 'SIMPLIFY/ keyword))) (call-with-values @@ -48,12 +63,7 @@ MIT in each case. |# `(DEFINE ,proc-name (LET ((HANDLER (LAMBDA ,(cons (car bindings) names) ,@body))) (NAMED-LAMBDA (,proc-name ENV FORM) - (LET ((TRANSFORM-CODE (LAMBDA () ,code))) - (LET ((INFO (SIMPLIFY/GET-DBG-INFO ENV FORM))) - (LET ((CODE (TRANSFORM-CODE))) - (IF INFO - (CODE-REWRITE/REMEMBER* CODE INFO)) - CODE)))))))))) + (SIMPLIFY/REMEMBER ,code FORM)))))))) (define-simplifier LOOKUP (env name) (let ((ref `(LOOKUP ,name))) @@ -388,7 +398,15 @@ MIT in each case. |# (for-each (lambda (ref) (form/rewrite! ref `(CALL ,(copy-value ref) ,@(cddr ref)))) - operator-refs))) + operator-refs) + + ;; For DBG info + (cond ((and (null? ordinary-refs) (LAMBDA/? value)) + 'ignore) ; probably a huge procedure body + (else + (dbg-info/remember (simplify/binding/name node) + value))) + )) (define (simplify/copy-form/renaming env form) ;; Copy FORM, renaming local bindings and keeping references to free @@ -397,7 +415,9 @@ MIT in each case. |# (define (rename name) (if (memq name '(#!aux #!rest #!optional)) name - (variable/rename name))) + (let ((new-name (variable/rename name))) + (dbg-info/remember name new-name) + new-name))) (define (walk renames form) (define (extend old new) (map* renames cons old new)) (define (reference name wrap kind) @@ -427,6 +447,14 @@ MIT in each case. |# (new (map rename old))) `(LAMBDA ,new ,(walk (extend old new) (lambda/body form))))) + ((CALL/? form) + (if (LOOKUP/? (call/operator form)) + (let ((name (lookup/name (call/operator form)))) + (define (call name) + `(CALL (LOOKUP ,name) + ,@(walk* (call/cont-and-operands form)))) + (reference name call 'OPERATOR)) + `(CALL ,@(walk* (cdr form))))) ((LET/? form) (let/letrec 'LET)) ((LETREC/? form) @@ -436,14 +464,6 @@ MIT in each case. |# ((BEGIN/? form) `(BEGIN ,@(walk* (cdr form)))) ((DECLARE/? form) `(DECLARE ,@(cdr form))) - ((CALL/? form) - (if (LOOKUP/? (call/operator form)) - (let ((name (lookup/name (call/operator form)))) - (define (call name) - `(CALL (LOOKUP ,name) - ,@(walk* (call/cont-and-operands form)))) - (reference name call 'OPERATOR)) - `(CALL ,@(walk* (cdr form))))) (else (internal-error "Unexpected syntax" form)))) @@ -527,32 +547,32 @@ MIT in each case. |# -(define (simplify/get-dbg-info env expr) - (cond ((code-rewrite/original-form/previous expr) - => (lambda (dbg-info) - ;; Copy the dbg info, keeping dbg-info-refs in the environment - ;; which may later be overwritten - (let* ((block (new-dbg-form/block dbg-info)) - (block* (new-dbg-block/copy-transforming - (lambda (expr) - (simplify/copy-dbg-kmp expr env)) - block)) - (dbg-info* (new-dbg-form/new-block dbg-info block*))) - dbg-info*))) - (else #F))) - - -(define (simplify/copy-dbg-kmp expr env) - (form/copy-transforming - (lambda (form copy uninteresting) - copy - (cond ((and (LOOKUP/? form) - (simplify/lookup*! env (lookup/name form) - `(LOOKUP ,(lookup/name form)) - 'DBG-INFO)) - => (lambda (reference) reference)) - (else (uninteresting form)))) - expr)) +;;(define (simplify/get-dbg-info env expr) +;; (cond ((code-rewrite/original-form/previous expr) +;; => (lambda (dbg-info) +;; ;; Copy the dbg info, keeping dbg-info-refs in the environment +;; ;; which may later be overwritten +;; (let* ((block (new-dbg-form/block dbg-info)) +;; (block* (new-dbg-block/copy-transforming +;; (lambda (expr) +;; (simplify/copy-dbg-kmp expr env)) +;; block)) +;; (dbg-info* (new-dbg-form/new-block dbg-info block*))) +;; dbg-info*))) +;; (else #F))) +;; +;; +;;(define (simplify/copy-dbg-kmp expr env) +;; (form/copy-transforming +;; (lambda (form copy uninteresting) +;; copy +;; (cond ((and (LOOKUP/? form) +;; (simplify/lookup*! env (lookup/name form) +;; `(LOOKUP ,(lookup/name form)) +;; 'DBG-INFO)) +;; => (lambda (reference) reference)) +;; (else (uninteresting form)))) +;; expr)) (define-structure (simplify/binding -- 2.25.1