Write two new phases: compute-call-graph and side-effect-analysis.
#| -*-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
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*)
(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)
(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)
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)
#| -*-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
(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))
(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
#| -*-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
(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)
#| -*-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
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
(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))))
#| -*-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
(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)
#| -*-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
(set! *lvalues*)
(set! *applications*)
(set! *parallels*)
- (set! *assignments*)
+ ;; (set! *assignments*)
(set! *ic-procedure-headers*)
(set! *root-expression*)
(set! *root-block*)
(*lvalues*)
(*applications*)
(*parallels*)
- (*assignments*)
+ ;; (*assignments*)
(*ic-procedure-headers*)
(*root-expression*)
(*root-block*))
(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*)
(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)
(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*))))
-
+\f
(define (phase/simplicity-analysis)
(compiler-subphase "Simplicity Analysis"
(lambda ()
(simplicity-analysis *parallels*))))
-\f
+
(define (phase/subproblem-ordering)
(compiler-subphase "Subproblem Ordering"
(lambda ()
(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*))))))
\f
(define (phase/rtl-generation)
#| -*-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
(symbol? object)
(scode/primitive-procedure? object)
(eq? object compiled-error-procedure)))
-
-(define invariant-names
+\f
+(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
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)))
\f
-;;;; 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
#| -*-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
(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
#| -*-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
(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!
(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)
#| -*-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
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.
|#
\f
(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)))
+\f
+(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))))
\f
-(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))))
(if (procedure-rest proc)
-1
(+ req (length (procedure-optional proc)))))))
-\f
-;; 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))
-\f
(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)
(= 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
(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)))))
+\f
+;; 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)))
+\f
+(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)))
+\f
+(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
#| -*-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
;; 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*)))
|#
\f
(define (initialize-target-block! procedure)
(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
(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
(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.
\f
;;; 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)
#| -*-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
(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
(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))))
+|#
+\f
+#|
(define (eliminate-known-nodes lvalues)
(let ((knowable-nodes
(list-transform-positive lvalues
(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)))))))))
\f
(define (fold-combinations combinations)
(if (null? combinations)
(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))))))))
(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)
#| -*-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
(for-each prepare-application applications))
check-application
applications))
-\f
+
(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
(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)))
\f
(define (rvalue-passed-out! rvalue)
((method-table-lookup passed-out-methods (tagged-vector/index rvalue))
(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)))
#| -*-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
(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")
(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
#| -*-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
((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
#| -*-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
(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)))
(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)
projects / mit-scheme.git / commitdiff