#| -*-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
(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
(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)
#| -*-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
(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
`(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
(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))
\f
;;;; Utilities for variable manipulation forms
(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*)
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))
+ )
\f
(define (assconv/env-lookup env name)
(let spine-loop ((env env))
#| -*-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
(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
`(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)))
(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.
(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))
#| -*-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
(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)
(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*)
(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*)
(lambda (rator* env*)
(let ((bindings* (closconv/bindings env* env bindings)))
`(CALL ,(closconv/remember rator* rator)
- ,@(lmap cadr bindings*))))))))
+ ,@(map cadr bindings*))))))))
(else
(default)))))
(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))
(define (closconv/new-name prefix)
(new-variable prefix))
\f
-(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))
-\f
;;;; Parameterization for invocation before and after cps conversion
;; Before CPS
(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))
;; 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
(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
(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
(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
(form/rewrite!
form
\f
- (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)))
#| -*-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
(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)
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
(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)
#| -*-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
(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
`(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)))
(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)))
+ ))
\f
(define (simplify/copy-form/renaming env form)
;; Copy FORM, renaming local bindings and keeping references to free
(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)
(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)
((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))))
-(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))
\f
(define-structure
(simplify/binding
projects / mit-scheme.git / commitdiff