From: Guillermo J. Rozas Date: Tue, 1 Nov 1988 04:58:20 +0000 (+0000) Subject: - "Self consistent closing": A group of procedures whose only free X-Git-Tag: 20090517-FFI~12469 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=6ec7f47ec7ac3231e76a40a30f89116808409e49;p=mit-scheme.git - "Self consistent closing": A group of procedures whose only free variables represent each other will be represented as trivial closures that reference each other by direct pc offsets. - Known trivial closure variables are now integrated. - Similar procedures used in operator position may not be closed. There is a notion of a virtual closure: A closure whose environment is known, but whose code pointer is not. - Procedures now remember why they were closed. - Once-only assignments to top-level or completely free variables are done with local-assignment rather than with assignment caches. - Variuos fixes to the closure analysis. Lambda expressions in operand position are closed only if they are escaping their context. This was broken when the uniform closing strategy (all closures close to the top) was introduced in the front end. --- diff --git a/v7/src/compiler/base/blocks.scm b/v7/src/compiler/base/blocks.scm index 0c56140be..fd4e0e523 100644 --- a/v7/src/compiler/base/blocks.scm +++ b/v7/src/compiler/base/blocks.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -141,7 +141,9 @@ from the continuation, and then "glued" into place afterwards. )) (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)) @@ -213,6 +215,12 @@ from the continuation, and then "glued" into place afterwards. (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)) (define (stack-block/external-ancestor block) (let ((parent (block-parent block))) diff --git a/v7/src/compiler/base/ctypes.scm b/v7/src/compiler/base/ctypes.scm index 0dd52bb98..7b5380db7 100644 --- a/v7/src/compiler/base/ctypes.scm +++ b/v7/src/compiler/base/ctypes.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/ctypes.scm,v 4.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 @@ -48,6 +48,7 @@ MIT in each case. |# 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*) @@ -56,7 +57,7 @@ MIT in each case. |# (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) @@ -114,6 +115,8 @@ MIT in each case. |# (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))) diff --git a/v7/src/compiler/base/lvalue.scm b/v7/src/compiler/base/lvalue.scm index cedc1be30..0e664beba 100644 --- a/v7/src/compiler/base/lvalue.scm +++ b/v7/src/compiler/base/lvalue.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/lvalue.scm,v 4.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 @@ -36,6 +36,10 @@ MIT in each case. |# (declare (usual-integrations)) +;; 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 @@ -46,6 +50,7 @@ MIT in each case. |# 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', @@ -205,15 +210,7 @@ MIT in each case. |# (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)))))) (define (lvalue=? lvalue lvalue*) (or (eq? lvalue lvalue*) diff --git a/v7/src/compiler/base/macros.scm b/v7/src/compiler/base/macros.scm index d05606332..d4dabaa19 100644 --- a/v7/src/compiler/base/macros.scm +++ b/v7/src/compiler/base/macros.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -176,7 +176,7 @@ MIT in each case. |# (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. @@ -200,7 +200,7 @@ MIT in each case. |# (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)))) @@ -210,29 +210,27 @@ MIT in each case. |# (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))) diff --git a/v7/src/compiler/base/proced.scm b/v7/src/compiler/base/proced.scm index 4a7501517..0a190fdb3 100644 --- a/v7/src/compiler/base/proced.scm +++ b/v7/src/compiler/base/proced.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/proced.scm,v 4.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 @@ -51,12 +51,19 @@ MIT in each case. |# 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*) @@ -70,7 +77,7 @@ MIT in each case. |# (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)) @@ -105,6 +112,9 @@ MIT in each case. |# (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))) @@ -145,9 +155,10 @@ MIT in each case. |# (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))) @@ -220,4 +231,58 @@ MIT in each case. |# (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)))) + +(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 diff --git a/v7/src/compiler/base/switch.scm b/v7/src/compiler/base/switch.scm index be81143d9..5ccd10318 100644 --- a/v7/src/compiler/base/switch.scm +++ b/v7/src/compiler/base/switch.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/switch.scm,v 4.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 @@ -43,15 +43,15 @@ MIT in each case. |# (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 diff --git a/v7/src/compiler/base/toplev.scm b/v7/src/compiler/base/toplev.scm index cf462ecfb..7b56170c0 100644 --- a/v7/src/compiler/base/toplev.scm +++ b/v7/src/compiler/base/toplev.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/toplev.scm,v 4.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 @@ -422,6 +422,7 @@ MIT in each case. |# (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) @@ -456,6 +457,11 @@ MIT in each case. |# (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 () diff --git a/v7/src/compiler/fggen/canon.scm b/v7/src/compiler/fggen/canon.scm index 61db428c1..f5b92799b 100644 --- a/v7/src/compiler/fggen/canon.scm +++ b/v7/src/compiler/fggen/canon.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -40,18 +40,15 @@ MIT in each case. |# (declare (usual-integrations)) -;;;; 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. @@ -66,7 +63,39 @@ HIGH: package bodies are treated as top level expressions to be 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. |# + +;;;; 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) @@ -142,7 +171,8 @@ HIGH: package bodies are treated as top level expressions to be ;;;; 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) @@ -179,7 +209,7 @@ HIGH: package bodies are treated as top level expressions to be (recvr (scode/quotation-expression (car operands))) (normal)))) (normal))))) - + (cond ((scode/variable? body) (let ((name (scode/variable-name body))) (if (eq? name environment-variable) @@ -202,8 +232,6 @@ HIGH: package bodies are treated as top level expressions to be ((scode/comment? body) (comment body (lambda (nbody) nbody))) (else (normal)))) - -;;;; Hairy expressions (define (combine-list elements) (if (null? elements) @@ -212,6 +240,8 @@ HIGH: package bodies are treated as top level expressions to be (car elements) (combine-list (cdr elements))))) +;;; Expressions + (define canonicalize/constant canonicalize/trivial) (define (canonicalize/error operator operands bound context) @@ -221,6 +251,20 @@ HIGH: package bodies are treated as top level expressions to be (list (canonicalize/expression (car operands) bound context) (canonicalize/expression (cadr operands) bound context) (canonicalize/trivial (caddr operands) bound context))))) + +;;;; 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))) @@ -242,7 +286,7 @@ HIGH: package bodies are treated as top level expressions to be 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)) @@ -256,9 +300,10 @@ HIGH: package bodies are treated as top level expressions to be (list (scode/make-variable environment-variable) name (canout-expr value))) - (canout-safe? value) true false))))))) + (canout-safe? value) + true false))))))) -;;;; More hairy expressions +;;;; Hairy expressions (define (canonicalize/definition expression bound context) (scode/definition-components expression @@ -462,6 +507,8 @@ HIGH: package bodies are treated as top level expressions to be 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) diff --git a/v7/src/compiler/fggen/fggen.scm b/v7/src/compiler/fggen/fggen.scm index 9fc4c3ca1..44ca47740 100644 --- a/v7/src/compiler/fggen/fggen.scm +++ b/v7/src/compiler/fggen/fggen.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -735,7 +735,7 @@ MIT in each case. |# (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)) diff --git a/v7/src/compiler/fgopt/blktyp.scm b/v7/src/compiler/fgopt/blktyp.scm index 2b8451e13..b2c44aba0 100644 --- a/v7/src/compiler/fgopt/blktyp.scm +++ b/v7/src/compiler/fgopt/blktyp.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/blktyp.scm,v 4.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 @@ -67,27 +67,33 @@ MIT in each case. |# (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)))))) (define (find-closure-bindings receiver) (define (find-internal block) @@ -105,9 +111,15 @@ MIT in each case. |# (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)) diff --git a/v7/src/compiler/fgopt/closan.scm b/v7/src/compiler/fgopt/closan.scm index 899608c55..98c504b51 100644 --- a/v7/src/compiler/fgopt/closan.scm +++ b/v7/src/compiler/fgopt/closan.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/closan.scm,v 4.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 @@ -76,8 +76,8 @@ result, the analysis has been modified to force the closure-limit to (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)) @@ -87,61 +87,171 @@ result, the analysis has been modified to force the closure-limit to (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))) + +(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))))))) -(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)) + +(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))))))))))))) + +(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 diff --git a/v7/src/compiler/fgopt/offset.scm b/v7/src/compiler/fgopt/offset.scm index 9611fbebf..91f5669fe 100644 --- a/v7/src/compiler/fgopt/offset.scm +++ b/v7/src/compiler/fgopt/offset.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -121,6 +121,14 @@ MIT in each case. |# ((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)))) diff --git a/v7/src/compiler/fgopt/order.scm b/v7/src/compiler/fgopt/order.scm index 33a4bf223..d21f8e9f1 100644 --- a/v7/src/compiler/fgopt/order.scm +++ b/v7/src/compiler/fgopt/order.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -152,7 +152,8 @@ MIT in each case. |# (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)) @@ -165,24 +166,24 @@ MIT in each case. |# 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))) @@ -200,7 +201,8 @@ MIT in each case. |# (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). @@ -210,7 +212,9 @@ MIT in each case. |# (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 diff --git a/v7/src/compiler/machines/bobcat/compiler.pkg b/v7/src/compiler/machines/bobcat/compiler.pkg index 789d96bfb..501a24391 100644 --- a/v7/src/compiler/machines/bobcat/compiler.pkg +++ b/v7/src/compiler/machines/bobcat/compiler.pkg @@ -1,6 +1,6 @@ #| -*-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 @@ -192,6 +192,7 @@ MIT in each case. |# "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 @@ -210,6 +211,7 @@ MIT in each case. |# identify-closure-limits! operator-analysis outer-analysis + optimize-environments! setup-block-types! simplicity-analysis simulate-application @@ -228,18 +230,17 @@ MIT in each case. |# "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 @@ -258,14 +259,12 @@ MIT in each case. |# "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") diff --git a/v7/src/compiler/machines/bobcat/compiler.sf b/v7/src/compiler/machines/bobcat/compiler.sf index 1c6014110..2d536dfd0 100644 --- a/v7/src/compiler/machines/bobcat/compiler.sf +++ b/v7/src/compiler/machines/bobcat/compiler.sf @@ -1,6 +1,6 @@ #| -*-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 @@ -34,6 +34,9 @@ MIT in each case. |# ;;;; Script to incrementally syntax the compiler +(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")))) @@ -98,4 +101,5 @@ MIT in each case. |# ;; 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 diff --git a/v7/src/compiler/machines/bobcat/dassm2.scm b/v7/src/compiler/machines/bobcat/dassm2.scm index ecfafa068..5d3c70db4 100644 --- a/v7/src/compiler/machines/bobcat/dassm2.scm +++ b/v7/src/compiler/machines/bobcat/dassm2.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -144,9 +144,9 @@ MIT in each case. |# (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)) ;;;; Compiler specific information diff --git a/v7/src/compiler/machines/bobcat/decls.scm b/v7/src/compiler/machines/bobcat/decls.scm index 9496eaaba..9ba2ca1f8 100644 --- a/v7/src/compiler/machines/bobcat/decls.scm +++ b/v7/src/compiler/machines/bobcat/decls.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/decls.scm,v 4.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 @@ -182,13 +182,17 @@ MIT in each case. |# (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 @@ -197,17 +201,34 @@ MIT in each case. |# (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) @@ -220,7 +241,7 @@ MIT in each case. |# source-nodes/by-rank) (for-each source-node/maybe-syntax! source-nodes/by-rank) (for-each source-node/maybe-syntax! source-nodes/circular-dependencies)) - + (define (source-node/maybe-syntax! node) (if (not (source-node/modification-time node)) (source-node/syntax! node))) @@ -279,8 +300,8 @@ MIT in each case. |# "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") @@ -289,8 +310,7 @@ MIT in each case. |# "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" @@ -413,8 +433,9 @@ MIT in each case. |# (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 @@ -425,7 +446,7 @@ MIT in each case. |# (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) diff --git a/v7/src/compiler/machines/bobcat/make.scm-68040 b/v7/src/compiler/machines/bobcat/make.scm-68040 index 8ac675770..6a9c4baef 100644 --- a/v7/src/compiler/machines/bobcat/make.scm-68040 +++ b/v7/src/compiler/machines/bobcat/make.scm-68040 @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 4.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 @@ -41,4 +41,4 @@ MIT in each case. |# ((package/reference (find-package name) 'INITIALIZE-PACKAGE!))) '((COMPILER MACROS) (COMPILER DECLARATIONS))) -(add-system! (make-system "Liar" 4 25 '())) \ No newline at end of file +(add-system! (make-system "Liar" 4 26 '())) \ No newline at end of file diff --git a/v7/src/compiler/machines/bobcat/rules3.scm b/v7/src/compiler/machines/bobcat/rules3.scm index 3c5984210..bf45461f4 100644 --- a/v7/src/compiler/machines/bobcat/rules3.scm +++ b/v7/src/compiler/machines/bobcat/rules3.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -57,6 +57,14 @@ MIT in each case. |# (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 @@ -65,6 +73,16 @@ MIT in each case. |# (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 @@ -224,6 +242,20 @@ MIT in each case. |# (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)) @@ -327,9 +359,14 @@ MIT in each case. |# (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)) diff --git a/v7/src/compiler/rtlbase/rtlexp.scm b/v7/src/compiler/rtlbase/rtlexp.scm index 81e36705f..57b6a5cc3 100644 --- a/v7/src/compiler/rtlbase/rtlexp.scm +++ b/v7/src/compiler/rtlbase/rtlexp.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -40,7 +40,9 @@ MIT in each case. |# (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 @@ -67,6 +69,8 @@ MIT in each case. |# OBJECT->ADDRESS OBJECT->DATUM OBJECT->FIXNUM + ADDRESS->FIXNUM + FIXNUM->ADDRESS OBJECT->TYPE OFFSET-ADDRESS VARIABLE-CACHE)))) @@ -152,7 +156,7 @@ MIT in each case. |# (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) diff --git a/v7/src/compiler/rtlbase/rtlty1.scm b/v7/src/compiler/rtlbase/rtlty1.scm index 3455072e0..aabac5305 100644 --- a/v7/src/compiler/rtlbase/rtlty1.scm +++ b/v7/src/compiler/rtlbase/rtlty1.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -101,7 +101,9 @@ MIT in each case. |# (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 diff --git a/v7/src/compiler/rtlgen/fndblk.scm b/v7/src/compiler/rtlgen/fndblk.scm index e8959f0dc..84372738b 100644 --- a/v7/src/compiler/rtlgen/fndblk.scm +++ b/v7/src/compiler/rtlgen/fndblk.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -87,6 +87,7 @@ MIT in each case. |# (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 @@ -167,21 +168,30 @@ MIT in each case. |# 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) @@ -196,6 +206,15 @@ MIT in each case. |# (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)) diff --git a/v7/src/compiler/rtlgen/opncod.scm b/v7/src/compiler/rtlgen/opncod.scm index d931eca1c..da663b111 100644 --- a/v7/src/compiler/rtlgen/opncod.scm +++ b/v7/src/compiler/rtlgen/opncod.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -47,18 +47,18 @@ MIT in each case. |# (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)))) @@ -91,7 +91,7 @@ MIT in each case. |# (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)) @@ -123,8 +123,7 @@ MIT in each case. |# (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))) @@ -440,7 +439,7 @@ MIT in each case. |# (finish (rtl:make-fetch temporary))))) (let* ((open-code/memory-ref - (lambda (index) + (lambda (index) (lambda (expressions finish) (finish (rtl:make-fetch @@ -499,7 +498,7 @@ MIT in each case. |# (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)))) @@ -729,25 +728,29 @@ MIT in each case. |# 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! @@ -828,20 +831,24 @@ MIT in each case. |# 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))))))) (define (generic->fixnum-op generic-op) (case generic-op @@ -881,7 +888,7 @@ MIT in each case. |# (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 @@ -898,7 +905,7 @@ MIT in each case. |# (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 @@ -914,7 +921,7 @@ MIT in each case. |# (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 @@ -932,7 +939,7 @@ MIT in each case. |# (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 diff --git a/v7/src/compiler/rtlgen/rgcomb.scm b/v7/src/compiler/rtlgen/rgcomb.scm index 5cbd45056..f7578b25d 100644 --- a/v7/src/compiler/rtlgen/rgcomb.scm +++ b/v7/src/compiler/rtlgen/rgcomb.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -49,66 +49,76 @@ MIT in each case. |# (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)))))) ;;;; 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) @@ -121,7 +131,9 @@ MIT in each case. |# ;; 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)))) @@ -133,8 +145,9 @@ MIT in each case. |# (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)) diff --git a/v7/src/compiler/rtlgen/rgproc.scm b/v7/src/compiler/rtlgen/rgproc.scm index df42d1095..0739a0422 100644 --- a/v7/src/compiler/rtlgen/rgproc.scm +++ b/v7/src/compiler/rtlgen/rgproc.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -47,16 +47,27 @@ MIT in each case. |# (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 @@ -109,8 +120,7 @@ MIT in each case. |# (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)))))) @@ -141,8 +151,10 @@ MIT in each case. |# (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) diff --git a/v7/src/compiler/rtlgen/rgrval.scm b/v7/src/compiler/rtlgen/rgrval.scm index ce0fa7a77..0c63dab51 100644 --- a/v7/src/compiler/rtlgen/rgrval.scm +++ b/v7/src/compiler/rtlgen/rgrval.scm @@ -1,9 +1,9 @@ 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 @@ -102,8 +102,7 @@ promotional, or sales literature without prior written consent from (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))))))) @@ -167,7 +166,9 @@ promotional, or sales literature without prior written consent from (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? @@ -207,23 +208,24 @@ promotional, or sales literature without prior written consent from (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 @@ -273,6 +275,7 @@ promotional, or sales literature without prior written consent from ) (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)))) diff --git a/v7/src/compiler/rtlopt/rcse1.scm b/v7/src/compiler/rtlopt/rcse1.scm index 61e25cff7..e1d615fd8 100644 --- a/v7/src/compiler/rtlopt/rcse1.scm +++ b/v7/src/compiler/rtlopt/rcse1.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -280,6 +280,8 @@ MIT in each case. |# statement unspecific) +(define-cse-method 'OVERFLOW-TEST method/noop) + (define-cse-method 'POP-RETURN method/noop) (define-cse-method 'CONTINUATION-ENTRY method/noop) @@ -291,7 +293,9 @@ MIT in each case. |# (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)