#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/blocks.scm,v 4.3 1988/06/14 08:31:26 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/blocks.scm,v 4.4 1988/11/01 04:46:18 jinx Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
))
(define-integrable (ic-block? block)
- (eq? (block-type block) block-type/ic))
+ (let ((type (block-type block)))
+ (or (eq? type block-type/ic)
+ (eq? type block-type/expression))))
(define-integrable (closure-block? block)
(eq? (block-type block) block-type/closure))
(if (block-parent block)
(block-ancestry (block-parent block) (cons block path))
(cons block path)))
+
+(define (find-outermost-block block)
+ ;; Should this check whether it is an expression/ic block or not?
+ (if (block-parent block)
+ (find-outermost-block (block-parent block))
+ block))
\f
(define (stack-block/external-ancestor block)
(let ((parent (block-parent block)))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/ctypes.scm,v 4.5 1988/08/18 01:34:48 cph Exp $
+$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 $
Copyright (c) 1988 Massachusetts Institute of Technology
arguments) ;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
)
(define *applications*)
(let ((application
(make-snode application-tag
type block operator operands false '() '()
- continuation-push)))
+ continuation-push false)))
(set! *applications* (cons application *applications*))
(add-block-application! block application)
(if (rvalue/reference? operator)
(define-integrable set-combination/frame-size! set-application-operand-values!)
(define-integrable combination/inline? combination/inliner)
(define-integrable combination/continuation-push application-continuation-push)
+(define-integrable combination/model application-model)
+(define-integrable set-combination/model! set-application-model!)
(define-integrable (combination/continuation combination)
(car (application-operands combination)))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/lvalue.scm,v 4.6 1988/06/14 08:32:14 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/lvalue.scm,v 4.7 1988/11/01 04:47:24 jinx Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
(declare (usual-integrations))
\f
+;; IMPORTANT: Change transform/make-lvalue and the call to
+;; define-type-definition in macros.scm whenever a field is added or
+;; deleted!
+
(define-root-type lvalue
forward-links ;lvalues that sink values from here
backward-links ;lvalues that source values to here
passed-in? ;true iff this lvalue gets an unknown value
passed-out? ;true iff this lvalue passes its value to unknown place
marks ;attribute marks list (see `lvalue-mark-set?')
+ source-links ;backward links with circularities removed
)
;;; Note that the rvalues stored in `initial-values', `values-cache',
(and value
(or (rvalue/constant? value)
(and (rvalue/procedure? value)
- (procedure/open? value)
-#|
- ;; For now this is disabled.
- ;; We need self-consistent closing
- (or (procedure/open? value)
- (and (procedure/closure? value)
- (procedure/trivial-closure? value)))
-|#
- )))))
+ (procedure/virtually-open? value))))))
\f
(define (lvalue=? lvalue lvalue*)
(or (eq? lvalue lvalue*)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/macros.scm,v 4.6 1988/08/22 20:20:59 markf Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/macros.scm,v 4.7 1988/11/01 04:48:06 jinx Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
(define-type-definition snode 5 false)
(define-type-definition pnode 6 false)
(define-type-definition rvalue 2 rvalue-types)
- (define-type-definition lvalue 10 false))
+ (define-type-definition lvalue 11 false))
;;; Kludge to make these compile efficiently.
(let ((result (generate-uninterned-symbol)))
`(let ((,result
((ACCESS VECTOR ,system-global-environment)
- ,tag '() '() '() 'NOT-CACHED FALSE '() FALSE FALSE '()
+ ,tag '() '() '() 'NOT-CACHED FALSE '() FALSE FALSE '() '()
,@extra)))
(SET! *LVALUES* (CONS ,result *LVALUES*))
,result))))
(define transform/define-rtl-predicate)
(let ((rtl-common
(lambda (type prefix components wrap-constructor)
- (let ((constructor-name (symbol-append prefix 'MAKE- type)))
- `(BEGIN
- (DEFINE-INTEGRABLE
- (,constructor-name ,@components)
- ,(wrap-constructor `(LIST ',type ,@components)))
- (DEFINE-RTL-CONSTRUCTOR ',type ,constructor-name)
- (DEFINE-INTEGRABLE (,(symbol-append 'RTL: type '?) EXPRESSION)
- (EQ? (CAR EXPRESSION) ',type))
- ,@(let loop ((components components)
- (ref-index 6)
- (set-index 2))
- (if (null? components)
- '()
- (let* ((slot (car components))
- (name (symbol-append type '- slot)))
- `((DEFINE-INTEGRABLE (,(symbol-append 'RTL: name) ,type)
- (GENERAL-CAR-CDR ,type ,ref-index))
- (DEFINE-INTEGRABLE (,(symbol-append 'RTL:SET- name '!)
- ,type ,slot)
- (SET-CAR! (GENERAL-CAR-CDR ,type ,set-index) ,slot))
- ,@(loop (cdr components)
- (* ref-index 2)
- (* set-index 2)))))))))))
+ `(BEGIN
+ (DEFINE-INTEGRABLE
+ (,(symbol-append prefix 'MAKE- type) ,@components)
+ ,(wrap-constructor `(LIST ',type ,@components)))
+ (DEFINE-INTEGRABLE (,(symbol-append 'RTL: type '?) EXPRESSION)
+ (EQ? (CAR EXPRESSION) ',type))
+ ,@(let loop ((components components)
+ (ref-index 6)
+ (set-index 2))
+ (if (null? components)
+ '()
+ (let* ((slot (car components))
+ (name (symbol-append type '- slot)))
+ `((DEFINE-INTEGRABLE (,(symbol-append 'RTL: name) ,type)
+ (GENERAL-CAR-CDR ,type ,ref-index))
+ (DEFINE-INTEGRABLE (,(symbol-append 'RTL:SET- name '!)
+ ,type ,slot)
+ (SET-CAR! (GENERAL-CAR-CDR ,type ,set-index) ,slot))
+ ,@(loop (cdr components)
+ (* ref-index 2)
+ (* set-index 2))))))))))
(set! transform/define-rtl-expression
(macro (type prefix . components)
(rtl-common type prefix components identity-procedure)))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/proced.scm,v 4.5 1988/06/14 08:33:14 cph Exp $
+$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 $
Copyright (c) 1988 Massachusetts Institute of Technology
original-rest ;like `rest' but never changed
label ;label to identify procedure entry point [symbol]
applications ;list of applications for which this is an operator
- always-known-operator? ;true if always known operator of application
+ always-known-operator? ;always known operator of application? [boolean]
closing-limit ;closing limit (see code)
closure-block ;for closure, where procedure is closed [block]
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
+ 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]
)
(define *procedures*)
(node->edge (cfg-entry-node scfg))
(list-copy required) (list-copy optional) rest
(generate-label name) false false false false false
- false false)))
+ false false false false false false '() '() false)))
(set! *procedures* (cons procedure *procedures*))
(set-block-procedure! block procedure)
procedure))
(define-integrable (procedure-closing-block procedure)
(block-parent (procedure-block procedure)))
+(define (set-procedure-closing-block! procedure block)
+ (set-block-parent! (procedure-block procedure) block))
+
(define-integrable (procedure-continuation-lvalue procedure)
;; Valid only if (not (procedure-continuation? procedure))
(car (procedure-required procedure)))
(null? (cdr (procedure-applications procedure))))
(define (procedure-inline-code? procedure)
- (and (procedure/open? procedure)
- (procedure-always-known-operator? procedure)
- (procedure-application-unique? procedure)))
+ (or (procedure-trivial? procedure)
+ (and (procedure-always-known-operator? procedure)
+ (procedure-application-unique? procedure)
+ (procedure/virtually-open? procedure))))
(define-integrable (open-procedure-needs-static-link? procedure)
(stack-block/static-link? (procedure-block procedure)))
(define (procedure/open-internal? procedure)
(and (procedure/open? procedure)
- (procedure/internal? procedure)))
\ No newline at end of file
+ (procedure/internal? procedure)))
+
+(define (procedure/virtually-open? procedure)
+ (or (procedure/open? procedure)
+ (and (procedure/closure? procedure)
+ (procedure/trivial-closure? procedure))))
+
+(define (procedure/trivial-or-virtual? procedure)
+ (or (procedure-virtual-closure? procedure)
+ (and (procedure/closure? procedure)
+ (procedure/trivial-closure? procedure))))
+\f
+(define (add-closure-reason! procedure reason1 reason2)
+ (let ((reasons (procedure-closure-reasons procedure)))
+ (let ((slot (assq reason1 reasons)))
+ (cond ((null? slot)
+ (set-procedure-closure-reasons!
+ procedure
+ (cons (cons reason1
+ (if (false? reason2)
+ '()
+ (list reason2)))
+ reasons)))
+ ((and (not (false? reason2))
+ (not (memq reason2 (cdr slot))))
+ (set-cdr! slot (cons reason2 (cdr slot))))))))
+
+;; The possible reasons are
+;;
+;; - passed-out : procedure is available from outside block
+;; (usually an upwards funarg).
+;;
+;; - argument : procedure is given as an argument to a procedure does not
+;; share its lexical chain. Some of these cases of downward funargs
+;; could be stack allocated.
+;;
+;; - assignment: procedure is assigned to some variable outside its closing
+;; block.
+;;
+;; - contagion: procedure is called by some other closure.
+;;
+;; - compatibility: procedure is called from a location which may have more
+;; than one operator, but the complete set of possibilities is known and
+;; they are compatible closures.
+;;
+;; - apply-compatibility: procedure is called from a location which may have
+;; move than one operator, but the complete set of possibilities is now known
+;; or they are incompatible, so (internal) apply has to be used.
+
+(define (closure-procedure-needs-external-descriptor? procedure)
+ (let loop ((reasons (procedure-closure-reasons procedure)))
+ (and (not (null? reasons))
+ (or (memq (caar reasons)
+ '(PASSED-OUT ARGUMENT ASSIGNMENT APPLY-COMPATIBILITY))
+ (loop (cdr reasons))))))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/switch.scm,v 4.7 1988/09/02 20:24:45 markf Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/switch.scm,v 4.8 1988/11/01 04:48:53 jinx Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
(define compiler:show-subphases? false)
(define compiler:preserve-data-structures? false)
(define compiler:code-compression? true)
-(define compiler:compile-once-only-packages-recursively? true)
(define compiler:cache-free-variables? true)
(define compiler:implicit-self-static? false)
+(define compiler:optimize-environments? true)
(define compiler:cse? true)
(define compiler:open-code-primitives? true)
(define compiler:generate-rtl-files? false)
(define compiler:generate-range-checks? false)
(define compiler:generate-type-checks? false)
-
+(define compiler:open-code-flonum-checks? false)
;;; Nary switches
(define compiler:package-optimization-level
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/toplev.scm,v 4.10 1988/10/20 18:34:36 markf Exp $
+$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 $
Copyright (c) 1988 Massachusetts Institute of Technology
(phase/fold-constants)
(phase/open-coding-analysis)
(phase/operator-analysis)
+ (phase/environment-optimization)
(phase/identify-closure-limits)
(phase/setup-block-types) (phase/continuation-analysis)
(phase/simplicity-analysis)
(lambda ()
(operator-analysis *procedures* *applications*))))
+(define (phase/environment-optimization)
+ (compiler-subphase "Environment optimization"
+ (lambda ()
+ (optimize-environments! *procedures*))))
+
(define (phase/identify-closure-limits)
(compiler-subphase "Closure Limit Identification"
(lambda ()
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fggen/canon.scm,v 1.2 1988/06/14 08:36:01 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fggen/canon.scm,v 1.3 1988/11/01 04:49:45 jinx Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
(declare (usual-integrations))
\f
-;;;; Data structures, top level and switches
-
-(define-structure canout ; canonicalize-output
- expr ; expression
- safe? ; safe? if no (THE-ENVIRONMENT)
- needs? ; requires environment binding
- splice?) ; top level can be moved
-
#|
-Allowed levels for compiler:package-optimization-level are:
+This program translates expressions depending on the context
+in which they appear, the value of the global switch
+compiler:package-optimization-level, and the variables which are
+bound by "visible" surrounding lambda expressions.
+
+1) Allowed levels for compiler:package-optimization-level are:
-All levels treat all packages uniformly except the HYBRID level.
+All levels except HYBRID treat all packages uniformly.
NONE: no optimization is to be performed.
processed independently. They are copied as necessary to
avoid inefficiencies (or incorrectness) due to shared lexical
addresses, etc.
+
+2) The context in which an expression appears is described by an
+argument to canonicalize/expression. The context argument can take
+the following values:
+
+FIRST-CLASS: Treat every expression as if it appeared in a first class
+ environment. This is used by the LOW optimization level.
+
+TOP-LEVEL: The expression appears at top level of the original
+ expression or an in-package special form. It is not
+ surrounded by any lambda expressions in the input form.
+ It is assumed that such expressions are only executed
+ (evaluated) once.
+
+ONCE-ONLY: The expression will be executed only once (as long as
+ the corresponding top level expression is executed
+ only once), although it appears surrounded by some
+ lambda expression. Currently this context occurs only
+ in the body of (potentially nested) top level LET
+ expressions.
+
+ARBITRARY: The expression may be executed more than once. It
+ appears surrounded by some lambda expressions which
+ have not been proven to be invoked at most once.
|#
+\f
+;;;; Data structures, top level and switches
+
+(define-structure canout ; canonicalize-output
+ expr ; expression
+ safe? ; safe? if no (THE-ENVIRONMENT)
+ needs? ; requires environment binding
+ splice?) ; top level can be moved
(define (canonicalize/top-level expression)
(if (eq? compiler:package-optimization-level 'NONE)
\f
;;;; Caching first class environments
-(define environment-variable (make-named-tag "ENVIRONMENT"))
+(define environment-variable
+ (make-named-tag "ENVIRONMENT"))
(define (scode/comment-directive? text . kinds)
(and (pair? text)
(recvr (scode/quotation-expression (car operands)))
(normal))))
(normal)))))
-
+\f
(cond ((scode/variable? body)
(let ((name (scode/variable-name body)))
(if (eq? name environment-variable)
((scode/comment? body)
(comment body (lambda (nbody) nbody)))
(else (normal))))
-\f
-;;;; Hairy expressions
(define (combine-list elements)
(if (null? elements)
(car elements)
(combine-list (cdr elements)))))
+;;; Expressions
+
(define canonicalize/constant canonicalize/trivial)
(define (canonicalize/error operator operands bound context)
(list (canonicalize/expression (car operands) bound context)
(canonicalize/expression (cadr operands) bound context)
(canonicalize/trivial (caddr operands) bound context)))))
+\f
+;;;; Variables and assignment
+
+;; Variables and assignment are treated asymmetrically:
+;; Assignments to free variables in non ARBITRARY contexts are
+;; performed by using LEXICAL-ASSIGNMENT to avoid creating an
+;; assignment cache which will be used only once. Variable references
+;; will only use LEXICAL-REFERENCE in FIRST-CLASS contexts.
+;; The reason for this asymmetry is that a common programming style is
+;; to bind some names at top level, and then assign them from within a
+;; once-only context to initialize them. Lowering the space
+;; requirements of the assignment is more important than increasing
+;; the speed since the assignment will only be done once. This
+;; decision penalizes certain assignments, but oh well...
(define (canonicalize/variable var bound context)
(let ((name (scode/variable-name var)))
expr
(lambda (name old-value)
(let ((value (canonicalize/expression old-value bound context)))
- (cond ((not (eq? context 'FIRST-CLASS))
+ (cond ((eq? context 'ARBITRARY)
(canonicalize/combine-binary scode/make-assignment
(make-canout name true false (if (memq name bound) true false))
value))
(list (scode/make-variable environment-variable)
name
(canout-expr value)))
- (canout-safe? value) true false)))))))
+ (canout-safe? value)
+ true false)))))))
\f
-;;;; More hairy expressions
+;;;; Hairy expressions
(define (canonicalize/definition expression bound context)
(scode/definition-components expression
nenv))
(cond ((canout-splice? nexpr)
+ ;; Random optimization. The in-package expression has no
+ ;; free variables. Turn it into a sequence.
(canonicalize/combine-unary scode/make-sequence
(combine-list (list nenv nexpr))))
((canonicalize/optimization-low? context)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fggen/fggen.scm,v 4.10 1988/08/18 02:02:37 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fggen/fggen.scm,v 4.11 1988/11/01 04:50:09 jinx Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
(let ((operator (scode/combination-operator expression))
(operands (scode/combination-operands expression)))
(cond ((and (eq? operator (ucode-primitive lexical-unassigned?))
- (the-environment? (car operands))
+ (scode/the-environment? (car operands))
(scode/symbol? (cadr operands)))
(generate/unassigned? block continuation expression))
((and (or (eq? operator (ucode-primitive error-procedure))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/blktyp.scm,v 4.4 1988/04/15 02:06:00 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/blktyp.scm,v 4.5 1988/11/01 04:50:40 jinx Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(define (close-procedure! block)
(let ((procedure (block-procedure block))
- (parent (block-parent block)))
- ;; Note: this should be innocuous if there is already a closure block.
- ;; In particular, if there is a closure block which happens to be a
- ;; reference placed there by the first-class environment transformation
- ;; in fggen/fggen and fggen/canon, and it is replaced by the line below,
- ;; the presumpt first-class environment is not really used as one, so
- ;; the procedure is being "demoted" from first-class to closure.
- (set-procedure-closure-block! procedure parent)
- (((find-closure-bindings
- (lambda (closure-frame-block size)
- (set-block-parent! block closure-frame-block)
- (set-procedure-closure-size! procedure size)))
- parent)
- (list-transform-negative (block-free-variables block)
- (lambda (lvalue)
- (eq? (lvalue-known-value lvalue) procedure)))
- '())
- (set-block-children! parent (delq! block (block-children parent)))
- (set-block-disowned-children!
- parent
- (cons block (block-disowned-children parent)))))
+ (current-parent (block-parent block)))
+ (let ((parent (or (procedure-target-block procedure) current-parent)))
+ ;; Note: this should be innocuous if there is already a closure block.
+ ;; In particular, if there is a closure block which happens to be a
+ ;; reference placed there by the first-class environment transformation
+ ;; in fggen/fggen and fggen/canon, and it is replaced by the line below,
+ ;; the presumpt first-class environment is not really used as one, so
+ ;; the procedure is being "demoted" from first-class to closure.
+ (set-procedure-closure-block! procedure parent)
+ (((find-closure-bindings
+ (lambda (closure-frame-block size)
+ (set-block-parent! block closure-frame-block)
+ (set-procedure-closure-size! procedure size)))
+ parent)
+ (list-transform-negative (block-free-variables block)
+ (lambda (lvalue)
+ (let ((val (lvalue-known-value lvalue)))
+ (and val
+ (or (eq? val procedure)
+ (and (rvalue/procedure? val)
+ (procedure/trivial-or-virtual? val)))))))
+ '())
+ (set-block-children! current-parent
+ (delq! block (block-children current-parent)))
+ (set-block-disowned-children!
+ current-parent
+ (cons block (block-disowned-children current-parent))))))
\f
(define (find-closure-bindings receiver)
(define (find-internal block)
(filter-bound-variables (block-bound-variables block)
free-variables
bound-variables)
- (find-internal (block-parent block))))))
+ (find-internal (block-original-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 (filter-bound-variables bindings free-variables bound-variables)
(cond ((null? bindings)
(return-2 free-variables bound-variables))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/closan.scm,v 4.3 1988/04/15 02:05:28 jinx Exp $
+$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 $
Copyright (c) 1987 Massachusetts Institute of Technology
(define-export (identify-closure-limits! procedures applications assignments)
(for-each initialize-closure-limit! procedures)
(for-each close-passed-out! procedures)
- (for-each close-application-arguments! applications)
- (for-each close-assignment-values! assignments))
+ (for-each close-assignment-values! assignments)
+ (close-application-elements! applications))
(define (initialize-closure-limit! procedure)
(if (not (procedure-continuation? procedure))
(define (close-passed-out! procedure)
(if (and (not (procedure-continuation? procedure))
(procedure-passed-out? procedure))
- (close-procedure! procedure false)))
-
-(define (close-application-arguments! application)
- ;; Note that case where all procedures are closed in same block can
- ;; be solved by introduction of another kind of closure, which has a
- ;; fixed environment but carries around a pointer to the code.
- (if (application/combination? application)
- (let ((operator (application-operator application)))
- (if (not (rvalue-known-value operator))
- (close-rvalue! operator false))))
+ (close-procedure! procedure false 'PASSED-OUT false)))
+
+(define (close-assignment-values! assignment)
+ (close-rvalue! (assignment-rvalue assignment)
+ (variable-block (assignment-lvalue assignment))
+ 'ASSIGNMENT
+ (assignment-lvalue assignment)))
+\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)
- ;; **** Force trivial closure limit.
- ;; (procedure-block procedure)
- false))))
+ (procedure-block procedure)))
+ 'ARGUMENT
+ application))
-(define (close-assignment-values! assignment)
- (close-rvalue! (assignment-rvalue assignment)
- ;; **** Force trivial closure limit.
- ;; (variable-block (assignment-lvalue assignment))
- false))
+;; 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 (with-procedure-arity proc receiver)
+ (let ((req (length (procedure-required proc))))
+ (receiver req
+ (if (procedure-rest proc)
+ -1
+ (+ req (length (procedure-optional proc)))))))
\f
-(define-integrable (close-rvalue! rvalue binding-block)
- (close-values! (rvalue-values rvalue) binding-block))
+;; 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 (close-values! values binding-block)
+ (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)))
+ (with-procedure-arity
+ model
+ (lambda (model-min model-max)
+ (let loop ((procs (cdr procs))
+ (class (if (procedure/closure? model)
+ 'COMPATIBILITY
+ 'POTENTIAL)))
+ (if (null? procs)
+ class
+ (let ((this (car procs)))
+ (with-procedure-arity
+ this
+ (lambda (this-min this-max)
+ (cond ((not (and (= model-min this-min)
+ (= model-max this-max)))
+ 'APPLY-COMPATIBILITY)
+ ((or (procedure/closure? this)
+ (not (eq? (procedure-closing-block this)
+ model-env)))
+ (loop (cdr procs) 'COMPATIBILITY))
+ (else
+ (loop (cdr procs) class)))))))))))))
+\f
+(define-integrable (close-rvalue! rvalue binding-block reason1 reason2)
+ (close-values! (rvalue-values rvalue) binding-block reason1 reason2))
+
+(define (close-values! values binding-block reason1 reason2)
(for-each (lambda (value)
(if (and (rvalue/procedure? value)
(not (procedure-continuation? value)))
- (close-procedure! value binding-block)))
+ (close-procedure! value binding-block reason1 reason2)))
values))
-(define (close-procedure! procedure binding-block)
- (let ((closing-limit (procedure-closing-limit procedure)))
- (let ((new-closing-limit
- (and binding-block
- closing-limit
- (block-nearest-common-ancestor binding-block closing-limit))))
- (if (not (eq? new-closing-limit closing-limit))
- (begin
- (set-procedure-closing-limit! procedure new-closing-limit)
- (if (not (procedure-closure-block procedure))
- ;; The following line forces the procedure's type to CLOSURE.
- (set-procedure-closure-block! procedure true))
- (close-callees! (procedure-block procedure) new-closing-limit))))))
-
-(define (close-callees! block new-closing-limit)
+(define (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)))
+ ((false? new-closing-limit)
+ (add-closure-reason! procedure reason1 reason2)))))
+
+(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)))))
+ (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/offset.scm,v 4.4 1988/08/18 01:36:00 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/offset.scm,v 4.5 1988/11/01 04:51:59 jinx Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
((APPLICATION)
(case (application-type node)
((COMBINATION)
+ ;; This is done because the arguments may be integrated and may
+ ;; be closures that would otherwise not be met, since they are
+ ;; never operators.
+ (if (combination/inline? node)
+ (for-each
+ (lambda (subp)
+ (walk-rvalue (subproblem-rvalue subp)))
+ (cdr (parallel-subproblems (application-owner node)))))
(walk-rvalue (combination/operator node)))
((RETURN)
(walk-return (return/operator node) (return/operand node) offset))))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/order.scm,v 4.8 1988/10/04 22:59:20 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/order.scm,v 4.9 1988/11/01 04:52:18 jinx Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
(combination/block combination)
(car subproblems)
(cdr subproblems)
- (rvalue-known-value (combination/operator combination)))))
+ (or (rvalue-known-value (combination/operator combination))
+ (combination/model combination)))))
(set-combination/frame-size!
combination
(let loop ((subproblems subproblems) (accumulator 0))
accumulator)))))
subproblems))
-(define (order-subproblems/out-of-line block operator operands callee)
+(define (order-subproblems/out-of-line block operator operands model)
(set-subproblem-type! operator (operator-type (subproblem-rvalue operator)))
- (if (and callee (rvalue/procedure? callee))
+ (if (and model (rvalue/procedure? model))
(let ((rest
- (cond ((not (stack-block? (procedure-block callee)))
+ (cond ((not (stack-block? (procedure-block model)))
(standard-combination-ordering operator operands))
- ((procedure-always-known-operator? callee)
+ ((procedure-always-known-operator? model)
;; At this point, the following should be true.
- ;; (procedure-interface-optimizible? callee)
+ ;; (procedure-interface-optimizible? model)
(optimized-combination-ordering block
operator
operands
- callee))
+ model))
(else
(known-combination-ordering block operator
- operands callee)))))
- (if (procedure/open? callee)
- (generate/static-link block callee rest)
+ operands model)))))
+ (if (procedure/open? model)
+ (generate/static-link block model rest)
rest))
(standard-combination-ordering operator operands)))
\f
(reverse (cons operator operands)))
(define (known-combination-ordering block operator operands procedure)
- (if (not (procedure/closure? procedure))
+ (if (and (not (procedure/closure? procedure))
+ (not (procedure-virtual-closure? procedure)))
(error "known-combination-ordering: known non-closure" procedure))
;; The behavior of known lexpr closures should be improved
;; at least when the listification is trivial (0 or 1 args).
(set-subproblem-types! operands continuation-type/push)
(set-subproblem-type!
operator
- (if (closure-procedure-needs-operator? procedure)
+ (if (or (not (rvalue-known-value (subproblem-rvalue operator)))
+ (and (procedure/closure? procedure)
+ (closure-procedure-needs-operator? procedure)))
continuation-type/push
continuation-type/effect))
(push-unassigned block
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/compiler.pkg,v 1.7 1988/08/23 16:34:11 markf Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/compiler.pkg,v 1.8 1988/11/01 04:43:57 jinx Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
"fgopt/folcon" ;fold constants
"fgopt/operan" ;operator analysis
"fgopt/closan" ;closure analysis
+ "fgopt/envopt" ;environment optimization
"fgopt/blktyp" ;environment type assignment
"fgopt/contan" ;continuation analysis
"fgopt/simple" ;simplicity analysis
identify-closure-limits!
operator-analysis
outer-analysis
+ optimize-environments!
setup-block-types!
simplicity-analysis
simulate-application
"rtlbase/rtline" ;linearizer
)
(parent (compiler))
+ (export (compiler)
+ make-linearizer)
(export (compiler top-level)
generate/top-level
linearize-rtl
- open-coding-analysis)
+ open-coding-analysis
+ setup-bblock-continuations!)
(export (compiler debug)
linearize-rtl)
- (export (compiler rtl-optimizer)
- rgraph/compress!
- generate-primitive
- generate-type-test
- generate-generic-binary
- generate-generic-unary))
+ (import (compiler top-level)
+ label->object))
(define-package (compiler rtl-cse)
(files "rtlopt/rcse1" ;RTL common subexpression eliminator
"rtlopt/rdeath" ;RTL code compression
"rtlopt/rdebug" ;RTL optimizer debugging output
"rtlopt/ralloc" ;RTL register allocation
- "rtlopt/expand" ;RTL expansion
)
(parent (compiler))
(export (compiler top-level)
code-compression
lifetime-analysis
- register-allocation
- rtl-expansion))
+ register-allocation))
(define-package (compiler debugging-information)
(files "base/infnew")
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/compiler.sf,v 1.5 1988/08/31 06:49:59 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/compiler.sf,v 1.6 1988/11/01 04:45:49 jinx Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
;;;; Script to incrementally syntax the compiler
\f
+(fluid-let ((sf/usual-integrations-default-deletions
+ '(VARIABLE? PRIMITIVE-PROCEDURE?)))
+
;; Guarantee that the package modeller is loaded.
(if (not (name->package '(CROSS-REFERENCE)))
(with-working-directory-pathname "/scheme/cref" (lambda () (load "make"))))
;; Rebuild the package constructors and cref.
(cref/generate-all "comp")(sf "comp.con" "comp.bcon")
-(sf "comp.ldr" "comp.bldr")
\ No newline at end of file
+(sf "comp.ldr" "comp.bldr")
+) ;; End of fluid-let
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/dassm2.scm,v 4.7 1988/06/14 08:46:44 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/dassm2.scm,v 4.8 1988/11/01 04:56:26 jinx Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
(let ((word (bit-string-allocate size-in-bits)))
(with-absolutely-no-interrupts
(lambda ()
- (read-bits! (if *block (+ (object-datum *block) offset) offset)
- 0
- word)))
+ (if *block
+ (read-bits! *block (* offset addressing-granularity) word)
+ (read-bits! offset 0 word))))
word))
\f
;;;; Compiler specific information
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/decls.scm,v 4.8 1988/09/01 19:31:16 markf Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/decls.scm,v 4.9 1988/11/01 04:57:13 jinx Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
(define (syntax-files!)
(for-each
(lambda (node)
- (set-source-node/modification-time!
- node
- (let ((source (modification-time node "scm"))
- (binary (modification-time node "bin")))
- (if (not source)
- (error "Missing source file" (source-node/filename node)))
- (and binary (< source binary) binary))))
+ (let ((modification-time
+ (let ((source (modification-time node "scm"))
+ (binary (modification-time node "bin")))
+ (if (not source)
+ (error "Missing source file" (source-node/filename node)))
+ (and binary (< source binary) binary))))
+ (set-source-node/modification-time! node modification-time)
+ (if (not modification-time)
+ (begin (newline)
+ (write-string "Source file newer than binary: ")
+ (write (source-node/filename node))))))
source-nodes)
(if compiler:enable-integration-declarations?
(begin
(let ((time (source-node/modification-time node)))
(if (and time
(there-exists? (source-node/dependencies node)
- (lambda (node)
- (let ((time* (source-node/modification-time node)))
- (or (not time*)
- (> time* time))))))
+ (lambda (node*)
+ (let ((newer?
+ (let ((time*
+ (source-node/modification-time node*)))
+ (or (not time*)
+ (> time* time)))))
+ (if newer?
+ (begin
+ (newline)
+ (write-string "Binary file ")
+ (write (source-node/filename node))
+ (write-string " newer than dependency ")
+ (write (source-node/filename node*))))
+ newer?))))
(set-source-node/modification-time! node false))))
source-nodes)
(for-each
(lambda (node)
(if (not (source-node/modification-time node))
- (for-each (lambda (node)
- (set-source-node/modification-time! node false))
+ (for-each (lambda (node*)
+ (if (source-node/modification-time node*)
+ (begin
+ (newline)
+ (write-string "Binary file ")
+ (write (source-node/filename node*))
+ (write-string " depends on ")
+ (write (source-node/filename node))))
+ (set-source-node/modification-time! node* false))
(source-node/dependents node))))
source-nodes)))
(for-each (lambda (node)
source-nodes/by-rank)
(for-each source-node/maybe-syntax! source-nodes/by-rank)
(for-each source-node/maybe-syntax! source-nodes/circular-dependencies))
-
+\f
(define (source-node/maybe-syntax! node)
(if (not (source-node/modification-time node))
(source-node/syntax! node)))
"declar" "fggen" "canon")
(filename/append "fgopt"
"blktyp" "closan" "conect" "contan" "desenv"
- "folcon" "offset" "operan" "order" "outer"
- "simapp" "simple")
+ "envopt" "folcon" "offset" "operan" "order"
+ "outer" "simapp" "simple")
(filename/append "rtlbase"
"regset" "rgraph" "rtlcfg" "rtlcon" "rtlexp"
"rtline" "rtlobj" "rtlreg" "rtlty1" "rtlty2")
"rgrval" "rgstmt" "rtlgen")
(filename/append "rtlopt"
"ralloc" "rcse1" "rcse2" "rcseep" "rcseht"
- "rcserq" "rcsesr" "rdeath" "rdebug" "rlife"
- "expand"))
+ "rcserq" "rcsesr" "rdeath" "rdebug" "rlife"))
compiler-syntax-table)
(file-dependency/syntax/join
(filename/append "machines/bobcat"
(filename/append "fggen"
"declar" "fggen") ; "canon" needs no integrations
(filename/append "fgopt"
- "blktyp" "closan" "conect" "contan" "desenv" "folcon"
- "offset" "operan" "order" "outer" "simapp" "simple"))
+ "blktyp" "closan" "conect" "contan" "desenv"
+ "envopt" "folcon" "offset" "operan" "order"
+ "outer" "simapp" "simple"))
(append front-end-base bobcat-base))
(file-dependency/integration/join
(file-dependency/integration/join
(append cse-base
- (filename/append "rtlopt" "ralloc" "rdeath" "rdebug" "rlife" "expand"))
+ (filename/append "rtlopt" "ralloc" "rdeath" "rdebug" "rlife"))
(append bobcat-base rtl-base))
(file-dependency/integration/join cse-base cse-base)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 4.25 1988/10/20 18:50:45 markf Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 4.26 1988/11/01 04:57:48 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 25 '()))
\ No newline at end of file
+(add-system! (make-system "Liar" 4 26 '()))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules3.scm,v 4.10 1988/08/29 22:54:31 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules3.scm,v 4.11 1988/11/01 04:58:20 jinx Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
(LAP ,@(clear-map!)
(BRA (@PCR ,label))))
+(define-rule statement
+ (INVOCATION:COMPUTED-JUMP (? frame-size) (? continuation))
+ frame-size continuation
+ ;; It expects the procedure at the top of the stack
+ (LAP ,@(clear-map!)
+ (CLR B (@A 7))
+ (RTS)))
+
(define-rule statement
(INVOCATION:LEXPR (? number-pushed) (? continuation) (? label))
continuation
(LEA (@PCR ,label) (A 0))
(JMP ,entry:compiler-lexpr-apply)))
+(define-rule statement
+ (INVOCATION:COMPUTED-LEXPR (? number-pushed) (? continuation))
+ continuation
+ ;; It expects the procedure at the top of the stack
+ (LAP ,@(clear-map!)
+ ,(load-dnw number-pushed 0)
+ (CLR B (@A 7))
+ (MOV L (@A+ 7) (A 0))
+ (JMP ,entry:compiler-lexpr-apply)))
+
(define-rule statement
(INVOCATION:UUO-LINK (? frame-size) (? continuation) (? name))
continuation
(LABEL ,label)
,@(generate/move-frame-up* frame-size temp)))))
+(define-rule statement
+ (INVOCATION-PREFIX:DYNAMIC-LINK (? frame-size)
+ (REGISTER (? source))
+ (REGISTER 12))
+ (QUALIFIER (pseudo-register? source))
+ (let ((areg (move-to-temporary-register! source 'ADDRESS))
+ (label (generate-label)))
+ (LAP (CMP L ,areg (A 4))
+ (B HS B (@PCR ,label))
+ (MOV L (A 4) ,areg)
+ (LABEL ,label)
+ ,@(generate/move-frame-up* frame-size
+ (+ (lap:ea-operand-1 areg) 8)))))
+
(define (generate/move-frame-up frame-size destination)
(let ((temp (allocate-temporary-register! 'ADDRESS)))
(LAP (LEA ,destination ,(register-reference temp))
(define-rule statement
(OPEN-PROCEDURE-HEADER (? internal-label))
- (simple-procedure-header internal-entry-code-word
- internal-label
- entry:compiler-interrupt-procedure))
+ (LAP ,@(let ((external-label (rtl-procedure/%external-label
+ (label->object internal-label))))
+ (if external-label
+ (LAP (EQUATE ,external-label ,internal-label))
+ (LAP)))
+ ,@(simple-procedure-header internal-entry-code-word
+ internal-label
+ entry:compiler-interrupt-procedure)))
(define-rule statement
(PROCEDURE-HEADER (? internal-label) (? min) (? max))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlexp.scm,v 4.8 1988/09/02 15:01:08 markf Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlexp.scm,v 4.9 1988/11/01 04:52:48 jinx Exp $
Copyright (c) 1987, 1988 Massachusetts Institute of Technology
(memq (rtl:expression-type rtl)
'(INVOCATION:APPLY
INVOCATION:JUMP
+ INVOCATION:COMPUTED-JUMP
INVOCATION:LEXPR
+ INVOCATION:COMPUTED-LEXPR
INVOCATION:PRIMITIVE
INVOCATION:SPECIAL-PRIMITIVE
INVOCATION:UUO-LINK
OBJECT->ADDRESS
OBJECT->DATUM
OBJECT->FIXNUM
+ ADDRESS->FIXNUM
+ FIXNUM->ADDRESS
OBJECT->TYPE
OFFSET-ADDRESS
VARIABLE-CACHE))))
(define (rtl:expand-statement statement expander finish)
(let loop ((subexpressions (cdr statement)) (new-subexpressions '()))
(if (null? subexpressions)
- (finish (reverse new-subexpressions))
+ (finish (reverse! new-subexpressions))
(expander (car subexpressions)
(lambda (new-subexpression)
(loop (cdr subexpressions)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlty1.scm,v 4.11 1988/10/20 18:15:40 markf Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlty1.scm,v 4.12 1988/11/01 04:53:11 jinx Exp $
Copyright (c) 1987, 1988 Massachusetts Institute of Technology
(define-rtl-statement invocation:apply rtl: pushed continuation)
(define-rtl-statement invocation:jump rtl: pushed continuation procedure)
+(define-rtl-statement invocation:computed-jump rtl: pushed continuation)
(define-rtl-statement invocation:lexpr rtl: pushed continuation procedure)
+(define-rtl-statement invocation:computed-lexpr rtl: pushed continuation)
(define-rtl-statement invocation:uuo-link rtl: pushed continuation name)
(define-rtl-statement invocation:primitive rtl: pushed continuation procedure)
(define-rtl-statement invocation:special-primitive rtl: pushed continuation
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/fndblk.scm,v 4.8 1988/08/18 01:36:46 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/fndblk.scm,v 4.9 1988/11/01 04:53:37 jinx Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
(if-compiler
(offset-locative locative (variable-offset block variable)))))
if-ic))
+ ;; This is just for paranoia.
((procedure/trivial-closure? rvalue)
(error "FIND-VARIABLE-INTERNAL: Trivial closure value encountered"))
(else
receiver))
(define (find-block/initial block offset)
- (enumeration-case block-type (block-type block)
- ((STACK)
- (stack-locative-offset (rtl:make-fetch register:stack-pointer) offset))
- ((IC)
- (rtl:make-fetch register:environment))
- (else
- (error "Illegal initial block type" block))))
+ (if (null? block)
+ (begin
+ (error "find-block/initial: Null block!" block)
+ (rtl:make-fetch register:environment))
+ (enumeration-case block-type (block-type block)
+ ((STACK)
+ (stack-locative-offset (rtl:make-fetch register:stack-pointer) offset))
+ ((IC)
+ (rtl:make-fetch register:environment))
+ (else
+ (error "Illegal initial block type" block)))))
(define (find-block/loop block end-block? locative)
- (if (or (end-block? block)
- (ic-block? block))
- (return-2 block locative)
- (find-block/loop (block-parent block)
- end-block?
- ((find-block/parent-procedure block) block locative))))
+ (cond ((null? block)
+ (error "find-block/loop: Null block!" block)
+ (return-2 block locative))
+ ((or (end-block? block)
+ (ic-block? block))
+ (return-2 block locative))
+ (else
+ (find-block/loop (block-parent block)
+ end-block?
+ ((find-block/parent-procedure block)
+ block locative)))))
(define (find-block/parent-procedure block)
(enumeration-case block-type (block-type block)
(else (error "Illegal procedure parent" parent)))
(error "Block has no parent" block)))
((procedure/trivial-closure? (block-procedure block))
+#|
+ ;; This case cannot signal an error because of the way that
+ ;; find-block/loop is written. The locative for the
+ ;; parent is needed, although it will be ignored by the
+ ;; receiver once it finds out that the block is
+ ;; ic/non-existent. The references are found by using
+ ;; the variable caches.
+ (error "Block corresponds to trivial closure")
+|#
trivial-closure/bogus-locative)
((not parent)
(error "Block has no parent" block))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/opncod.scm,v 4.15 1988/10/20 17:22:35 markf Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/opncod.scm,v 4.16 1988/11/01 04:53:58 jinx Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
(let ((inliner (analyze-combination application)))
(set-combination/inliner! application inliner)
;; Don't push a return address on the stack
- ;; if: (1) the combination is inline coded,
- ;; (2) the continuation is known, and (3) the
- ;; push is unique for this combination.
- (let ((push
- (combination/continuation-push application)))
- (if (and inliner
- push
- (rvalue-known-value
- (combination/continuation application)))
- (set-virtual-continuation/type!
- (virtual-return-operator push)
- continuation-type/effect))))))
+ ;; if: (1) the combination is inline coded,
+ ;; (2) the continuation is known, and (3) the
+ ;; push is unique for this combination.
+ (let ((push
+ (combination/continuation-push application)))
+ (if (and inliner
+ push
+ (rvalue-known-value
+ (combination/continuation application)))
+ (set-virtual-continuation/type!
+ (virtual-return-operator push)
+ continuation-type/effect))))))
(lambda (application)
(if (eq? (application-type application) 'COMBINATION)
(set-combination/inliner! application false))))
(let ((offset (node/offset combination)))
(generate/return* (combination/block combination)
(combination/continuation combination)
- (combination/continuation-push combination)
+ (combination/continuation-push combination)
(let ((inliner (combination/inliner combination)))
(let ((handler (inliner/handler inliner))
(generator (inliner/generator inliner))
(rtl:make-constant (constant-value value)))
((and value
(rvalue/procedure? value)
- (procedure/closure? value)
- (procedure/trivial-closure? value))
+ (procedure/trivial-or-virtual? value))
(make-trivial-closure-cons value))
((and (rvalue/reference? rvalue)
(not (variable/value-variable? (reference-lvalue rvalue)))
(finish (rtl:make-fetch temporary)))))
\f
(let* ((open-code/memory-ref
- (lambda (index)
+ (lambda (index)
(lambda (expressions finish)
(finish
(rtl:make-fetch
(define-open-coder/value name
(lambda (operands)
(or (filter/nonnegative-integer (cadr operands)
- (lambda (index)
+ (lambda (index)
(return-2
(open-code/constant-vector-ref name (1+ index))
'(0 1))))
give-it-up))
(generic-2
;; op1 is a fixnum, op2 is not
- (pcfg*scfg->scfg!
- (generate-type-test 'flonum op2)
- ;; Whem we have open coded flonums we
- ;; will convert op1 to a float and do a
- ;; floating op.
- generic-flonum
- give-it-up))
+ (if compiler:open-code-flonum-checks?
+ (pcfg*scfg->scfg!
+ (generate-type-test 'flonum op2)
+ ;; Whem we have open coded flonums we
+ ;; will convert op1 to a float and do a
+ ;; floating op.
+ generic-flonum
+ give-it-up)
+ give-it-up))
(generic-1
;; op1 is not a fixnum, op2 unknown
- (pcfg*scfg->scfg!
- (generate-type-test 'flonum op1)
- (pcfg*scfg->scfg!
- (generate-type-test 'flonum op2)
- ;; For now we will just call the generic op.
- ;; When we have open coded flonums, we will
- ;; stick that stuff here.
- generic-flonum
- generic-3)
- give-it-up)))
+ (if compiler:open-code-flonum-checks?
+ (pcfg*scfg->scfg!
+ (generate-type-test 'flonum op1)
+ (pcfg*scfg->scfg!
+ (generate-type-test 'flonum op2)
+ ;; For now we will just call the generic op.
+ ;; When we have open coded flonums, we will
+ ;; stick that stuff here.
+ generic-flonum
+ generic-3)
+ give-it-up)
+ give-it-up)))
(if (or (default-object? is-pred?)
(not is-pred?))
(pcfg*scfg->scfg!
give-it-up
(finish (rtl:make-fixnum->object
fix-temp))))
- (pcfg*scfg->scfg!
- (generate-type-test 'flonum op)
- generic-flonum
- give-it-up))
+ (if compiler:open-code-flonum-checks?
+ (pcfg*scfg->scfg!
+ (generate-type-test 'flonum op)
+ generic-flonum
+ give-it-up)
+ give-it-up))
(pcfg*scfg->scfg!
(generate-type-test 'fixnum op)
(finish
(rtl:make-fixnum-pred-1-arg
fix-op
(rtl:make-object->fixnum op)))
- (pcfg*scfg->scfg!
- (generate-type-test 'flonum op)
- generic-flonum
- give-it-up)))))))
+ (if compiler:open-code-flonum-checks?
+ (pcfg*scfg->scfg!
+ (generate-type-test 'flonum op)
+ generic-flonum
+ give-it-up)
+ give-it-up)))))))
\f
(define (generic->fixnum-op generic-op)
(case generic-op
(define-open-coder/value generic-op
(lambda (operands)
(return-2
- (lambda (expressions finish)
+ (lambda (expressions finish)
(generate-generic-binary
(rtl:make-generic-binary
generic-op
(define-open-coder/value generic-op
(lambda (operand)
(return-2
- (lambda (expression finish)
+ (lambda (expression finish)
(generate-generic-unary
(rtl:make-generic-unary
generic-op
(define-open-coder/predicate generic-op
(lambda (operands)
(return-2
- (lambda (expressions finish)
+ (lambda (expressions finish)
(generate-generic-binary
(rtl:make-generic-binary
generic-op
(define-open-coder/predicate generic-op
(lambda (operand)
(return-2
- (lambda (expression finish)
+ (lambda (expression finish)
(generate-generic-unary
(rtl:make-generic-unary
generic-op
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgcomb.scm,v 4.6 1988/09/14 06:38:12 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgcomb.scm,v 4.7 1988/11/01 04:54:28 jinx Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
(frame-size (combination/frame-size combination))
(continuation (combination/continuation combination))
(offset (node/offset combination)))
- (let ((callee (rvalue-known-value operator)))
- (let ((finish
- (lambda (invocation callee-external?)
- (invocation operator
- offset
- frame-size
- (and (return-operator/subproblem? continuation)
- (not (continuation/always-known-operator?
- continuation))
- (continuation/label continuation))
- (generate/invocation-prefix block
- callee
- continuation
- callee-external?)))))
- (cond ((not callee)
- (finish (if (reference? operator)
- invocation/reference
- invocation/apply)
- true))
- ((rvalue/constant? callee)
- (finish
- (if (normal-primitive-procedure? (constant-value callee))
- invocation/primitive
- invocation/apply)
- true))
- ((rvalue/procedure? callee)
- (case (procedure/type callee)
- ((OPEN-EXTERNAL) (finish invocation/jump true))
- ((OPEN-INTERNAL) (finish invocation/jump false))
- ((CLOSURE)
- ;; *** For the time being, known lexpr closures are
- ;; invoked through apply. This makes the code
- ;; simpler and probably does not matter much. ***
- (if (procedure-rest callee)
- (finish invocation/apply true)
- (finish invocation/jump true)))
- ((IC) (finish invocation/ic true))
- (else (error "Unknown procedure type" callee))))
- (else
- (finish invocation/apply true)))))))
+ (let* ((callee (rvalue-known-value operator))
+ (callee-model (or callee (combination/model combination)))
+ (finish
+ (lambda (invocation callee-external?)
+ (invocation callee-model
+ operator
+ offset
+ frame-size
+ (and (return-operator/subproblem? continuation)
+ (not (continuation/always-known-operator?
+ continuation))
+ (continuation/label continuation))
+ (generate/invocation-prefix block
+ callee-model
+ continuation
+ callee-external?)))))
+ (cond ((not callee-model)
+ (finish (if (reference? operator)
+ invocation/reference
+ invocation/apply)
+ true))
+ ((and callee (rvalue/constant? callee))
+ (finish
+ (if (normal-primitive-procedure? (constant-value callee))
+ invocation/primitive
+ invocation/apply)
+ true))
+ ((rvalue/procedure? callee-model)
+ (case (procedure/type callee-model)
+ ((OPEN-EXTERNAL) (finish invocation/jump true))
+ ((OPEN-INTERNAL) (finish invocation/jump false))
+ ((CLOSURE)
+ ;; *** For the time being, known lexpr closures are
+ ;; invoked through apply. This makes the code
+ ;; simpler and probably does not matter much. ***
+ (if (procedure-rest callee-model)
+ (finish invocation/apply true)
+ (finish invocation/jump true)))
+ ((IC) (finish invocation/ic true))
+ (else (error "Unknown procedure type" callee-model))))
+ (else
+ (finish invocation/apply true))))))
\f
;;;; Invocations
-(define (invocation/jump operator offset frame-size continuation prefix)
+(define (invocation/jump model operator offset frame-size continuation prefix)
(let ((callee (rvalue-known-value operator)))
(scfg*scfg->scfg!
(prefix offset frame-size)
- (if (procedure-inline-code? callee)
- (generate/procedure-entry/inline callee)
- (begin
- (enqueue-procedure! callee)
- ((if (procedure-rest callee)
- rtl:make-invocation:lexpr
- rtl:make-invocation:jump)
- frame-size
- continuation
- (procedure-label callee)))))))
+ (cond ((not callee)
+ (if (not model)
+ (error "invocation/jump: Going to hyperspace!"))
+ ((if (procedure-rest model)
+ rtl:make-invocation:computed-lexpr
+ rtl:make-invocation:computed-jump)
+ frame-size
+ continuation))
+ ((procedure-inline-code? callee)
+ (generate/procedure-entry/inline callee))
+ (else
+ (enqueue-procedure! callee)
+ ((if (procedure-rest callee)
+ rtl:make-invocation:lexpr
+ rtl:make-invocation:jump)
+ frame-size
+ continuation
+ (procedure-label callee)))))))
-(define (invocation/apply operator offset frame-size continuation prefix)
- operator
+(define (invocation/apply model operator offset frame-size continuation prefix)
+ model operator ; ignored
(invocation/apply* offset frame-size continuation prefix))
(define (invocation/apply* offset frame-size continuation prefix)
;; sibling, self-recursion, or an ancestor.
invocation/apply)
-(define (invocation/primitive operator offset frame-size continuation prefix)
+(define (invocation/primitive model operator offset frame-size
+ continuation prefix)
+ model ; ignored
(scfg*scfg->scfg!
(prefix offset frame-size)
(let ((primitive (constant-value (rvalue-known-value operator))))
\f
(package (invocation/reference)
-(define-export (invocation/reference operator offset frame-size continuation
- prefix)
+(define-export (invocation/reference model operator offset frame-size
+ continuation prefix)
+ model ; ignored
(if (reference-to-known-location? operator)
(invocation/apply* offset frame-size continuation prefix)
(let ((block (reference-block operator))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgproc.scm,v 4.3 1988/04/15 02:04:53 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgproc.scm,v 4.4 1988/11/01 04:55:01 jinx Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
(rtl:make-ic-procedure-header (procedure-label procedure)))
(setup-ic-frame procedure))
(scfg*scfg->scfg!
- (cond ((procedure/closure? procedure)
- (if (procedure/trivial-closure? procedure)
- (with-procedure-arity-encoding
- procedure
- (lambda (min max)
- (rtl:make-procedure-header (procedure-label procedure)
- min max)))
- (rtl:make-closure-header (procedure-label procedure))))
- (inline?
+ (cond (inline?
+ ;; Paranoia
+ (if (not (procedure/virtually-open? procedure))
+ (error "Inlining a real closure!" procedure))
(make-null-cfg))
+ ((procedure/closure? procedure)
+ (cond ((not (procedure/trivial-closure? procedure))
+ (rtl:make-closure-header (procedure-label procedure)))
+ ((or (procedure-rest procedure)
+ (closure-procedure-needs-external-descriptor?
+ procedure))
+ (with-procedure-arity-encoding
+ procedure
+ (lambda (min max)
+ (rtl:make-procedure-header (procedure-label procedure)
+ min max))))
+ (else
+ ;; It's not an open procedure but it looks like one
+ ;; at the rtl level.
+ (rtl:make-open-procedure-header
+ (procedure-label procedure)))))
((procedure-rest procedure)
(with-procedure-arity-encoding
procedure
(scfg*->scfg!
(map (lambda (name value)
(if (and (procedure? value)
- (procedure/closure? value)
- (not (procedure/trivial-closure? value)))
+ (not (procedure/trivial-or-virtual? value)))
(letrec-close block name value)
(make-null-cfg)))
names values))))))
(case (procedure/type value)
((CLOSURE)
(if (procedure/trivial-closure? value)
- (recvr (make-null-cfg)
- (make-trivial-closure-cons value))
+ (begin
+ (error "Letrec value is trivial closure" value)
+ (recvr (make-null-cfg)
+ (make-trivial-closure-cons value)))
(recvr (make-non-trivial-closure-cons value)
(rtl:interpreter-call-result:enclose))))
((IC)
d3 1
a4 1
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgrval.scm,v 4.7 1988/06/14 08:42:56 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgrval.scm,v 4.8 1988/11/01 04:55:26 jinx Exp $
#| -*-Scheme-*-
Copyright (c) 1988 Massachusetts Institute of Technology
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgrval.scm,v 4.7 1988/06/14 08:42:56 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgrval.scm,v 4.8 1988/11/01 04:55:26 jinx Exp $
Copyright (c) 1988, 1990 Massachusetts Institute of Technology
(cond ((not value) (perform-fetch))
lvalue))
(generate/rvalue* value offset))
- ((and (procedure/closure? value)
- (procedure/trivial-closure? value))
+ ((not (rvalue/procedure? value))
(generate/rvalue* value))
(else (perform-fetch)))))))
\f
(make-ic-cons procedure offset
(lambda (scfg expr) (return-2 scfg expr))))
(make-cons-closure-indirection procedure)))))
- (error "Reference to open procedure" procedure))
+ ((IC)
+ (make-ic-cons procedure))
+ ((OPEN-EXTERNAL OPEN-INTERNAL)
(if (not (procedure-virtual-closure? procedure))
(error "Reference to open procedure" procedure))
;; inside another IC procedure?
(loop (cdr entries)
(scfg*scfg->scfg!
(rtl:make-assignment
- (cond ;; This is a waste.
- ;; It should be integrated.
- ((and value
- (rvalue/procedure? value)
- (procedure/closure? value)
- (procedure/trivial-closure? value))
- (make-trivial-closure-cons value))
- ((not (eq? value (block-procedure
- closure-block)))
- (rtl:make-fetch
- (find-closure-variable closure-block
- variable
- offset)))
- (else
- (rtl:make-fetch
- (block-closure-locative closure-block
- offset))))))
+ (rtl:locative-offset closure-locative
+ (cdar entries))
+ (let* ((variable (caar entries))
+ (value (lvalue-known-value variable)))
+ (cond
+ ;; Paranoia.
+ ((and value
+ (rvalue/procedure? value)
+ ((not (eq? value (block-procedure
+ closure-block)))
+ value variable))
+ (find-closure-variable closure-block
+ variable
+ offset)))
+ ((eq? value
+ (rtl:make-fetch
+ (block-closure-locative closure-block
+ offset))))))
code))))
(loop
)
\f
(define (make-trivial-closure-cons procedure)
+ (enqueue-procedure! procedure)
(rtl:make-cons-pointer
(rtl:make-constant type-code:compiled-entry)
(rtl:make-entry:procedure (procedure-label procedure))))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcse1.scm,v 4.11 1988/08/11 20:10:34 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcse1.scm,v 4.12 1988/11/01 04:55:53 jinx Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
statement
unspecific)
+(define-cse-method 'OVERFLOW-TEST method/noop)
+
(define-cse-method 'POP-RETURN method/noop)
(define-cse-method 'CONTINUATION-ENTRY method/noop)
(define-cse-method 'INVOCATION:APPLY method/noop)
(define-cse-method 'INVOCATION:JUMP method/noop)
+(define-cse-method 'INVOCATION:COMPUTED-JUMP method/noop)
(define-cse-method 'INVOCATION:LEXPR method/noop)
+(define-cse-method 'INVOCATION:COMPUTED-LEXPR method/noop)
(define-cse-method 'INVOCATION:UUO-LINK method/noop)
(define-cse-method 'INVOCATION:PRIMITIVE method/noop)
(define-cse-method 'INVOCATION:SPECIAL-PRIMITIVE method/noop)
projects / mit-scheme.git / commitdiff