From: Guillermo J. Rozas Date: Tue, 6 Dec 1988 18:58:19 +0000 (+0000) Subject: Rewrite constant folding and closure analysis phases. X-Git-Tag: 20090517-FFI~12396 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=2ed0bc7166b7aebb440c62087300289a3402bd2d;p=mit-scheme.git Rewrite constant folding and closure analysis phases. Write two new phases: compute-call-graph and side-effect-analysis. --- diff --git a/v7/src/compiler/base/ctypes.scm b/v7/src/compiler/base/ctypes.scm index 7b5380db7..3dcb421f1 100644 --- a/v7/src/compiler/base/ctypes.scm +++ b/v7/src/compiler/base/ctypes.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/ctypes.scm,v 4.6 1988/11/01 04:46:49 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/ctypes.scm,v 4.7 1988/12/06 18:51:59 jinx Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -45,10 +45,11 @@ MIT in each case. |# operands (parallel-node owner) (operators ;used in simulate-application - arguments) ;used in outer-analysis + args-passed-out?) ;used in outer-analysis operand-values ;set by outer-analysis, used by identify-closure-limits continuation-push model ;set by identify-closure-limits, used in generation + destination-block ;used by identify-closure-limits to quench propagation ) (define *applications*) @@ -57,7 +58,7 @@ MIT in each case. |# (let ((application (make-snode application-tag type block operator operands false '() '() - continuation-push false))) + continuation-push false true))) (set! *applications* (cons application *applications*)) (add-block-application! block application) (if (rvalue/reference? operator) @@ -109,8 +110,8 @@ MIT in each case. |# (define-integrable combination/block application-block) (define-integrable combination/operator application-operator) -(define-integrable combination/inliner application-arguments) -(define-integrable set-combination/inliner! set-application-arguments!) +(define-integrable combination/inliner application-operators) +(define-integrable set-combination/inliner! set-application-operators!) (define-integrable combination/frame-size application-operand-values) (define-integrable set-combination/frame-size! set-application-operand-values!) (define-integrable combination/inline? combination/inliner) @@ -162,13 +163,13 @@ MIT in each case. |# lvalue rvalue) -(define *assignments*) +;; (define *assignments*) (define (make-assignment block lvalue rvalue) (lvalue-connect! lvalue rvalue) - (variable-assigned! lvalue) (let ((assignment (make-snode assignment-tag block lvalue rvalue))) - (set! *assignments* (cons assignment *assignments*)) + ;; (set! *assignments* (cons assignment *assignments*)) + (variable-assigned! lvalue assignment) (snode->scfg assignment))) (define-integrable (node/assignment? node) diff --git a/v7/src/compiler/base/lvalue.scm b/v7/src/compiler/base/lvalue.scm index 1942934f4..df9520ef6 100644 --- a/v7/src/compiler/base/lvalue.scm +++ b/v7/src/compiler/base/lvalue.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/lvalue.scm,v 4.8 1988/11/15 16:33:41 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/lvalue.scm,v 4.9 1988/12/06 18:52:19 jinx Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -75,18 +75,19 @@ MIT in each case. |# (define-lvalue variable block ;block in which variable is defined name ;name of variable [symbol] - assigned? ;true iff variable appears in an assignment + assignments ;true iff variable appears in an assignment in-cell? ;true iff variable requires cell at runtime (normal-offset ;offset of variable within `block' popping-limit) ;popping-limit for continuation variables declarations ;list of declarations for this variable + closed-over? ;true iff a closure references it freely. ) (define continuation-variable/type variable-in-cell?) (define set-continuation-variable/type! set-variable-in-cell?!) (define (make-variable block name) - (make-lvalue variable-tag block name false false false '())) + (make-lvalue variable-tag block name '() false false '() false)) (define variable-assoc (association-procedure eq? variable-name)) @@ -183,19 +184,17 @@ MIT in each case. |# (define-integrable (lvalue-mark-set? lvalue mark) (memq mark (lvalue-marks lvalue))) -#| + (define-integrable (variable-auxiliary! variable) (set-variable-auxiliary?! variable true)) -(define (variable-assigned! variable) - (set-variable-assignments! variable (1+ (variable-assignments variable)))) +(define (variable-assigned! variable assignment) + (set-variable-assignments! + variable + (cons assignment (variable-assignments variable)))) (define (variable-assigned? variable) - (> (variable-assignments variable) - (if (variable-auxiliary? variable) 1 0))) -|# -(define-integrable (variable-assigned! variable) - (set-variable-assigned?! variable true)) + (not (null? (variable-assignments variable)))) ;; Note: ;; If integration of known block values (first class environments) is diff --git a/v7/src/compiler/base/object.scm b/v7/src/compiler/base/object.scm index 41656378d..9c756348d 100644 --- a/v7/src/compiler/base/object.scm +++ b/v7/src/compiler/base/object.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/object.scm,v 4.3 1988/07/20 00:09:16 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/object.scm,v 4.4 1988/12/06 18:52:56 jinx Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -134,7 +134,7 @@ MIT in each case. |# (not (zero? (vector-length object))) (let loop ((tag* (tagged-vector/tag object))) (or (eq? tag tag*) - (and (pair? tag*) + (and (vector-tag? tag*) (loop (vector-tag-parent tag*)))))))) (define (tagged-vector/description object) diff --git a/v7/src/compiler/base/proced.scm b/v7/src/compiler/base/proced.scm index 0a190fdb3..5b8e1b866 100644 --- a/v7/src/compiler/base/proced.scm +++ b/v7/src/compiler/base/proced.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/proced.scm,v 4.6 1988/11/01 04:48:30 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/proced.scm,v 4.7 1988/12/06 18:53:20 jinx Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -57,15 +57,22 @@ MIT in each case. |# closure-offset ;for closure, offset of procedure in stack frame register ;for continuation, argument register closure-size ;for closure, virtual size of frame [integer or false] - target-block ;where procedure is "really" closed [block] - free-callees ;procedures invoked by means of free variables - free-callers ;procedures that invoke me by means of free variables + (target-block ;where procedure is "really" closed [block] + initial-callees) ;procs. invoked by me directly + (free-callees ;procs. invoked by means of free variables (1) + callees) ;procs. invoked by me (transitively) + (free-callers ;procs. that invoke me by means of free variables (1) + callers) ;procs. that invoke me (transitively) virtual-closure? ;need entry point but no environment? [boolean] closure-reasons ;reasons why a procedure is closed. - side-effects ;classes of side-effects performed by this procedure - trivial? ;true if body is trivial and should open code [boolean] + (variables ;variables which may be bound to this procedure (1) + side-effects) ;classes of side-effects performed by this procedure + properties ;random bits of information [assq list] ) +;; (1) The first meaning is used during closure analysis. +;; The second meaning is used during side-effect analysis. + (define *procedures*) (define (make-procedure type block name required optional rest names values @@ -154,8 +161,14 @@ MIT in each case. |# (define-integrable (procedure-application-unique? procedure) (null? (cdr (procedure-applications procedure)))) +(define-integrable (procedure/simplified? procedure) + (assq 'SIMPLIFIED (procedure-properties procedure))) + +(define-integrable (procedure/trivial? procedure) + (assq 'TRIVIAL (procedure-properties procedure))) + (define (procedure-inline-code? procedure) - (or (procedure-trivial? procedure) + (or (procedure/trivial? procedure) (and (procedure-always-known-operator? procedure) (procedure-application-unique? procedure) (procedure/virtually-open? procedure)))) diff --git a/v7/src/compiler/base/switch.scm b/v7/src/compiler/base/switch.scm index 555e5dd82..05d9613a6 100644 --- a/v7/src/compiler/base/switch.scm +++ b/v7/src/compiler/base/switch.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/switch.scm,v 4.9 1988/11/02 21:52:31 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/switch.scm,v 4.10 1988/12/06 18:53:47 jinx Rel $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -46,6 +46,7 @@ MIT in each case. |# (define compiler:cache-free-variables? true) (define compiler:implicit-self-static? false) (define compiler:optimize-environments? true) +(define compiler:analyze-side-effects? true) (define compiler:cse? true) (define compiler:open-code-primitives? true) (define compiler:generate-rtl-files? false) diff --git a/v7/src/compiler/base/toplev.scm b/v7/src/compiler/base/toplev.scm index 7b56170c0..d389022b7 100644 --- a/v7/src/compiler/base/toplev.scm +++ b/v7/src/compiler/base/toplev.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/toplev.scm,v 4.11 1988/11/01 04:49:15 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/toplev.scm,v 4.12 1988/12/06 18:54:04 jinx Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -87,7 +87,7 @@ MIT in each case. |# (set! *lvalues*) (set! *applications*) (set! *parallels*) - (set! *assignments*) + ;; (set! *assignments*) (set! *ic-procedure-headers*) (set! *root-expression*) (set! *root-block*) @@ -117,7 +117,7 @@ MIT in each case. |# (*lvalues*) (*applications*) (*parallels*) - (*assignments*) + ;; (*assignments*) (*ic-procedure-headers*) (*root-expression*) (*root-block*)) @@ -406,7 +406,7 @@ MIT in each case. |# (set! *lvalues* '()) (set! *applications* '()) (set! *parallels* '()) - (set! *assignments* '()) + ;; (set! *assignments* '()) (set! *root-expression* (construct-graph (last-reference *scode*))) (set! *root-block* (expression-block *root-expression*)) (if (or (null? *expressions*) @@ -424,7 +424,9 @@ MIT in each case. |# (phase/operator-analysis) (phase/environment-optimization) (phase/identify-closure-limits) - (phase/setup-block-types) (phase/continuation-analysis) + (phase/setup-block-types) (phase/compute-call-graph) + (phase/side-effect-analysis) + (phase/continuation-analysis) (phase/simplicity-analysis) (phase/subproblem-ordering) (phase/connectivity-analysis) @@ -458,30 +460,42 @@ MIT in each case. |# (operator-analysis *procedures* *applications*)))) (define (phase/environment-optimization) - (compiler-subphase "Environment optimization" + (compiler-subphase "Environment Optimization" (lambda () (optimize-environments! *procedures*)))) (define (phase/identify-closure-limits) (compiler-subphase "Closure Limit Identification" (lambda () - (identify-closure-limits! *procedures* *applications* *assignments*)))) + (identify-closure-limits! *procedures* *applications* *lvalues*)))) (define (phase/setup-block-types) (compiler-subphase "Block Type Determination" (lambda () (setup-block-types! *root-block*)))) +(define (phase/compute-call-graph) + (compiler-subphase + "Call Graph Computation" + (lambda () + (compute-call-graph! *procedures*)))) + +(define (phase/side-effect-analysis) + (compiler-subphase + "Side Effect Analysis" + (lambda () + (side-effect-analysis *procedures* *applications*)))) + (define (phase/continuation-analysis) (compiler-subphase "Continuation Analysis" (lambda () (continuation-analysis *blocks*)))) - + (define (phase/simplicity-analysis) (compiler-subphase "Simplicity Analysis" (lambda () (simplicity-analysis *parallels*)))) - + (define (phase/subproblem-ordering) (compiler-subphase "Subproblem Ordering" (lambda () @@ -506,13 +520,14 @@ MIT in each case. |# (compiler-subphase "Flow Graph Optimization Cleanup" (lambda () (if (not compiler:preserve-data-structures?) - (begin (set! *constants*) + (begin (clear-call-graph! *procedures*) + (set! *constants*) (set! *blocks*) (set! *procedures*) (set! *lvalues*) (set! *applications*) (set! *parallels*) - (set! *assignments*) + ;; (set! *assignments*) (set! *root-block*)))))) (define (phase/rtl-generation) diff --git a/v7/src/compiler/base/utils.scm b/v7/src/compiler/base/utils.scm index 4750efca6..9969a7ece 100644 --- a/v7/src/compiler/base/utils.scm +++ b/v7/src/compiler/base/utils.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/utils.scm,v 4.7 1988/11/15 16:33:19 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/utils.scm,v 4.8 1988/12/06 18:54:25 jinx Exp $ Copyright (c) 1987, 1988 Massachusetts Institute of Technology @@ -254,11 +254,11 @@ MIT in each case. |# (symbol? object) (scode/primitive-procedure? object) (eq? object compiled-error-procedure))) - -(define invariant-names + +(define function-names '( ;; Predicates - OBJECT-TYPE? EQ? FALSE? NULL? PAIR? VECTOR? SYMBOL? STRING? + OBJECT-TYPE? EQ? FALSE? NULL? PAIR? VECTOR? SYMBOL? STRING? NUMBER? CHAR? PROMISE? BIT-STRING? CELL? CHAR-ASCII? ;; Numbers @@ -276,37 +276,76 @@ MIT in each case. |# OBJECT-TYPE NOT ASCII->CHAR CHAR->INTEGER CHAR-BITS CHAR-CODE CHAR-DOWNCASE CHAR-UPCASE INTEGER->CHAR VECTOR-LENGTH MAKE-CHAR PRIMITIVE-PROCEDURE-ARITY STRING-MAXIMUM-LENGTH + )) - ;; If we could guarantee no side effects - #| APPLY CONS LIST CONS* MAKE-STRING VECTOR MAKE-VECTOR LIST-COPY VECTOR-COPY +;; The following definition is used to avoid computation if possible. +;; Not to avoid recomputation. To avoid recomputation, function-names +;; should be used. +;; +;; Example: CONS has no side effects, yet it is not a function. +;; Thus if the result of a CONS is not going to be used, we can avoid the +;; CONS operation, yet we can't reuse its result even when given the same +;; arguments again because the two pairs should not be EQ?. + +(define side-effect-free-additional-names + `( + ;; Constructors + CONS LIST CONS* MAKE-STRING VECTOR MAKE-VECTOR LIST-COPY VECTOR-COPY CAR CDR VECTOR-REF STRING-REF BIT-STRING-REF LENGTH LIST->VECTOR VECTOR->LIST MAKE-BIT-STRING MAKE-CELL STRING->SYMBOL STRING-LENGTH - |# )) + +(define additional-function-primitives + (list + (ucode-primitive &+) (ucode-primitive &-) + (ucode-primitive &*) (ucode-primitive &/) + (ucode-primitive &<) (ucode-primitive &>) + (ucode-primitive &=) (ucode-primitive &atan))) -;;;; Constant "Foldable" operators +;;;; "Foldable" and side-effect-free operators -(define (constant-foldable-primitive? operator) - (memq operator constant-foldable-primitives)) +(define function-variables + (map (lambda (name) + (cons name + (lexical-reference system-global-environment name))) + function-names)) + +(define-integrable (constant-foldable-variable? name) + (assq name function-variables)) + +(define side-effect-free-variables + (map* function-variables + (lambda (name) + (cons name + (lexical-reference system-global-environment name))) + side-effect-free-additional-names)) + +(define-integrable (side-effect-free-variable? name) + (assq name side-effect-free-variables)) (define (variable-usual-definition name) - (let ((place (assq name invariant-variables))) + (let ((place (assq name side-effect-free-variables))) (and place (cdr place)))) -(define invariant-variables - (map (lambda (name) - (cons name - (lexical-reference system-global-environment name))) - invariant-names)) +(define function-primitives + (append! + (list-transform-positive + (map cdr function-variables) + (lexical-reference system-global-environment 'PRIMITIVE-PROCEDURE?)) + additional-function-primitives)) -(define constant-foldable-primitives +(define (constant-foldable-primitive? operator) + (memq operator function-primitives)) + +(define side-effect-free-primitives (append! (list-transform-positive - (map cdr invariant-variables) + (map cdr side-effect-free-variables) (lexical-reference system-global-environment 'PRIMITIVE-PROCEDURE?)) - (list - (ucode-primitive &+) (ucode-primitive &-) - (ucode-primitive &*) (ucode-primitive &/) - (ucode-primitive &<) (ucode-primitive &>) - (ucode-primitive &=) (ucode-primitive &atan)))) \ No newline at end of file + additional-function-primitives)) + +(define (side-effect-free-primitive? operator) (memq operator side-effect-free-primitives)) + +(define procedure-object? + (lexical-reference system-global-environment 'PROCEDURE?)) \ No newline at end of file diff --git a/v7/src/compiler/fggen/declar.scm b/v7/src/compiler/fggen/declar.scm index a3729e28c..e4723053d 100644 --- a/v7/src/compiler/fggen/declar.scm +++ b/v7/src/compiler/fggen/declar.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fggen/declar.scm,v 1.4 1988/11/15 16:34:06 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fggen/declar.scm,v 1.5 1988/12/06 18:55:33 jinx Rel $ Copyright (c) 1987, 1988 Massachusetts Institute of Technology @@ -140,4 +140,6 @@ MIT in each case. |# (define-declaration 'CONSTANT boolean-variable-property) (define-declaration 'IGNORE-REFERENCE-TRAPS boolean-variable-property) (define-declaration 'IGNORE-ASSIGNMENT-TRAPS boolean-variable-property) -(define-declaration 'USUAL-DEFINITION boolean-variable-property) \ No newline at end of file +(define-declaration 'USUAL-DEFINITION boolean-variable-property) +(define-declaration 'SIDE-EFFECT-FREE boolean-variable-property) +(define-declaration 'PURE-FUNCTION boolean-variable-property) \ No newline at end of file diff --git a/v7/src/compiler/fgopt/blktyp.scm b/v7/src/compiler/fgopt/blktyp.scm index f38a8e4db..5958fbd76 100644 --- a/v7/src/compiler/fgopt/blktyp.scm +++ b/v7/src/compiler/fgopt/blktyp.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/blktyp.scm,v 4.6 1988/11/17 05:18:17 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/blktyp.scm,v 4.7 1988/12/06 18:55:58 jinx Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -90,12 +90,16 @@ MIT in each case. |# (and val (or (eq? val procedure) (and (rvalue/procedure? val) - (procedure/trivial-or-virtual? val)))))))) + (procedure/trivial-or-virtual? val))))) + (begin + (set-variable-closed-over?! lvalue true) + false)))) '()) - (if (and previously-trivial? - (not (procedure/trivial-closure? procedure))) - (error "close-procedure! trivial becoming non-trivial" - procedure)) + (let ((new (procedure/trivial-closure? procedure))) + (if (or (and previously-trivial? (not new)) + (and (not previously-trivial?) new)) + (error "close-procedure! trivial becoming non-trivial or viceversa" + procedure))) (set-block-children! current-parent (delq! block (block-children current-parent))) (set-block-disowned-children! @@ -118,14 +122,17 @@ MIT in each case. |# (filter-bound-variables (block-bound-variables block) free-variables bound-variables) - (find-internal (block-original-parent block)))))) + (find-internal (original-block-parent block)))))) find-internal) ;; This only works for procedures (not continuations) and it assumes ;; that all procedures' target-block field have been initialized. -(define-integrable (block-original-parent block) - (procedure-target-block (block-procedure block))) +(define-integrable (original-block-parent block) + (let ((procedure (block-procedure block))) + (and procedure + (rvalue/procedure? procedure) + (procedure-target-block procedure)))) (define (filter-bound-variables bindings free-variables bound-variables) (cond ((null? bindings) diff --git a/v7/src/compiler/fgopt/closan.scm b/v7/src/compiler/fgopt/closan.scm index 98c504b51..4233b7455 100644 --- a/v7/src/compiler/fgopt/closan.scm +++ b/v7/src/compiler/fgopt/closan.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/closan.scm,v 4.4 1988/11/01 04:51:03 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/closan.scm,v 4.5 1988/12/06 18:56:18 jinx Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -66,85 +66,134 @@ which is not a child, the current implementation requires that the other procedure also be a closure. However, if the closing-limit of the caller is the same as the closure-block of the callee, the callee will not be marked as a closure. This has disastrous results. As a -result, the analysis has been modified to force the closure-limit to +result, the analysis has been modified to force the closing-limit to #F whenever a closure is identified. |# (package (identify-closure-limits!) -(define-export (identify-closure-limits! procedures applications assignments) - (for-each initialize-closure-limit! procedures) - (for-each close-passed-out! procedures) - (for-each close-assignment-values! assignments) - (close-application-elements! applications)) +(define-export (identify-closure-limits! procs&conts applications lvalues) + (let ((procedures + (list-transform-negative procs&conts procedure-continuation?))) + (for-each initialize-lvalues-lists! lvalues) + (for-each initialize-closure-limit! procedures) + (for-each initialize-arguments! applications) + (transitive-closure + (lambda () + (for-each close-passed-out! procedures)) + (lambda (item) + (if (rvalue/procedure? item) + (analyze-procedure item) + (analyze-application item))) + (append procedures applications)) + ;; Clean up + (if (not compiler:preserve-data-structures?) + (for-each (lambda (procedure) + (set-procedure-free-callees! procedure '()) + (set-procedure-free-callers! procedure '()) + (set-procedure-variables! procedure '())) + procedures)))) + +(define (initialize-lvalues-lists! lvalue) + (if (lvalue/variable? lvalue) + (for-each (lambda (val) + (if (rvalue/procedure? val) + (set-procedure-variables! + val + (cons lvalue (procedure-variables val)))) + 'DONE) + (lvalue-values lvalue)))) (define (initialize-closure-limit! procedure) - (if (not (procedure-continuation? procedure)) - (set-procedure-closing-limit! procedure - (procedure-closing-block procedure)))) + (set-procedure-closing-limit! procedure + (procedure-closing-block procedure)) + 'DONE) + +(define (initialize-arguments! application) + (if (application/combination? application) + (begin + (let ((values + (let ((operands (application-operands application))) + (if (null? operands) + '() + (eq-set-union* (rvalue-values (car operands)) + (map rvalue-values (cdr operands))))))) + (set-application-operand-values! application values) + (for-each + (lambda (value) + (if (and (rvalue/procedure? value) + (not (procedure-continuation? value))) + (set-procedure-virtual-closure?! value true))) + values))))) (define (close-passed-out! procedure) (if (and (not (procedure-continuation? procedure)) (procedure-passed-out? procedure)) - (close-procedure! procedure false 'PASSED-OUT false))) + (maybe-close-procedure! procedure false 'PASSED-OUT false))) + +(define (analyze-procedure procedure) + (for-each (lambda (variable) + (maybe-close-procedure! procedure + (variable-block variable) + 'EXPORTED + variable)) + (procedure-variables procedure))) -(define (close-assignment-values! assignment) - (close-rvalue! (assignment-rvalue assignment) - (variable-block (assignment-lvalue assignment)) - 'ASSIGNMENT - (assignment-lvalue assignment))) +(define (analyze-application application) + (let* ((operator (application-operator application)) + (proc (rvalue-known-value operator)) + (procs (rvalue-values operator))) + (cond ((not (application/combination? application)) + ;; If the combination is not an application, we need not + ;; examine the operators for compatibility. + 'DONE) + ((rvalue-passed-in? operator) + ;; We don't need to close the operands because + ;; they have been marked as passed out already. + (close-rvalue! operator false 'APPLY-COMPATIBILITY application)) + ((null? procs) + ;; The (null? procs) case is the NOP node case. This combination + ;; should not be executed, so it should have no effect on any items + ;; involved in it. + 'DONE) + ((not proc) + (let ((class (compatibility-class procs)) + (model (car procs))) + (set-combination/model! application + (if (eq? class 'APPLY-COMPATIBILITY) + false + model)) + (if (eq? class 'POTENTIAL) + (for-each (lambda (proc) + (set-procedure-virtual-closure?! proc true)) + procs) + (begin + (close-rvalue! operator false class application) + (close-application-arguments! application false))))) + ((or (not (rvalue/procedure? proc)) + (procedure-closure-block proc)) + (close-application-arguments! application false)) + (else + 'DONE)))) -(define-integrable (close-application-arguments! application) - (close-values! - (application-operand-values application) - (let ((procedure (rvalue-known-value (application-operator application)))) - (and procedure - (rvalue/procedure? procedure) - (procedure-always-known-operator? procedure) - (procedure-block procedure))) - 'ARGUMENT - application)) - -;; This attempts to find the cases where all procedures are closed in -;; same block. This case can be solved by introduction of another -;; kind of closure, which has a fixed environment but carries around a -;; pointer to the code. - -(define (close-application-elements! applications) - (let loop ((applications applications) - (potential-winners '())) - (if (null? applications) - (maybe-close-multiple-operators! potential-winners) - (let ((application (car applications))) - (close-application-arguments! application) - (let ((operator (application-operator application))) - (cond ((not (application/combination? application)) - (loop (cdr applications) potential-winners)) - ((rvalue-passed-in? operator) - (close-rvalue! operator false - 'APPLY-COMPATIBILITY application) - (loop (cdr applications) potential-winners)) - ((or (rvalue-known-value operator) - ;; Paranoia - (and (null? (rvalue-values operator)) - (error "Operator has no values and not passed in" - operator application))) - (loop (cdr applications) potential-winners)) - (else - (let ((class - (compatibility-class (rvalue-values operator)))) - (if (not (eq? class 'APPLY-COMPATIBILITY)) - (set-combination/model! - application - (car (rvalue-values operator)))) - (if (eq? class 'POTENTIAL) - (loop (cdr applications) - (cons application potential-winners)) - (begin - (close-rvalue! operator false class application) - (loop (cdr applications) - potential-winners))))))))))) +(define (close-application-arguments! application block) + (let* ((previous (application-destination-block application)) + (new (cond ((eq? previous true) + block) + ((or (false? previous) + (false? block)) + false) + (else + (block-nearest-common-ancestor block previous))))) + (if (not (eq? new previous)) + (begin + (set-application-destination-block! application new) + (close-values! + (application-operand-values application) + new + 'ARGUMENT + application))))) (define (with-procedure-arity proc receiver) (let ((req (length (procedure-required proc)))) @@ -152,48 +201,12 @@ result, the analysis has been modified to force the closure-limit to (if (procedure-rest proc) -1 (+ req (length (procedure-optional proc))))))) - -;; The reason each application may have to be examined more than once -;; is because the same procedure may be a potential operator in more -;; than one application. The procedure may be forced into becoming a -;; closure due to one combination, forcing the others to become a -;; closure in other combinations, etc. The procedure dependency graph -;; could be built, but since the number of applications in this -;; category is usually VERY small, it does not seem worth it. - -(define (maybe-close-multiple-operators! applications) - (define (virtually-close-operators! application) - (for-each (lambda (proc) - (set-procedure-virtual-closure?! proc true)) - (rvalue-values (application-operator application)))) - - (define (relax applications still-good any-bad?) - (cond ((not (null? applications)) - (let ((application (car applications))) - (if (there-exists? - (rvalue-values (application-operator application)) - procedure/closure?) - (begin - (close-rvalue! (application-operator application) - false - 'COMPATIBILITY - application) - (relax (cdr applications) still-good true)) - (relax (cdr applications) - (cons application still-good) - any-bad?)))) - (any-bad? - (relax still-good '() false)) - (else - (for-each virtually-close-operators! still-good)))) - (relax applications '() false)) - (define (compatibility-class procs) (if (not (for-all? procs rvalue/procedure?)) 'APPLY-COMPATIBILITY (let* ((model (car procs)) - (model-env (procedure-closing-block model))) + (model-env (procedure-closing-limit model))) (with-procedure-arity model (lambda (model-min model-max) @@ -211,7 +224,7 @@ result, the analysis has been modified to force the closure-limit to (= model-max this-max))) 'APPLY-COMPATIBILITY) ((or (procedure/closure? this) - (not (eq? (procedure-closing-block this) + (not (eq? (procedure-closing-limit this) model-env))) (loop (cdr procs) 'COMPATIBILITY)) (else @@ -224,34 +237,150 @@ result, the analysis has been modified to force the closure-limit to (for-each (lambda (value) (if (and (rvalue/procedure? value) (not (procedure-continuation? value))) - (close-procedure! value binding-block reason1 reason2))) + (maybe-close-procedure! value binding-block + reason1 reason2))) values)) -(define (close-procedure! procedure binding-block reason1 reason2) +(define (maybe-close-procedure! procedure binding-block reason1 reason2) (let* ((closing-limit (procedure-closing-limit procedure)) (new-closing-limit (and binding-block closing-limit (block-nearest-common-ancestor binding-block closing-limit)))) (cond ((not (eq? new-closing-limit closing-limit)) - ;; **** Force trivial closure limit due to poor code generator. - (let ((new-closing-limit false)) - (set-procedure-closing-limit! procedure new-closing-limit) - (add-closure-reason! procedure reason1 reason2) - (if (not (procedure-closure-block procedure)) - ;; Force the procedure's type to CLOSURE. - (set-procedure-closure-block! procedure true)) - (close-callees! (procedure-block procedure) - new-closing-limit - procedure))) + (if (procedure-virtual-closure? procedure) + (set-procedure-virtual-closure?! procedure false)) + (close-procedure! procedure new-closing-limit reason1 reason2)) ((false? new-closing-limit) (add-closure-reason! procedure reason1 reason2))))) +(define (close-procedure! procedure new-closing-limit reason1 reason2) + new-closing-limit + ;; **** Force trivial closure limit due to poor code generator. **** + (let ((new-closing-limit false)) + (let ((previously-trivial? (procedure/trivial-closure? procedure))) + (set-procedure-closing-limit! procedure new-closing-limit) + ;; We can't change the closing block yet. + ;; blktyp has a consistency check that depends on the closing block + ;; remaining the same. + (add-closure-reason! procedure reason1 reason2) + ;; Force the procedure's type to CLOSURE. + (if (not (procedure-closure-block procedure)) + (set-procedure-closure-block! procedure true)) + ;; The code generator needs all callees to be closed. + (close-callees! (procedure-block procedure) + new-closing-limit + procedure) + ;; The environment optimizer may have moved some procedures in the + ;; environment tree based on the (now incorrect) assumption that this + ;; procedure was not closed. Fix this. + ;; On the other hand, if it was trivial before, it is still trivial + ;; now, so the callers are not affected. + (if (not previously-trivial?) + (examine-free-callers! procedure)) + ;; We need to reexamine those applications which may have this procedure + ;; as an operator, since the compatibility class of the operator may have + ;; changed. + (enqueue-nodes! (procedure-applications procedure))))) + +;; These are like the corresponding standard block operations, but +;; they ignore any block drifting caused by envopt. + +(define-integrable (original-block-parent block) + (let ((procedure (block-procedure block))) + (and procedure + (rvalue/procedure? procedure) + (procedure-target-block procedure)))) + +(define (original-block-ancestor-or-self? block block*) + (define (loop block) + (and block + (or (eq? block block*) + (loop (original-block-parent block))))) + + (or (eq? block block*) + (loop (original-block-parent block)))) + +(define (original-block-ancestry block path) + (if (block-parent block) + (original-block-ancestry (original-block-parent block) (cons block path)) + (cons block path))) + +(define (original-block-nearest-common-ancestor block block*) + (let loop + ((join false) + (ancestry (original-block-ancestry block '())) + (ancestry* (original-block-ancestry block* '()))) + (if (and (not (null? ancestry)) + (not (null? ancestry*)) + (eq? (car ancestry) (car ancestry*))) + (loop (car ancestry) (cdr ancestry) (cdr ancestry*)) + join))) + +(define-integrable (block<= ancestor descendant) + (block-ancestor-or-self? descendant ancestor)) + +(define (undrift-procedure! procedure block) + (let ((myblock (procedure-block procedure)) + (closing-block (procedure-closing-limit procedure)) + (original-closing-block (procedure-target-block procedure))) + (set-procedure-closing-limit! procedure block) + (set-block-children! closing-block + (delq! myblock (block-children closing-block))) + (set-block-children! block (cons myblock (block-children block))) + (enqueue-nodes! (cons procedure (procedure-applications procedure))) + (cond ((eq? block original-closing-block) + (set-block-disowned-children! original-closing-block + (delq! myblock + (block-disowned-children + original-closing-block)))) + ((and (not (block<= block original-closing-block)) + (rvalue/procedure? (block-procedure original-closing-block)) + (not (procedure-closure-block + (block-procedure original-closing-block)))) + ;; My original parent has drifted to a place where I can't + ;; be closed. I must drag it back. + (if (not (original-block-ancestor-or-self? original-closing-block + block)) + (error "Procedure has free variables in hyperspace!" + procedure)) + (undrift-procedure! (block-procedure original-closing-block) + block))) + (examine-free-callers! procedure))) + +(define (examine-free-callers! procedure) + (let ((myblock (procedure-block procedure))) + (for-each + (lambda (procedure*) + (if (false? (procedure-closure-block procedure*)) + (let ((closing-block (procedure-closing-limit procedure*)) + (original-closing-block (procedure-target-block procedure*))) + ;; No need to do anything if PROCEDURE* hasn't drifted + ;; relative to PROCEDURE. + (if (and (not (eq? closing-block original-closing-block)) + (not (block<= myblock closing-block))) + (let ((binding-block + (reduce original-block-nearest-common-ancestor + false + (map variable-block + (cdr (assq procedure + (procedure-free-callees + procedure*))))))) + (if (not (block<= binding-block closing-block)) + ;; PROCEDURE* has drifted towards the + ;; environment root past the point where we + ;; have access to PROCEDURE (by means of free + ;; variables). We must drift it away from + ;; the root until we regain access to PROCEDURE. + (undrift-procedure! procedure* binding-block))))))) + (procedure-free-callers procedure)))) + (define (close-callees! block new-closing-limit culprit) (for-each-callee! block (lambda (value) (if (not (block-ancestor-or-self? (procedure-block value) block)) - (close-procedure! value new-closing-limit 'CONTAGION culprit))))) + (maybe-close-procedure! value new-closing-limit + 'CONTAGION culprit))))) (define (for-each-callee! block procedure) (for-each-block-descendent! block diff --git a/v7/src/compiler/fgopt/envopt.scm b/v7/src/compiler/fgopt/envopt.scm index cf8090ad5..5868e3e85 100644 --- a/v7/src/compiler/fgopt/envopt.scm +++ b/v7/src/compiler/fgopt/envopt.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/envopt.scm,v 1.2 1988/11/17 05:12:25 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/envopt.scm,v 1.3 1988/12/06 18:56:41 jinx Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -92,12 +92,12 @@ MIT in each case. |# ;; external stuff, and irrelevant of whether they are ;; closures or not. (not (block-ancestor-or-self? (procedure-block value) block))) - (add-caller&callee! procedure value)))) + (add-caller&callee! procedure value variable)))) (define (check-callee! procedure block callee) ;; Here we do not need to worry about such things *** (if (not (block-ancestor-or-self? (procedure-block callee) block)) - (add-caller&callee! procedure callee))) + (add-caller&callee! procedure callee *NEED-A-VARIABLE-HERE*))) |# (define (initialize-target-block! procedure) @@ -123,10 +123,12 @@ MIT in each case. |# (set-procedure-target-block! procedure target-block)) (let ((value (lvalue-known-value (car free-vars))) (new-block (variable-block (car free-vars)))) + ;; Should this piece of code deal with sets + ;; of values rather than known values only? (cond ((and value (rvalue/constant? value)) (loop target-block (cdr free-vars))) ((and value (rvalue/procedure? value)) - (add-caller&callee! procedure value) + (add-caller&callee! procedure value (car free-vars)) (loop target-block (cdr free-vars))) ((block-ancestor? new-block target-block) ;; The current free variable is bound in a block @@ -149,7 +151,7 @@ MIT in each case. |# (target-block original)) ;; (constraint (block-ancestor-or-self? block target-block)) (cond ((not (null? dependencies)) - (let ((this-block (procedure-target-block (car dependencies)))) + (let ((this-block (procedure-target-block (caar dependencies)))) (if (block-ancestor-or-self? this-block block) (loop (cdr dependencies) target-block) (let ((merge-block @@ -173,11 +175,6 @@ MIT in each case. |# (define (choose-target-block! procedure) (let ((callers (procedure-free-callers procedure)) (closing-block (procedure-closing-block procedure))) - ;; Clean up - (if (not compiler:preserve-data-structures?) - (begin - (set-procedure-free-callees! procedure '()) - (set-procedure-free-callers! procedure '()))) ;; The following conditional makes some cases of LET-like procedures ;; track their parents in order to avoid closing over the same ;; variables twice. @@ -208,18 +205,22 @@ MIT in each case. |# ;;; Utilities -(define (add-caller&callee! procedure on-whom) +(define (add-caller&callee! procedure on-whom var) (if (not (procedure-continuation? on-whom)) (begin - (add-free-callee! procedure on-whom) + (add-free-callee! procedure on-whom var) (add-free-caller! on-whom procedure)))) -(define (add-free-callee! procedure on-whom) +(define (add-free-callee! procedure on-whom var) (let ((bucket (procedure-free-callees procedure))) - (cond ((null? bucket) - (set-procedure-free-callees! procedure (list on-whom))) - ((not (memq on-whom bucket)) - (set-procedure-free-callees! procedure (cons on-whom bucket)))) + (if (null? bucket) + (set-procedure-free-callees! procedure (list (list on-whom var))) + (let ((place (assq on-whom bucket))) + (if (false? place) + (set-procedure-free-callees! procedure + (cons (list on-whom var) bucket)) + (set-cdr! place + (cons var (cdr place)))))) 'DONE)) (define (add-free-caller! procedure on-whom) diff --git a/v7/src/compiler/fgopt/folcon.scm b/v7/src/compiler/fgopt/folcon.scm index 1350d2c97..59a6bf4dc 100644 --- a/v7/src/compiler/fgopt/folcon.scm +++ b/v7/src/compiler/fgopt/folcon.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/folcon.scm,v 4.4 1988/11/15 16:32:34 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/folcon.scm,v 4.5 1988/12/06 18:56:59 jinx Exp $ Copyright (c) 1987, 1988 Massachusetts Institute of Technology @@ -39,6 +39,24 @@ MIT in each case. |# (package (fold-constants) (define-export (fold-constants lvalues applications) + #| + ;; This is needed only if we use the version of eliminate-known-nodes + ;; commented out below. + ;; + ;; Initialize + ;; a. Remove circularities + (for-each (lambda (lvalue) + (set-lvalue-source-links! + lvalue + (list-transform-negative + (lvalue-backward-links lvalue) + (lambda (lvalue*) + (memq lvalue (lvalue-backward-links lvalue*)))))) + lvalues) + ;; b. Remove nop nodes + (transitive-closure false delete-if-nop! lvalues) + |# + ;; Do the actual work (let loop ((lvalues lvalues) (combinations @@ -50,6 +68,21 @@ MIT in each case. |# (loop unknown-lvalues not-folded) not-folded)))))) +#| +(define (delete-if-nop! lvalue) + (if (and (not (lvalue-passed-in? lvalue)) + (null? (lvalue-values lvalue)) + (null? (lvalue-source-links lvalue))) + (for-each + (lambda (lvalue*) + (set-lvalue-source-links! + lvalue* + (delq! lvalue (lvalue-source-links lvalue*))) + (enqueue-node! lvalue*)) + (lvalue-forward-links lvalue)))) +|# + +#| (define (eliminate-known-nodes lvalues) (let ((knowable-nodes (list-transform-positive lvalues @@ -73,17 +106,33 @@ MIT in each case. |# (define (delete-if-known! lvalue) (if (and (not (lvalue-known-value lvalue)) - (for-all? (lvalue-backward-links lvalue) - (lambda (lvalue*) - (if (eq? lvalue lvalue*) - true - (lvalue-known-value lvalue*))))) + (for-all? (lvalue-source-links lvalue) lvalue-known-value)) (let ((value (car (lvalue-values lvalue)))) (for-each (lambda (lvalue*) (if (lvalue-mark-set? lvalue* 'KNOWABLE) (enqueue-node! lvalue*))) (lvalue-forward-links lvalue)) (set-lvalue-known-value! lvalue value)))) +|# + +(define (eliminate-known-nodes lvalues) + (list-transform-negative lvalues + (lambda (lvalue) + (and (not (or (lvalue-passed-in? lvalue) + (and (variable? lvalue) + (variable-assigned? lvalue) + (not (memq 'CONSTANT + (variable-declarations lvalue)))))) + + (let ((values (lvalue-values lvalue))) + (and (not (null? values)) + (null? (cdr values)) + (let ((value (car values))) + (and (or (rvalue/procedure? value) + (rvalue/constant? value)) + (begin + (set-lvalue-known-value! lvalue value) + true))))))))) (define (fold-combinations combinations) (if (null? combinations) @@ -134,9 +183,9 @@ MIT in each case. |# (set-lvalue-passed-in?! lvalue new)) ((recompute-lvalue-passed-in! lvalue) (for-each (lambda (lvalue) - ;; We don't recompute-lvalue-passed-in! recursively - ;; because the forward-link relationship is transitively - ;; closed. + ;; We don't recompute-lvalue-passed-in! + ;; recursively because the forward-link + ;; relationship is transitively closed. (if (eq? (lvalue-passed-in? lvalue) 'INHERITED) (recompute-lvalue-passed-in! lvalue))) (lvalue-forward-links lvalue)))))))) @@ -164,7 +213,7 @@ MIT in each case. |# (not (reference-to-known-location? rv)) (let ((var (reference-lvalue rv))) (and (memq 'USUAL-DEFINITION (variable-declarations var)) - (variable-usual-definition (variable-name var))))))) + (constant-foldable-variable? (variable-name var))))))) (define (constant-foldable-operator-value rv) (if (rvalue/reference? rv) diff --git a/v7/src/compiler/fgopt/outer.scm b/v7/src/compiler/fgopt/outer.scm index ce9683223..2fdffc7e0 100644 --- a/v7/src/compiler/fgopt/outer.scm +++ b/v7/src/compiler/fgopt/outer.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/outer.scm,v 4.4 1988/11/15 16:32:58 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/outer.scm,v 4.5 1988/12/06 18:57:30 jinx Rel $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -54,16 +54,9 @@ MIT in each case. |# (for-each prepare-application applications)) check-application applications)) - + (define (prepare-application application) - (let ((values - (let ((operands (application-operands application))) - (if (null? operands) - '() - (eq-set-union* (rvalue-values (car operands)) - (map rvalue-values (cdr operands))))))) - (set-application-operand-values! application values) - (set-application-arguments! application values)) + (set-application-args-passed-out?! application false) ;; Need more sophisticated test here so that particular primitive ;; operators only pass out specific operands. A good test case is ;; `lexical-unassigned?' with a known block for its first argument @@ -75,13 +68,13 @@ MIT in each case. |# (define (check-application application) (if (and (rvalue-passed-in? (application-operator application)) - (not (null? (application-arguments application)))) + (not (application-args-passed-out? application))) (application-arguments-passed-out! application))) -(define (application-arguments-passed-out! application) - (let ((arguments (application-arguments application))) - (set-application-arguments! application '()) - (for-each rvalue-passed-out! arguments))) +(define-integrable (application-arguments-passed-out! application) + (set-application-args-passed-out?! application true) + (for-each rvalue-passed-out! + (application-operands application))) (define (rvalue-passed-out! rvalue) ((method-table-lookup passed-out-methods (tagged-vector/index rvalue)) @@ -151,7 +144,7 @@ MIT in each case. |# (define (%lvalue-passed-in! lvalue value) (set-lvalue-passed-in?! lvalue value) (for-each (lambda (application) - (if (not (null? (application-arguments application))) + (if (not (application-args-passed-out? application)) (enqueue-node! application))) (lvalue-applications lvalue))) diff --git a/v7/src/compiler/machines/bobcat/decls.scm b/v7/src/compiler/machines/bobcat/decls.scm index 0ff6f018f..344179bf6 100644 --- a/v7/src/compiler/machines/bobcat/decls.scm +++ b/v7/src/compiler/machines/bobcat/decls.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/decls.scm,v 4.16 1988/11/07 13:53:43 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/decls.scm,v 4.17 1988/12/06 18:54:49 jinx Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -347,7 +347,7 @@ MIT in each case. |# (filename/append "fgopt" "blktyp" "closan" "conect" "contan" "desenv" "envopt" "folcon" "offset" "operan" "order" - "outer" "simapp" "simple") + "outer" "sideff" "simapp" "simple") (filename/append "rtlbase" "regset" "rgraph" "rtlcfg" "rtlcon" "rtlexp" "rtline" "rtlobj" "rtlreg" "rtlty1" "rtlty2") @@ -481,7 +481,7 @@ MIT in each case. |# (filename/append "fgopt" "blktyp" "closan" "conect" "contan" "desenv" "envopt" "folcon" "offset" "operan" "order" - "outer" "simapp" "simple")) + "outer" "sideff" "simapp" "simple")) (append front-end-base bobcat-base)) (file-dependency/integration/join diff --git a/v7/src/compiler/machines/bobcat/make.scm-68040 b/v7/src/compiler/machines/bobcat/make.scm-68040 index 64c1f2196..fa8add433 100644 --- a/v7/src/compiler/machines/bobcat/make.scm-68040 +++ b/v7/src/compiler/machines/bobcat/make.scm-68040 @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 4.31 1988/11/17 05:20:43 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 4.32 1988/12/06 18:55:11 jinx Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -41,4 +41,4 @@ MIT in each case. |# ((package/reference (find-package name) 'INITIALIZE-PACKAGE!))) '((COMPILER MACROS) (COMPILER DECLARATIONS))) -(add-system! (make-system "Liar" 4 31 '())) \ No newline at end of file +(add-system! (make-system "Liar" 4 32 '())) \ No newline at end of file diff --git a/v7/src/compiler/rtlgen/rgretn.scm b/v7/src/compiler/rtlgen/rgretn.scm index a86c3487e..02d437da4 100644 --- a/v7/src/compiler/rtlgen/rgretn.scm +++ b/v7/src/compiler/rtlgen/rgretn.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgretn.scm,v 4.8 1988/11/04 10:28:34 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgretn.scm,v 4.9 1988/12/06 18:58:19 jinx Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -39,7 +39,7 @@ MIT in each case. |# (define (generate/return return) (generate/return* (return/block return) (return/operator return) - false + (application-continuation-push return) (trivial-return-operand (return/operand return)) (node/offset return))) @@ -70,7 +70,10 @@ MIT in each case. |# (define-export (generate/return* block operator not-on-stack? operand offset) (let ((continuation (rvalue-known-value operator))) - (if continuation + (if (and continuation + (not (procedure/simplified? + (block-procedure + (continuation/closing-block continuation))))) ((method-table-lookup simple-methods (continuation/type continuation)) (if not-on-stack? (return-operator/pop-frames block operator offset 0)