From 49be008e5d6c0596b7dcd1d2c506efbe3fb29b9c Mon Sep 17 00:00:00 2001 From: "Guillermo J. Rozas" Date: Thu, 3 May 1990 15:22:29 +0000 Subject: [PATCH] Add support for multi-closures, ie. closures with multiple (or no) entry points that share the environment "frame". --- v7/src/compiler/base/blocks.scm | 72 ++- v7/src/compiler/base/infnew.scm | 40 +- v7/src/compiler/base/lvalue.scm | 7 +- v7/src/compiler/base/proced.scm | 31 +- v7/src/compiler/base/switch.scm | 3 +- v7/src/compiler/fgopt/blktyp.scm | 502 +++++++++++++++--- v7/src/compiler/fgopt/closan.scm | 15 +- v7/src/compiler/fgopt/envopt.scm | 13 +- v7/src/compiler/fgopt/offset.scm | 62 ++- v7/src/compiler/fgopt/sideff.scm | 24 +- v7/src/compiler/fgopt/subfre.scm | 53 +- v7/src/compiler/fgopt/varind.scm | 22 +- v7/src/compiler/machines/bobcat/compiler.pkg | 15 +- v7/src/compiler/machines/bobcat/dassm2.scm | 5 +- v7/src/compiler/machines/bobcat/decls.scm | 15 +- v7/src/compiler/machines/bobcat/lapgen.scm | 58 +- v7/src/compiler/machines/bobcat/machin.scm | 45 +- .../compiler/machines/bobcat/make.scm-68040 | 4 +- v7/src/compiler/machines/bobcat/rules1.scm | 131 +++-- v7/src/compiler/machines/bobcat/rules3.scm | 169 ++++-- v7/src/compiler/machines/bobcat/rules4.scm | 18 +- v7/src/compiler/machines/bobcat/rulrew.scm | 6 +- v7/src/compiler/rtlbase/rtlcon.scm | 45 +- v7/src/compiler/rtlbase/rtlexp.scm | 22 +- v7/src/compiler/rtlbase/rtlty1.scm | 11 +- v7/src/compiler/rtlbase/rtlty2.scm | 7 +- v7/src/compiler/rtlgen/fndblk.scm | 10 +- v7/src/compiler/rtlgen/fndvar.scm | 189 ++++--- v7/src/compiler/rtlgen/opncod.scm | 8 +- v7/src/compiler/rtlgen/rgcomb.scm | 85 ++- v7/src/compiler/rtlgen/rgproc.scm | 138 +++-- v7/src/compiler/rtlgen/rgrval.scm | 240 ++++++--- v7/src/compiler/rtlgen/rgstmt.scm | 10 +- v7/src/compiler/rtlopt/rdflow.scm | 35 +- v7/src/compiler/rtlopt/rinvex.scm | 112 ++-- 35 files changed, 1656 insertions(+), 566 deletions(-) diff --git a/v7/src/compiler/base/blocks.scm b/v7/src/compiler/base/blocks.scm index ecfe469e4..8678a4fc6 100644 --- a/v7/src/compiler/base/blocks.scm +++ b/v7/src/compiler/base/blocks.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/blocks.scm,v 4.12 1989/10/26 07:35:27 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/blocks.scm,v 4.13 1990/05/03 15:04:48 jinx Rel $ -Copyright (c) 1988, 1989 Massachusetts Institute of Technology +Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -33,6 +33,7 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; Environment model data structures +;;; package: (compiler) (declare (usual-integrations)) @@ -86,9 +87,12 @@ from the continuation, and then "glued" into place afterwards. interned-variables ;alist of interned SCode variable objects closure-offsets ;for closure block, alist of bound variable offsets debugging-info ;dbg-block, if used - stack-link ;for stack block, adjacent block on stack - static-link? ;for stack block, true iff static link to parent - popping-limits ;for stack block (see continuation analysis) + (stack-link ;for stack block, adjacent block on stack + shared-block) ;for multi closures, the official block + (static-link? ;for stack block, true iff static link to parent + entry-number) ;for multi closures, entry number + (popping-limits ;for stack block (see continuation analysis) + grafted-blocks) ;for multi closures, list of blocks that share popping-limit ;for stack block (see continuation analysis) layout-frozen? ;used by frame reuse to tell parameter ;analysis not to alter this block's layout @@ -264,7 +268,7 @@ from the continuation, and then "glued" into place afterwards. (loop (block-parent block) (+ n (block-frame-size block)))))) -(define (for-each-block-descendent! block procedure) +(define (for-each-block-descendant! block procedure) (let loop ((block block)) (procedure block) (for-each loop (block-children block)))) @@ -296,13 +300,63 @@ from the continuation, and then "glued" into place afterwards. (rvalue/procedure? procedure) (procedure-target-block procedure)))) +#| (define (disown-block-child! block child) (set-block-children! block (delq! child (block-children block))) - (set-block-disowned-children! block - (cons child (block-disowned-children block))) + (if (eq? block (original-block-parent child)) + (set-block-disowned-children! block + (cons child (block-disowned-children block)))) unspecific) (define (own-block-child! block child) (set-block-parent! child block) (set-block-children! block (cons child (block-children block))) - unspecific) \ No newline at end of file + (if (eq? block (original-block-parent child)) + (set-block-disowned-children! block + (delq! child (block-disowned-children block)))) + unspecific) +|# + +(define (transfer-block-child! child block block*) + ;; equivalent to + ;; (begin + ;; (disown-block-child! block child) + ;; (own-block-child! block* child)) + ;; but faster. + (let ((original-parent (original-block-parent child))) + (set-block-children! block (delq! child (block-children block))) + (if (eq? block original-parent) + (set-block-disowned-children! + block + (cons child (block-disowned-children block)))) + (set-block-parent! child block*) + (if block* + (begin + (set-block-children! block* (cons child (block-children block*))) + (if (eq? block* original-parent) + (set-block-disowned-children! + block* + (delq! child (block-disowned-children block*)))))))) + +(define-integrable (block-number-of-entries block) + (block-entry-number block)) + +(define (closure-block-entry-number block) + (if (eq? block (block-shared-block block)) + 0 + (block-entry-number block))) + +(define (closure-block-first-offset block) + (let ((block* (block-shared-block block))) + (closure-first-offset (block-entry-number block*) + (if (eq? block block*) + 0 + (block-entry-number block))))) + +(define (block-nearest-closure-ancestor block) + (let loop ((block block) (last false)) + (and block + (if (stack-block? block) + (loop (block-parent block) block) + (and (closure-block? block) + last))))) \ No newline at end of file diff --git a/v7/src/compiler/base/infnew.scm b/v7/src/compiler/base/infnew.scm index 99b572f2a..a1506f2a5 100644 --- a/v7/src/compiler/base/infnew.scm +++ b/v7/src/compiler/base/infnew.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/infnew.scm,v 4.7 1990/01/22 23:44:42 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/infnew.scm,v 4.8 1990/05/03 15:04:52 jinx Rel $ Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology @@ -33,6 +33,7 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; Debugging Information +;;; package: (compiler debugging-information) (declare (usual-integrations)) @@ -167,10 +168,14 @@ MIT in each case. |# (define (closure-block->dbg-block block) (let ((parent (block-parent block)) + (start-offset + (closure-object-first-offset + (block-entry-number (block-shared-block block)))) (offsets (map (lambda (offset) (cons (car offset) - (- (cdr offset) closure-block-first-offset))) + (- (cdr offset) + (closure-block-first-offset block)))) (block-closure-offsets block)))) (let ((layout (make-layout (1+ (apply max (map cdr offsets)))))) (for-each (lambda (offset) @@ -180,7 +185,9 @@ MIT in each case. |# offsets) (if (and parent (ic-block/use-lookup? parent)) (layout-set! layout 0 dbg-block-name/ic-parent)) - (make-dbg-block 'CLOSURE (block->dbg-block parent) false layout false)))) + (make-dbg-block 'CLOSURE (block->dbg-block parent) false + (cons start-offset layout) + false)))) (define (ic-block->dbg-block block) (make-dbg-block 'IC (block->dbg-block (block-parent block)) @@ -202,17 +209,22 @@ MIT in each case. |# (let ((integrated? (lvalue-integrated? variable)) (indirection (variable-indirection variable))) (let ((dbg-variable - (make-dbg-variable (variable-name variable) - (cond (integrated? 'INTEGRATED) - (indirection 'INDIRECTED) - ((variable-in-cell? variable) 'CELL) - (else 'NORMAL)) - (cond (integrated? - (lvalue-known-value variable)) - (indirection - (variable->dbg-variable indirection)) - (else - false))))) + (make-dbg-variable + (variable-name variable) + (cond (integrated? 'INTEGRATED) + (indirection 'INDIRECTED) + ((variable-in-cell? variable) 'CELL) + (else 'NORMAL)) + (cond (integrated? + (lvalue-known-value variable)) + (indirection + ;; This currently does not examine whether it is a + ;; simple indirection, or a closure indirection. + ;; The value displayed will be incorrect if it + ;; is a closure indirection, but... + (variable->dbg-variable (car indirection))) + (else + false))))) (if integrated? (set! *integrated-variables* (cons dbg-variable *integrated-variables*))) diff --git a/v7/src/compiler/base/lvalue.scm b/v7/src/compiler/base/lvalue.scm index a9b08967f..0aa0a39bc 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.17 1990/02/02 18:38:16 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/lvalue.scm,v 4.18 1990/05/03 15:04:56 jinx Exp $ Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology @@ -86,7 +86,7 @@ MIT in each case. |# register ;register for parameters passed in registers stack-overwrite-target? ;true iff variable is the target of a stack overwrite - indirection ;alias for this variable [variable or #f] + indirection ;alias for this variable (variable . boolean) or #f source-node ;virtual-return that initializes this variable, or #f ) @@ -256,7 +256,8 @@ MIT in each case. |# (and value (or (rvalue/constant? value) (and (rvalue/procedure? value) - (procedure/virtually-open? value)))))) + (procedure/virtually-open? value)) + (lvalue-get lvalue 'INTEGRATED))))) (define (variable-unused? variable) (or (lvalue-integrated? variable) diff --git a/v7/src/compiler/base/proced.scm b/v7/src/compiler/base/proced.scm index b62a49001..967779ab3 100644 --- a/v7/src/compiler/base/proced.scm +++ b/v7/src/compiler/base/proced.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/proced.scm,v 4.15 1989/10/26 07:36:03 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/proced.scm,v 4.16 1990/05/03 15:05:01 jinx Exp $ -Copyright (c) 1988, 1989 Massachusetts Institute of Technology +Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -33,6 +33,7 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; Procedure datatype +;;; package: (compiler) (declare (usual-integrations)) @@ -52,7 +53,7 @@ MIT in each case. |# label ;label to identify procedure entry point [symbol] applications ;list of applications for which this is an operator always-known-operator? ;always known operator of application? [boolean] - closing-limit ;closing limit (see code) + closure-cons ;for closure, how it is to be consed. closure-context ;for closure, where procedure is closed [block] closure-offset ;for closure, offset of procedure in stack frame register ;for continuation, argument register @@ -67,7 +68,7 @@ MIT in each case. |# closure-reasons ;reasons why a procedure is closed. (variables ;variables which may be bound to this procedure (1) side-effects) ;classes of side-effects performed by this procedure - properties ;random bits of information [assq list] + alist ;random bits of information [assq list] debugging-info ;[dbg-procedure or dbg-continuation] ) @@ -173,11 +174,26 @@ MIT in each case. |# (if (null? applications) (set-procedure-always-known-operator?! procedure false)))) +(define (procedure-get procedure key) + (let ((entry (assq key (procedure-alist procedure)))) + (and entry + (cdr entry)))) + +(define (procedure-put! procedure key item) + (let ((entry (assq key (procedure-alist procedure)))) + (if entry + (set-cdr! entry item) + (set-procedure-alist! procedure + (cons (cons key item) (procedure-alist procedure)))))) + +(define (procedure-remove! procedure key) + (set-procedure-alist! procedure (del-assq! key (procedure-alist procedure)))) + (define-integrable (procedure/simplified? procedure) - (assq 'SIMPLIFIED (procedure-properties procedure))) + (procedure-get procedure 'SIMPLIFIED)) (define-integrable (procedure/trivial? procedure) - (assq 'TRIVIAL (procedure-properties procedure))) + (procedure-get procedure 'TRIVIAL)) (define (procedure-inline-code? procedure) (and (not (procedure-rest procedure)) @@ -313,7 +329,8 @@ MIT in each case. |# (let loop ((reasons (procedure-closure-reasons procedure))) (and (not (null? reasons)) (or (memq (caar reasons) - '(PASSED-OUT ARGUMENT ASSIGNMENT APPLY-COMPATIBILITY)) + '(PASSED-OUT ARGUMENT ASSIGNMENT + COMPATIBILITY APPLY-COMPATIBILITY)) (loop (cdr reasons)))))) (define (procedure-maybe-registerizable? procedure) diff --git a/v7/src/compiler/base/switch.scm b/v7/src/compiler/base/switch.scm index e554dd6f3..9a5b7e1b6 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.14 1990/03/26 23:45:19 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/switch.scm,v 4.15 1990/05/03 15:05:05 jinx Rel $ Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology @@ -59,6 +59,7 @@ MIT in each case. |# (define compiler:generate-range-checks? false) (define compiler:generate-type-checks? false) (define compiler:open-code-flonum-checks? false) +(define compiler:use-multiclosures? true) ;; The switch COMPILER:OPEN-CODE-FLOATING-POINT-ARITHMETIC? is in machin.scm. ;;; Nary switches diff --git a/v7/src/compiler/fgopt/blktyp.scm b/v7/src/compiler/fgopt/blktyp.scm index f398b35a1..3122a2063 100644 --- a/v7/src/compiler/fgopt/blktyp.scm +++ b/v7/src/compiler/fgopt/blktyp.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/blktyp.scm,v 4.14 1990/04/01 22:18:32 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/blktyp.scm,v 4.15 1990/05/03 15:09:03 jinx Rel $ -Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology +Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -33,6 +33,7 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; Environment Type Assignment +;;; package: (compiler fg-optimizer setup-block-types) (declare (usual-integrations)) @@ -57,67 +58,422 @@ MIT in each case. |# (define (block-type! block type) (set-block-type! block type) (for-each loop (block-children block))) + + (loop root-block) + (if compiler:use-multiclosures? + (merge-closure-blocks! root-block))) - (loop root-block)) +(define (merge-closure-blocks! root-block) + (define (loop block update?) + (enumeration-case block-type (block-type block) + ((STACK) + (let ((procedure (block-procedure block))) + (if (procedure/full-closure? procedure) + (let ((closure-block (block-parent block))) + (if (eq? closure-block (block-shared-block closure-block)) + (or (attempt-child-graft block procedure update?) + (and update? (update-closure! procedure)))))) + (examine-children block + (or (attempt-children-merge block procedure update?) + update?)))) + ((IC CONTINUATION EXPRESSION) + (examine-children block update?)) + (else + (error "Illegal block type" block)))) + + (define (examine-children block update?) + (for-each (lambda (child) + (loop child update?)) + (original-block-children block))) + + (loop root-block false)) +(define (original-block-children block) + (append (block-disowned-children block) + (list-transform-positive + (block-children block) + (lambda (block*) + (eq? block (original-block-parent block*)))))) + (define (maybe-close-procedure! procedure) (if (eq? true (procedure-closure-context procedure)) - (close-procedure! procedure))) - -(define (close-procedure! procedure) - (let ((block (procedure-block procedure)) - (previously-trivial? (procedure/trivial-closure? procedure)) - (original-parent (procedure-target-block procedure))) - (let ((parent (block-parent block))) - (set-procedure-closure-context! procedure - (make-reference-context original-parent)) - (with-values - (lambda () - (let ((uninteresting-variable? - (lambda (variable) - (or (lvalue-integrated? variable) - (let ((value (lvalue-known-value variable))) - (and value - (or (eq? value procedure) - (and (rvalue/procedure? value) - (procedure/trivial-or-virtual? - value))))))))) - (find-closure-bindings - original-parent - (list-transform-negative (block-free-variables block) - (lambda (lvalue) - (or (uninteresting-variable? lvalue) - (begin - (set-variable-closed-over?! lvalue true) - false)))) - '() - (list-transform-negative - (block-variables-nontransitively-free block) - uninteresting-variable?)))) - (lambda (closure-frame-block size) - (set-block-parent! block closure-frame-block) - (set-procedure-closure-size! procedure size))) - (if previously-trivial? - (if (not (procedure/trivial-closure? procedure)) - (error "trivial procedure becoming non-trivial" procedure)) - (if (procedure/trivial-closure? procedure) - (warn "non-trivial procedure becoming trivial" procedure))) - (set-block-children! parent (delq! block (block-children parent))) - (if (eq? parent original-parent) - (set-block-disowned-children! - parent - (cons block (block-disowned-children parent))))))) + (let ((block (procedure-block procedure)) + (previously-trivial? (procedure/trivial-closure? procedure)) + (original-parent (procedure-target-block procedure))) + (let ((parent (block-parent block))) + (set-procedure-closure-context! + procedure + (make-reference-context original-parent)) + (with-values + (lambda () + (let ((uninteresting-variable? + (lambda (variable) + (or (lvalue-integrated? variable) + (let ((value (lvalue-known-value variable))) + (and value + (or (eq? value procedure) + (and (rvalue/procedure? value) + (procedure/trivial-or-virtual? + value))))))))) + (find-closure-bindings + original-parent + (list-transform-negative (block-free-variables block) + (lambda (lvalue) + (or (uninteresting-variable? lvalue) + (begin + (set-variable-closed-over?! lvalue true) + false)))) + '() + (list-transform-negative + (block-variables-nontransitively-free block) + uninteresting-variable?)))) + (lambda (closure-block closure-block?) + (transfer-block-child! block parent closure-block) + (set-procedure-closure-size! + procedure + (cond (closure-block? + (compute-closure-offsets! closure-block + (closure-first-offset 1 0))) + (closure-block 1) + (else 0))))) + (set-procedure-closure-cons! procedure '(NORMAL)) + (if previously-trivial? + (if (not (procedure/trivial-closure? procedure)) + (error "trivial procedure becoming non-trivial" procedure)) + (if (procedure/trivial-closure? procedure) + (warn "non-trivial procedure becoming trivial" + procedure))))))) + +(define (attempt-child-graft block procedure update?) + (let ((block* (block-nearest-closure-ancestor + (procedure-target-block procedure)))) + (and block* + (let ((closure-block (block-parent block)) + (ancestor-block (block-shared-block (block-parent block*)))) + (and (for-all? + (refilter-variables (block-bound-variables closure-block) + update? procedure) + (let ((bvars (block-bound-variables ancestor-block))) + (lambda (var) + (or (memq var bvars) + (let ((val (lvalue-known-value var))) + (and val + (if (rvalue/block? val) + (eq? val ancestor-block) + (and (rvalue/procedure? val) + (procedure/full-closure? val) + (eq? (block-shared-block + (procedure-closing-block val)) + ancestor-block))))))))) + (graft-child! procedure ancestor-block closure-block)))))) + +(define (graft-child! procedure ancestor-block closure-block) + (for-each + (lambda (var) + (if (and (lvalue-known-value var) + (not (variable-closed-over? var)) + (let* ((sblock (block-nearest-closure-ancestor + (variable-block var))) + (cblock (and sblock (block-parent sblock)))) + (and cblock + (eq? (block-shared-block cblock) ancestor-block)))) + (lvalue-put! var 'INTEGRATED ancestor-block))) + (procedure-variables procedure)) + (graft-block! '(DESCENDANT) ancestor-block closure-block procedure) + true) + +(define (update-closure! procedure) + (let ((closure-block (procedure-closing-block procedure))) + (if (not (eq? (block-shared-block closure-block) closure-block)) + (error "update-closure!: Updating shared closure" procedure)) + (let ((vars (refilter-variables (block-bound-variables closure-block) + true procedure))) + (set-block-bound-variables! closure-block vars) + (set-procedure-closure-size! + procedure + (compute-closure-offsets! closure-block + (closure-block-first-offset + closure-block)))))) + +(define (refilter-variables bvars filter? procedure) + (if (not filter?) + bvars + (let loop ((vars (reverse bvars)) + (real '()) + (blocks '())) + (cond ((not (null? vars)) + (let* ((var (car vars)) + (ind (variable-indirection var))) + (if ind + (loop (cdr vars) + (if (memq (car ind) real) + real + (cons (car ind) real)) + blocks) + (let ((val (lvalue-known-value var))) + (cond ((not val) + (loop (cdr vars) + (cons var real) + blocks)) + ((rvalue/block? val) + ;; This should not be found since this is + ;; only the result of this procedure itself, + ;; or link-children!, and either way, it + ;; should not be called after that point. + (error "refilter-variables: Block found" + procedure)) + #| + ;; This doesn't work because these variables + ;; have not been indirected, so the eventual + ;; lookup will fail. + ;; We need to think about whether they can be + ;; indirected always. + ((and (rvalue/procedure? val) + (procedure/closure? val)) + (let ((block + (block-shared-block + (procedure-closing-block val)))) + (if (memq block blocks) + (loop (cdr vars) + real + blocks) + (loop (cdr vars) + (cons var real) + (cons block blocks))))) + |# + (else + (loop (cdr vars) + (cons var real) + blocks))))))) + ((null? real) + ;; Only non-trivial closures passed here. + (error "refilter-variables: becoming trivial!" procedure)) + (else real))))) + +(define (attempt-children-merge block procedure update?) + (let ((closure-children + (list-transform-positive + (original-block-children block) + (lambda (block*) + (let ((procedure* (block-procedure block*))) + (and procedure* + (procedure/full-closure? procedure*))))))) + (and (not (null? closure-children)) + (list-split + closure-children + (lambda (block*) + (procedure-get (block-procedure block*) 'UNCONDITIONAL)) + (lambda (unconditional conditional) + (and (not (null? unconditional)) + (or (not (null? conditional)) + (not (null? (cdr unconditional)))) + (merge-children! block procedure + unconditional conditional + update?))))))) + +(define (merge-children! block procedure unconditional conditional update?) + (let ((ic-parent + (let ((block + (list-search-positive unconditional + (lambda (block*) + (block-parent (block-parent block*)))))) + (and block + (block-parent (block-parent block))))) + (closed-over-variables + (refilter-variables + (reduce-right eq-set-union + '() + (map (lambda (block*) + (block-bound-variables (block-parent block*))) + unconditional)) + update? (block-procedure (car unconditional))))) + (let loop ((conditional conditional) + (block-closed (reverse unconditional))) + (cond ((not (null? conditional)) + (loop (cdr conditional) + (let* ((block* (car conditional)) + (closure-block (block-parent block*))) + (if (and (or (not (block-parent closure-block)) + ic-parent) + (for-all? + (refilter-variables + (block-bound-variables closure-block) + update? (block-procedure block*)) + (lambda (var) + (or (lvalue-implicit? var unconditional) + (let ((ind (variable-indirection var))) + (memq (if ind + (car ind) + var) + closed-over-variables)))))) + (cons (car conditional) block-closed) + block-closed)))) + ((null? (cdr block-closed)) + false) + (else + (link-children! block procedure (reverse block-closed) + ic-parent closed-over-variables)))))) + +(define closure-redirection-tag (intern "#[closure-redirection]")) + +(define (link-children! block procedure block-closed ic-parent variables) + ;; Possible improvement: the real free variables may be references + ;; to closure ancestors. At this point, all of them can be merged + ;; with the ancestor parent! This should be pretty rare, but... + (list-split + variables + (lambda (var) + (lvalue-implicit? var block-closed)) + (lambda (removable real) + (if (and (null? real) (not ic-parent)) + (error "link-children!: Trivial multiclosure" block-closed variables)) + (let ((letrec-names (procedure-names procedure)) + (indirection-var (make-variable block closure-redirection-tag)) + (shared-block + (make-closure-block + ic-parent + (reduce-right eq-set-union + '() + (map (lambda (block*) + (block-free-variables (block-parent block*))) + block-closed)) + real + '()))) + (set-variable-closed-over?! indirection-var true) + (let ((cache (list shared-block))) + (set-lvalue-initial-values! indirection-var cache) + (set-lvalue-values-cache! indirection-var cache) + (set-lvalue-known-value! indirection-var shared-block)) + ;; what follows is a kludge to communicate with + ;; rtlgen/rgproc.scm + (set-procedure-names! procedure + (cons indirection-var letrec-names)) + (set-procedure-values! procedure + (cons shared-block (procedure-values procedure))) + (set-block-bound-variables! block + (append (block-bound-variables block) + (list indirection-var))) + (set-block-entry-number! shared-block 0) + (for-each + (let ((pair `(INDIRECTED . ,indirection-var))) + (lambda (block) + (graft-block! pair shared-block + (block-parent block) (block-procedure block)))) + block-closed) + (let ((pair (cons indirection-var true))) + (for-each + (lambda (removable) + (if (not (memq removable letrec-names)) + (error "link-children!: non-letrec removable" removable)) + (set-variable-indirection! removable pair)) + removable) + (for-each + (lambda (name) + (if (not (variable-indirection name)) + (let ((proc (lvalue-known-closure name))) + (if (and proc + (eq? (block-shared-block + (procedure-closing-block proc)) + shared-block)) + (set-variable-indirection! name pair))))) + letrec-names) + true))))) + +(define (graft-block! how-consed block block* procedure*) + (if (or (closure-procedure-needs-external-descriptor? procedure*) + ;; Known lexpr closures are invoked through apply. + (procedure-rest procedure*)) + (let ((entry (block-entry-number block))) + (if (zero? entry) + (set-block-procedure! block procedure*)) + (set-block-entry-number! block (1+ entry)) + (set-block-entry-number! block* entry)) + (set-block-entry-number! block* 0)) + (let ((parent (block-parent block)) + (parent* (block-parent block*))) + (cond ((not parent*) + (if parent + (set-block-parent! block* parent))) + ((not parent) + (set-block-parent! block parent*) + (for-each (lambda (block**) + (set-block-parent! block** parent*)) + (block-grafted-blocks block))) + ((not (eq? parent parent*)) + (error "graft-block!: Differing parents" block block*)))) + (set-procedure-closure-cons! procedure* how-consed) + (set-block-shared-block! block* block) + ;; Note that the list of grafted blocks are in decreasing entry + ;; number order, except for those that have 0 as their entry number + ;; (and thus don't need entries). This is used to advantage in + ;; make-non-trivial-closure-cons in rtlgen/rgrval.scm . + (let ((new-grafts (cons block* (block-grafted-blocks block)))) + (set-block-grafted-blocks! block new-grafts) + (for-each (let ((bvars (block-bound-variables block))) + (lambda (block*) + (set-block-bound-variables! block* bvars) + (let ((size + (compute-closure-offsets! + block* + (closure-block-first-offset block*)))) + (if (not (null? (block-children block*))) + (set-procedure-closure-size! + (block-procedure (car (block-children block*))) + size))))) + (cons block new-grafts)))) + +;;; Utilities that should live elsewhere + +(define (indirection-block-procedure block) + (or (block-procedure block) + (if (null? (block-grafted-blocks block)) + (error "indirection-block-procedure: Bad indirection block" block) + (block-procedure + (car (block-children + (car (block-grafted-blocks block)))))))) + +(define (lvalue-implicit? var blocks) + (let ((val (lvalue-known-value var))) + (and val + (rvalue/procedure? val) + (memq (procedure-block val) blocks)))) + +(define (lvalue-known-closure var) + (let ((val (lvalue-known-value var))) + (and val + (rvalue/procedure? val) + (procedure/full-closure? val) + val))) + +(define-integrable (procedure/full-closure? proc) + (and (procedure/closure? proc) + (not (procedure/trivial-closure? proc)))) + +(define (list-split list predicate recvr) + (let split ((list list) + (recvr recvr)) + (if (not (pair? list)) + (recvr '() '()) + (let ((next (car list))) + (split (cdr list) + (if (predicate next) + (lambda (win lose) + (recvr (cons next win) lose)) + (lambda (win lose) + (recvr win (cons next lose))))))))) (define (find-closure-bindings block free-variables bound-variables variables-nontransitively-free) (if (or (not block) (ic-block? block)) (let ((grandparent (and (not (null? free-variables)) block))) (if (null? bound-variables) - (values grandparent (if grandparent 1 0)) - (make-closure-block grandparent - free-variables - bound-variables - variables-nontransitively-free))) + (values grandparent false) + (values + (make-closure-block grandparent + free-variables + bound-variables + variables-nontransitively-free) + true))) (with-values (lambda () (filter-bound-variables (block-bound-variables block) @@ -141,11 +497,6 @@ MIT in each case. |# free-variables bound-variables)))) -;; Note: The use of closure-block-first-offset below implies that -;; closure frames are not shared between different closures. -;; This may have to change if we ever do simultaneous closing of multiple -;; procedures sharing structure. - (define (make-closure-block parent free-variables bound-variables variables-nontransitively-free) (let ((block (make-block parent 'CLOSURE))) @@ -154,18 +505,31 @@ MIT in each case. |# (set-block-variables-nontransitively-free! block variables-nontransitively-free) - (do ((variables (block-bound-variables block) (cdr variables)) - (size (if (and parent (ic-block/use-lookup? parent)) 1 0) (1+ size)) - (table '() - (cons (cons (car variables) - (+ closure-block-first-offset size)) - table))) - ((null? variables) - (set-block-closure-offsets! block table) - (values block size)) - (if (lvalue-integrated? (car variables)) - (error "make-closure-block: integrated lvalue" (car variables)))))) + (set-block-shared-block! block block) + (set-block-entry-number! block 1) + (set-block-grafted-blocks! block '()) + block)) + +(define (compute-closure-offsets! block offset) + (if block + (let ((parent (block-parent block))) + (do ((variables (block-bound-variables block) (cdr variables)) + (size (if (and parent (ic-block/use-lookup? parent)) 1 0) + (1+ size)) + (table '() + (cons (cons (car variables) (+ offset size)) + table))) + ((null? variables) + (set-block-closure-offsets! block table) + size) + (if (lvalue-integrated? (car variables)) + (error "compute-closure-offsets!: integrated lvalue" + (car variables))))) + 0)) +;;;; Reference contexts in which procedures are closed. +;;; Needed to determine the access paths of free variables to close over. + (define (setup-closure-contexts! expression procedures) (with-new-node-marks (lambda () diff --git a/v7/src/compiler/fgopt/closan.scm b/v7/src/compiler/fgopt/closan.scm index c9869f88e..c7cb8f083 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.14 1990/04/01 22:23:16 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/closan.scm,v 4.15 1990/05/03 15:09:07 jinx Rel $ Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology @@ -33,6 +33,7 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; Closure Analysis +;;; package: (compiler fg-optimizer closure-analysis) (declare (usual-integrations)) @@ -255,7 +256,7 @@ MIT in each case. |# ;; is an ancestor if free variables captured by `block*' are needed. (define (process-descendant block) - (for-each-block-descendent! + (for-each-block-descendant! block (lambda (block*) (for-each process-disowned (block-disowned-children block*))))) @@ -417,13 +418,7 @@ MIT in each case. |# constraints)) (define (undrift-block! block new-parent) - (let ((parent (block-parent block))) - (set-block-children! parent (delq! block (block-children parent)))) - (own-block-child! new-parent block) - (if (eq? new-parent (original-block-parent block)) - (set-block-disowned-children! - new-parent - (delq! block (block-disowned-children new-parent))))) + (transfer-block-child! block (block-parent block) new-parent)) ;;;; Utilities @@ -445,7 +440,7 @@ MIT in each case. |# ;; envopt has an identical definition commented out. (define (for-each-callee! block action) - (for-each-block-descendent! block + (for-each-block-descendant! block (lambda (block*) (for-each (lambda (application) (for-each (lambda (value) diff --git a/v7/src/compiler/fgopt/envopt.scm b/v7/src/compiler/fgopt/envopt.scm index 47252abe6..f1ab5eae8 100644 --- a/v7/src/compiler/fgopt/envopt.scm +++ b/v7/src/compiler/fgopt/envopt.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/envopt.scm,v 1.6 1990/04/01 22:19:41 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/envopt.scm,v 1.7 1990/05/03 15:09:12 jinx Rel $ Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology @@ -33,6 +33,7 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; Procedure environment optimization +;;; package: (compiler fg-optimizer environment-optimization) (declare (usual-integrations)) @@ -66,7 +67,7 @@ MIT in each case. |# ;; world (which is ultimately functional). (define (for-each-callee! block procedure) - (for-each-block-descendent! block + (for-each-block-descendant! block (lambda (block*) (for-each (lambda (application) (for-each (lambda (value) @@ -151,9 +152,7 @@ MIT in each case. |# ;; invocation block. (set-procedure-target-block! procedure parent) (if (not (eq? parent target-block)) - (begin - (disown-block-child! parent block) - (own-block-child! target-block block))))) + (transfer-block-child! block parent target-block)))) #| (define (choose-target-block! procedure) @@ -186,9 +185,7 @@ MIT in each case. |# (lambda (application) (eq? (application-block application) parent))))))) - (begin - (disown-block-child! parent block) - (own-block-child! target-block block))) + (transfer-block-child! block parent target-block)) unspecific)) |# diff --git a/v7/src/compiler/fgopt/offset.scm b/v7/src/compiler/fgopt/offset.scm index b43b4f6fe..2b15ee3f9 100644 --- a/v7/src/compiler/fgopt/offset.scm +++ b/v7/src/compiler/fgopt/offset.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/offset.scm,v 4.6 1988/12/12 21:51:52 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/offset.scm,v 4.7 1990/05/03 15:09:17 jinx Exp $ -Copyright (c) 1988 Massachusetts Institute of Technology +Copyright (c) 1988, 1990 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -33,37 +33,59 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; Compute FG Node Offsets +;;; package: (compiler fg-optimizer compute-node-offsets) (declare (usual-integrations)) +(define *grafted-procedures*) (define *procedure-queue*) (define *procedures*) (define (compute-node-offsets root-expression) (fluid-let ((*procedure-queue* (make-queue)) + (*grafted-procedures* '()) (*procedures* '())) (with-new-node-marks (lambda () (walk-node (expression-entry-node root-expression) 0) (queue-map!/unsafe *procedure-queue* - (lambda (procedure) - (if (procedure-continuation? procedure) - (walk-next (continuation/entry-node procedure) - (if (eq? (continuation/type procedure) - continuation-type/push) - (1+ (continuation/offset procedure)) - (continuation/offset procedure))) - (begin - (for-each - (lambda (value) - (if (and (rvalue/procedure? value) - (not (procedure-continuation? value))) - (let ((context (procedure-closure-context value))) - (if (reference-context? context) - (update-reference-context/offset! context 0)))) - (walk-rvalue value 0)) - (procedure-values procedure)) - (walk-next (procedure-entry-node procedure) 0))))))))) + (lambda (procedure) + (if (procedure-continuation? procedure) + (walk-next (continuation/entry-node procedure) + (if (eq? (continuation/type procedure) + continuation-type/push) + (1+ (continuation/offset procedure)) + (continuation/offset procedure))) + (begin + (for-each + (lambda (value) + (cond ((and (rvalue/procedure? value) + (not (procedure-continuation? value))) + (let ((context (procedure-closure-context value))) + (if (reference-context? context) + (update-reference-context/offset! context 0))) + (walk-rvalue value 0)) + ((rvalue/block? value) + (enqueue-grafted-procedures! value)) + (else + (walk-rvalue value 0)))) + (procedure-values procedure)) + (walk-next (procedure-entry-node procedure) 0))))) + ;; This is a kludge. If the procedure hasn't been encountered + ;; elsewhere, tag it as closed when the letrec was done. + (for-each + (lambda (procedure) + (let ((context (procedure-closure-context procedure))) + (if (not (reference-context/offset context)) + (set-reference-context/offset! context 0)))) + *grafted-procedures*))))) + +(define (enqueue-grafted-procedures! block) + (let ((procs (map (lambda (block) + (block-procedure (car (block-children block)))) + (block-grafted-blocks block)))) + (set! *grafted-procedures* (append procs *grafted-procedures*)) + (for-each maybe-enqueue-procedure! procs))) (define (walk-rvalue rvalue offset) (if (and (rvalue/procedure? rvalue) diff --git a/v7/src/compiler/fgopt/sideff.scm b/v7/src/compiler/fgopt/sideff.scm index 03d6bee2e..5cfd9e4cd 100644 --- a/v7/src/compiler/fgopt/sideff.scm +++ b/v7/src/compiler/fgopt/sideff.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/sideff.scm,v 1.6 1990/03/21 02:11:37 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/sideff.scm,v 1.7 1990/05/03 15:09:20 jinx Rel $ Copyright (c) 1988, 1990 Massachusetts Institute of Technology @@ -33,6 +33,7 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; Side effect analysis +;;; package: (compiler fg-optimizer) (declare (usual-integrations)) @@ -407,24 +408,19 @@ MIT in each case. |# r/lvalue)) (define (procedure/trivial! procedure kind) - (let ((place (assq 'TRIVIAL (procedure-properties procedure)))) - (cond ((not place) - (set-procedure-properties! - procedure - (cons `(TRIVIAL ,kind) (procedure-properties procedure)))) - ((not (memq kind (cdr place))) - (set-cdr! place (cons kind (cdr place))))))) + (let ((kinds (procedure-get procedure 'TRIVIAL))) + (cond ((or (not kinds) (null? kinds)) + (procedure-put! procedure 'TRIVIAL (list kind))) + ((not (memq kind kinds)) + (procedure-put! procedure 'TRIVIAL (cons kind kinds)))))) (define (simplify-procedure! procedure r/lvalue) - (let ((place (assq 'SIMPLIFIED (procedure-properties procedure)))) - (if place - (error "procedure/trivial!: Already simplified" procedure)) - (set-procedure-properties! procedure - (cons `(SIMPLIFIED ,r/lvalue) - (procedure-properties procedure)))) ;; **** Kludge! `make-application' requires that a block be given, ;; rather than a context, because this is how "fggen" builds things. ;; So we must pass the block and then clobber it after. + (if (procedure-get procedure 'SIMPLIFIED) + (error "procedure/trivial!: Already simplified" procedure)) + (procedure-put! procedure 'SIMPLIFIED r/lvalue) (let ((block (procedure-block procedure))) (let ((context (make-reference-context block))) (let ((application diff --git a/v7/src/compiler/fgopt/subfre.scm b/v7/src/compiler/fgopt/subfre.scm index 2424ed458..48d858548 100644 --- a/v7/src/compiler/fgopt/subfre.scm +++ b/v7/src/compiler/fgopt/subfre.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/subfre.scm,v 1.4 1990/01/18 22:44:38 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/subfre.scm,v 1.5 1990/05/03 15:09:24 jinx Exp $ Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology @@ -33,6 +33,7 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; Subproblem Free Variables +;;; package: (compiler fg-optimizer subproblem-free-variables) (declare (usual-integrations)) @@ -40,9 +41,10 @@ MIT in each case. |# (with-analysis-state (lambda () (for-each (lambda (parallel) - (for-each (lambda (subproblem) - (set-subproblem-free-variables! subproblem 'UNKNOWN)) - (parallel-subproblems parallel))) + (for-each + (lambda (subproblem) + (set-subproblem-free-variables! subproblem 'UNKNOWN)) + (parallel-subproblems parallel))) parallels) (for-each (lambda (parallel) (for-each walk-subproblem (parallel-subproblems parallel))) @@ -70,16 +72,44 @@ MIT in each case. |# (else free)))) +(define (walk-procedure proc) + (define (default) + ;; This should be OK for open procedures, but perhaps + ;; we should look at the closure block for closures. + (list-transform-negative + (block-free-variables (procedure-block proc)) + lvalue-integrated?)) + + (if (or (not (procedure/closure? proc)) + (procedure/trivial-closure? proc)) + (default) + (let ((how (procedure-closure-cons proc))) + (case (car how) + ((NORMAL) + (default)) + ((DESCENDANT) + ;; This will automatically imply saving the ancestor + ;; for stack overwrites since that is how the free + ;; variables will be obtained. + ;; Is this really true? + ;; What if some of them are in registers? + ;; What if it is a descendant of an indirected procedure? + (default)) + ((INDIRECTED) + ;; In reality, only the indirection variable or the default + ;; set is needed, depending on where the reference occurs. + ;; This is always safe, however. + (cons (cdr how) (default))) + (else + (error "walk-procedure: Unknown closure method" proc)))))) + (define (walk-operator rvalue) (enumeration-case rvalue-type (tagged-vector/index rvalue) ((REFERENCE) (walk-lvalue (reference-lvalue rvalue) walk-operator)) ((PROCEDURE) (if (procedure-continuation? rvalue) (walk-next (continuation/entry-node rvalue) '()) - (map-union (lambda (procedure) - (list-transform-negative - (block-free-variables (procedure-block procedure)) - lvalue-integrated?)) + (map-union walk-procedure (eq-set-union (list rvalue) (procedure-callees rvalue))))) (else '()))) @@ -90,9 +120,7 @@ MIT in each case. |# ((PROCEDURE) (if (procedure-continuation? rvalue) (walk-next (continuation/entry-node rvalue) '()) - (list-transform-negative - (block-free-variables (procedure-block rvalue)) - lvalue-integrated?))) + (walk-procedure rvalue))) (else '()))) (define (walk-lvalue lvalue walk-rvalue) @@ -103,7 +131,8 @@ MIT in each case. |# (eq-set-adjoin lvalue (walk-rvalue value))) (if (and (variable? lvalue) (variable-indirection lvalue)) - (walk-lvalue (variable-indirection lvalue) walk-rvalue) + (walk-lvalue (car (variable-indirection lvalue)) + walk-rvalue) (list lvalue))))) (define *nodes*) diff --git a/v7/src/compiler/fgopt/varind.scm b/v7/src/compiler/fgopt/varind.scm index 12dd686f3..b15447ed0 100644 --- a/v7/src/compiler/fgopt/varind.scm +++ b/v7/src/compiler/fgopt/varind.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/varind.scm,v 1.3 1989/11/02 08:08:21 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/varind.scm,v 1.4 1990/05/03 15:09:28 jinx Rel $ -Copyright (c) 1989 Massachusetts Institute of Technology +Copyright (c) 1989, 1990 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -33,6 +33,7 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; Variable Indirections +;;; package: (compiler fg-optimizer variable-indirection) (declare (usual-integrations)) @@ -47,7 +48,8 @@ MIT in each case. |# lvalues)))) (define (initialize-variable-indirection! variable) - (if (not (lvalue-marked? variable)) + (if (and (not (lvalue-marked? variable)) + (not (variable-indirection variable))) (begin (lvalue-mark! variable) (let ((block (variable-block variable))) @@ -73,24 +75,24 @@ MIT in each case. |# (begin (initialize-variable-indirection! possibility) (or (variable-indirection possibility) - possibility)))))) + (cons possibility false))))))) (if indirection - (begin + (let ((indirection-variable (car indirection))) (set-variable-indirection! variable indirection) (let ((variables (block-variables-nontransitively-free block))) - (if (not (memq indirection variables)) + (if (not (memq indirection-variable variables)) (set-block-variables-nontransitively-free! block - (cons indirection variables)))) - (let ((block* (variable-block indirection))) + (cons indirection-variable variables)))) + (let ((block* (variable-block indirection-variable))) (let loop ((block block)) (let ((variables (block-free-variables block))) - (if (not (memq indirection variables)) + (if (not (memq indirection-variable variables)) (begin (set-block-free-variables! block - (cons indirection variables)) + (cons indirection-variable variables)) (let ((parent (block-parent block))) (if (not (eq? parent block*)) (loop parent)))))))))))))))) \ No newline at end of file diff --git a/v7/src/compiler/machines/bobcat/compiler.pkg b/v7/src/compiler/machines/bobcat/compiler.pkg index 4a64815e9..ae92904da 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.29 1990/03/26 23:45:05 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/compiler.pkg,v 1.30 1990/05/03 15:16:59 jinx Rel $ Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology @@ -98,7 +98,8 @@ MIT in each case. |# compiler:show-phases? compiler:show-procedures? compiler:show-subphases? - compiler:show-time-reports?)) + compiler:show-time-reports? + compiler:use-multiclosures?)) (define-package (compiler reference-contexts) (files "base/refctx") @@ -396,7 +397,9 @@ MIT in each case. |# (parent (compiler fg-optimizer)) (export (compiler top-level) setup-block-types! - setup-closure-contexts!)) + setup-closure-contexts!) + (export (compiler) + indirection-block-procedure)) (define-package (compiler fg-optimizer simplicity-analysis) (files "fgopt/simple") @@ -482,9 +485,13 @@ MIT in each case. |# (export (compiler rtl-generator) generate/rvalue load-closure-environment + make-cons-closure-indirection + make-cons-closure-redirection + make-closure-redirection make-ic-cons make-non-trivial-closure-cons - make-trivial-closure-cons)) + make-trivial-closure-cons + redirect-closure)) (define-package (compiler rtl-generator generate/combination) (files "rtlgen/rgcomb") diff --git a/v7/src/compiler/machines/bobcat/dassm2.scm b/v7/src/compiler/machines/bobcat/dassm2.scm index 28fd16f34..2f48f2937 100644 --- a/v7/src/compiler/machines/bobcat/dassm2.scm +++ b/v7/src/compiler/machines/bobcat/dassm2.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/dassm2.scm,v 4.16 1989/12/11 06:16:42 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/dassm2.scm,v 4.17 1990/05/03 15:17:04 jinx Rel $ -Copyright (c) 1988, 1989 Massachusetts Institute of Technology +Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -33,6 +33,7 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; 68000 Disassembler: Top Level +;;; package: (compiler disassembler) (declare (usual-integrations)) diff --git a/v7/src/compiler/machines/bobcat/decls.scm b/v7/src/compiler/machines/bobcat/decls.scm index d7ff1ad31..5f5024267 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.26 1990/02/02 18:39:26 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/decls.scm,v 4.27 1990/05/03 15:17:08 jinx Rel $ Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology @@ -33,6 +33,7 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; Compiler File Dependencies +;;; package: (compiler declarations) (declare (usual-integrations)) @@ -384,7 +385,7 @@ MIT in each case. |# (source-node/declarations node))))) filenames)) - (let ((front-end-base + (let* ((front-end-base (filename/append "base" "blocks" "cfg1" "cfg2" "cfg3" "contin" "ctypes" "enumer" "lvalue" @@ -398,7 +399,11 @@ MIT in each case. |# "rtlty2")) (cse-base (filename/append "rtlopt" - "rcse1" "rcse2" "rcseep" "rcseht" "rcserq" "rcsesr")) + "rcse1" "rcseht" "rcserq" "rcsesr")) + (cse-all + (append (filename/append "rtlopt" + "rcse2" "rcseep") + cse-base)) (instruction-base (filename/append "machines/bobcat" "assmd" "machin")) (lapgen-base @@ -509,13 +514,13 @@ MIT in each case. |# (append bobcat-base front-end-base rtl-base)) (file-dependency/integration/join - (append cse-base + (append cse-all (filename/append "rtlopt" "ralloc" "rcompr" "rdebug" "rdflow" "rerite" "rinvex" "rlife" "rtlcsm") (filename/append "machines/bobcat" "rulrew")) (append bobcat-base rtl-base)) - (file-dependency/integration/join cse-base cse-base) + (file-dependency/integration/join cse-all cse-base) (file-dependency/integration/join (filename/append "rtlopt" "ralloc" "rcompr" "rdebug" "rlife") diff --git a/v7/src/compiler/machines/bobcat/lapgen.scm b/v7/src/compiler/machines/bobcat/lapgen.scm index adbd12f03..e9634641b 100644 --- a/v7/src/compiler/machines/bobcat/lapgen.scm +++ b/v7/src/compiler/machines/bobcat/lapgen.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/lapgen.scm,v 4.31 1990/04/01 22:26:01 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/lapgen.scm,v 4.32 1990/05/03 15:17:14 jinx Exp $ Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology @@ -33,6 +33,7 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; RTL Rules for 68020. Part 1 +;;; package: (compiler lap-syntaxer) (declare (usual-integrations)) @@ -177,21 +178,24 @@ MIT in each case. |# (define (increment-machine-register register n) (let ((target (register-reference register))) - (case n - ((0) (LAP)) - ((1 2) (LAP (ADDQ L (& ,(* 4 n)) ,target))) - ((-1 -2) (LAP (SUBQ L (& ,(* -4 n)) ,target))) - (else - (if (< register 8) - (LAP (ADD L (& ,(* 4 n)) ,target)) - (LAP (LEA (@AO ,(- register 8) ,(* 4 n)) ,target))))))) + (cond ((zero? n) (LAP)) + ((<= 1 n 8) (LAP (ADDQ L (& ,n) ,target))) + ((>= -1 n -8) (LAP (SUBQ L (& ,n) ,target))) + ((not (< register 8)) + (LAP (LEA (@AO ,(- register 8) ,n) ,target))) + ((<= -128 n 127) + (let ((temp (reference-temporary-register! 'DATA))) + (LAP (MOVEQ (& ,n) ,temp) + (ADD L ,temp ,target)))) + (else + (LAP (ADD L (& ,n) ,target)))))) (define (load-constant constant target) (if (non-pointer-object? constant) (load-non-pointer-constant constant target) - (INST (MOV L - (@PCR ,(constant->label constant)) - ,target)))) + (LAP (MOV L + (@PCR ,(constant->label constant)) + ,target)))) (define (load-non-pointer-constant constant target) (load-non-pointer (object-type constant) @@ -204,12 +208,32 @@ MIT in each case. |# (define (load-machine-constant n target) (cond ((and (zero? n) (effective-address/data&alterable? target)) - (INST (CLR L ,target))) - ((and (<= -128 n 127) - (effective-address/data-register? target)) - (INST (MOVEQ (& ,n) ,target))) + (LAP (CLR L ,target))) + ((not (effective-address/data-register? target)) + (LAP (MOV UL (& ,n) ,target))) + ((<= -128 n 127) + (LAP (MOVEQ (& ,n) ,target))) (else - (INST (MOV UL (& ,n) ,target))))) + (find-zero-bits n + (lambda (zero-bits datum) + (cond ((> datum 127) + (LAP (MOV UL (& ,n) ,target))) + ((<= zero-bits 16) + (LAP (MOVEQ (& ,datum) ,target) + (LS L L (& ,zero-bits) ,target))) + (else + ;; This is useful for type-code or-masks. + ;; It should be extended to handle and-masks. + (LAP (MOVEQ (& ,datum) ,target) + (RO R L (& ,(- 32 zero-bits)) ,target))))))))) + +(define (find-zero-bits n receiver) + (let loop ((bits 0) (n n)) + (let ((result (integer-divide n 2))) + (if (zero? (integer-divide-remainder result)) + (loop (1+ bits) + (integer-divide-quotient result)) + (receiver bits n))))) (define (memory-set-type type target) (if (= 8 scheme-type-width) diff --git a/v7/src/compiler/machines/bobcat/machin.scm b/v7/src/compiler/machines/bobcat/machin.scm index ccf119fc6..c477dd341 100644 --- a/v7/src/compiler/machines/bobcat/machin.scm +++ b/v7/src/compiler/machines/bobcat/machin.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/machin.scm,v 4.21 1990/04/01 22:28:28 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/machin.scm,v 4.22 1990/05/03 15:17:20 jinx Rel $ Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology @@ -33,6 +33,7 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; Machine Model for 68020 +;;; package: (compiler) (declare (usual-integrations)) @@ -83,7 +84,44 @@ MIT in each case. |# (define-integrable (stack->memory-offset offset) offset) (define-integrable ic-block-first-parameter-offset 2) -(define-integrable closure-block-first-offset 2) + +;; This must return a word based offset. +;; On the 68k, to save space, entries can be at 2 mod 4 addresses, +;; which makes this impossible if the closure object used for +;; referencing points to arbitrary entries. Instead, all closure +;; entry points bump to the canonical entry point, which is always +;; longword aligned. +;; On other machines (word aligned), it may be easier to bump back +;; to each entry point, and the entry number `entry' would be part +;; of the computation. + +(define (closure-first-offset nentries entry) + entry ; ignored + (if (zero? nentries) + 1 + (quotient (+ (+ 3 1) (* 5 (- nentries 1))) 2))) + +;; This is from the start of the complete closure object, +;; viewed as a vector, and including the header word. + +(define (closure-object-first-offset nentries) + (case nentries + ((0) 1) + ((1) 4) + (else + (quotient (+ 5 (* 5 nentries)) 2)))) + +;; Bump from one entry point to another. + +(define (closure-entry-distance nentries entry entry*) + nentries ; ignored + (* 10 (- entry* entry))) + +;; Bump to the canonical entry point. + +(define (closure-environment-adjustment nentries entry) + (declare (integrate-operator closure-entry-distance)) + (closure-entry-distance nentries entry 0)) (define-integrable d0 0) (define-integrable d1 1) @@ -238,7 +276,8 @@ MIT in each case. |# ENTRY:CONTINUATION ASSIGNMENT-CACHE VARIABLE-CACHE - OFFSET-ADDRESS) + OFFSET-ADDRESS + BYTE-OFFSET-ADDRESS) 3) ((CONS-POINTER) (and (rtl:machine-constant? (rtl:cons-pointer-type expression)) diff --git a/v7/src/compiler/machines/bobcat/make.scm-68040 b/v7/src/compiler/machines/bobcat/make.scm-68040 index 26e1ff7c7..32a91baed 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.72 1990/04/03 04:50:08 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 4.73 1990/05/03 15:17:24 jinx Exp $ Copyright (c) 1988, 1989, 1990 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 (Motorola MC68020)" 4 72 '())) \ No newline at end of file +(add-system! (make-system "Liar (Motorola MC68020)" 4 73 '())) \ No newline at end of file diff --git a/v7/src/compiler/machines/bobcat/rules1.scm b/v7/src/compiler/machines/bobcat/rules1.scm index 30add54c7..675a8c25c 100644 --- a/v7/src/compiler/machines/bobcat/rules1.scm +++ b/v7/src/compiler/machines/bobcat/rules1.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules1.scm,v 4.32 1990/01/18 22:43:54 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules1.scm,v 4.33 1990/05/03 15:17:28 jinx Rel $ Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology @@ -33,6 +33,7 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; LAP Generation Rules: Data Transfers +;;; package: (compiler lap-syntaxer) (declare (usual-integrations)) @@ -51,38 +52,61 @@ MIT in each case. |# (define-rule statement (ASSIGN (REGISTER (? target)) (OFFSET-ADDRESS (REGISTER (? source)) (? n))) - (load-static-link target source n false)) + (load-static-link target source (* 4 n) false)) (define-rule statement ;; This is an intermediate rule -- not intended to produce code. (ASSIGN (REGISTER (? target)) (CONS-POINTER (MACHINE-CONSTANT (? type)) (OFFSET-ADDRESS (REGISTER (? source)) (? n)))) - (load-static-link target source n + (load-static-link target source (* 4 n) (lambda (target) (LAP (OR UL (& ,(make-non-pointer-literal type 0)) ,target))))) +(define-rule statement + (ASSIGN (REGISTER (? target)) + (BYTE-OFFSET-ADDRESS (REGISTER (? source)) (? n))) + (load-static-link target source n false)) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (CONS-POINTER (MACHINE-CONSTANT (? type)) + (BYTE-OFFSET-ADDRESS (REGISTER (? source)) (? n)))) + (load-static-link target source n + (lambda (target) + (LAP (OR UL (& ,(make-non-pointer-literal type 0)) ,target))))) + (define (load-static-link target source n suffix) (if (and (zero? n) (not suffix)) (assign-register->register target source) (let ((non-reusable - (if (not suffix) - (lambda () - (let ((source (allocate-indirection-register! source))) - (delete-dead-registers!) - (let ((target (allocate-alias-register! target 'ADDRESS))) - (if (eqv? source target) - (increment-machine-register target n) - (LAP (LEA ,(offset-reference source n) - ,(register-reference target))))))) - (lambda () - (let ((source (indirect-reference! source n))) - (delete-dead-registers!) - (let ((temp (reference-temporary-register! 'ADDRESS))) - (let ((target (reference-target-alias! target 'DATA))) - (LAP (LEA ,source ,temp) - (MOV L ,temp ,target) - ,@(suffix target))))))))) + (cond ((not suffix) + (lambda () + (let ((source (allocate-indirection-register! source))) + (delete-dead-registers!) + (let ((target (allocate-alias-register! target + 'ADDRESS))) + (if (eqv? source target) + (increment-machine-register target n) + (LAP (LEA ,(byte-offset-reference source n) + ,(register-reference target)))))))) + ((<= -128 n 127) + (lambda () + (let ((source (register-reference source))) + (delete-dead-registers!) + (let ((target (reference-target-alias! target 'DATA))) + (LAP (MOVEQ (& ,n) ,target) + (ADD L ,source ,target)))))) + (else + (lambda () + (let ((source (indirect-byte-reference! source n))) + (delete-dead-registers!) + (let ((temp (reference-temporary-register! 'ADDRESS))) + (let ((target (reference-target-alias! target + 'DATA))) + (LAP (LEA ,source ,temp) + (MOV L ,temp ,target) + ,@(suffix target)))))))))) (if (machine-register? source) (non-reusable) (reuse-pseudo-register-alias! source 'DATA @@ -166,17 +190,17 @@ MIT in each case. |# (define-rule statement (ASSIGN (REGISTER (? target)) (CONSTANT (? source))) - (LAP ,(load-constant source (standard-target-reference target)))) + (load-constant source (standard-target-reference target))) (define-rule statement (ASSIGN (REGISTER (? target)) (MACHINE-CONSTANT (? n))) - (LAP ,(load-machine-constant n (standard-target-reference target)))) + (load-machine-constant n (standard-target-reference target))) (define-rule statement (ASSIGN (REGISTER (? target)) (CONS-POINTER (MACHINE-CONSTANT (? type)) (MACHINE-CONSTANT (? datum)))) - (LAP ,(load-non-pointer type datum (standard-target-reference target)))) + (load-non-pointer type datum (standard-target-reference target))) (define-rule statement (ASSIGN (REGISTER (? target)) (ENTRY:PROCEDURE (? label))) @@ -246,8 +270,8 @@ MIT in each case. |# (delete-dead-registers!) (let ((target (reference-target-alias! target 'DATA))) (if (non-pointer-object? constant) - (LAP ,(load-non-pointer 0 (careful-object-datum constant) target)) - (LAP ,(load-constant constant target) + (load-non-pointer 0 (careful-object-datum constant) target) + (LAP ,@(load-constant constant target) ,@(conversion target))))) (define-rule statement @@ -306,13 +330,13 @@ MIT in each case. |# (define-rule statement (ASSIGN (OFFSET (REGISTER (? a)) (? n)) (CONSTANT (? object))) - (LAP ,(load-constant object (indirect-reference! a n)))) + (load-constant object (indirect-reference! a n))) (define-rule statement (ASSIGN (OFFSET (REGISTER (? a)) (? n)) (CONS-POINTER (MACHINE-CONSTANT (? type)) (MACHINE-CONSTANT (? datum)))) - (LAP ,(load-non-pointer type datum (indirect-reference! a n)))) + (load-non-pointer type datum (indirect-reference! a n))) (define-rule statement (ASSIGN (OFFSET (REGISTER (? a)) (? n)) (REGISTER (? r))) @@ -343,6 +367,36 @@ MIT in each case. |# (MOV L ,temp ,target) ,(memory-set-type type target)))) +(define-rule statement + (ASSIGN (OFFSET (REGISTER (? address)) (? offset)) + (CONS-POINTER (MACHINE-CONSTANT (? type)) + (BYTE-OFFSET-ADDRESS (REGISTER (? source)) (? n)))) + (let ((temp (reference-temporary-register! 'ADDRESS)) + (target (indirect-reference! address offset))) + (LAP (LEA ,(indirect-byte-reference! source n) ,temp) + (MOV L ,temp ,target) + ,(memory-set-type type target)))) + +;; Common case that can be done cheaply: + +(define-rule statement + (ASSIGN (OFFSET (REGISTER (? address)) (? offset)) + (BYTE-OFFSET-ADDRESS (OFFSET (REGISTER (? address)) (? offset)) + (? n))) + (if (zero? n) + (LAP) + (let ((target (indirect-byte-reference! address offset))) + (cond ((<= 1 n 8) + (LAP (ADDQ L (& ,n) ,target))) + ((<= -8 n -1) + (LAP (SUBQ L (& ,(- n)) ,target))) + ((<= -128 n 127) + (let ((temp (reference-temporary-register! 'DATA))) + (LAP (MOVEQ (& ,n) ,temp) + (ADD L ,temp ,target)))) + (else + (LAP (ADD L (& ,n) ,target))))))) + (define-rule statement (ASSIGN (OFFSET (REGISTER (? address)) (? offset)) (CONS-POINTER (MACHINE-CONSTANT (? type)) @@ -374,13 +428,13 @@ MIT in each case. |# (define-rule statement (ASSIGN (POST-INCREMENT (REGISTER 13) 1) (CONSTANT (? object))) - (LAP ,(load-constant object (INST-EA (@A+ 5))))) + (load-constant object (INST-EA (@A+ 5)))) (define-rule statement (ASSIGN (POST-INCREMENT (REGISTER 13) 1) (CONS-POINTER (MACHINE-CONSTANT (? type)) (MACHINE-CONSTANT (? datum)))) - (LAP ,(load-non-pointer type datum (INST-EA (@A+ 5))))) + (load-non-pointer type datum (INST-EA (@A+ 5)))) (define-rule statement (ASSIGN (POST-INCREMENT (REGISTER 13) 1) (REGISTER (? r))) @@ -412,7 +466,7 @@ MIT in each case. |# (define-rule statement (ASSIGN (PRE-INCREMENT (REGISTER 15) -1) (CONSTANT (? object))) - (LAP ,(load-constant object (INST-EA (@-A 7))))) + (load-constant object (INST-EA (@-A 7)))) (define-rule statement (ASSIGN (PRE-INCREMENT (REGISTER 15) -1) @@ -424,7 +478,7 @@ MIT in each case. |# (ASSIGN (PRE-INCREMENT (REGISTER 15) -1) (CONS-POINTER (MACHINE-CONSTANT (? type)) (MACHINE-CONSTANT (? datum)))) - (LAP ,(load-non-pointer type datum (INST-EA (@-A 7))))) + (load-non-pointer type datum (INST-EA (@-A 7)))) (define-rule statement (ASSIGN (PRE-INCREMENT (REGISTER 15) -1) @@ -447,6 +501,13 @@ MIT in each case. |# (LAP (PEA ,(indirect-reference! r n)) ,(memory-set-type type (INST-EA (@A 7))))) +(define-rule statement + (ASSIGN (PRE-INCREMENT (REGISTER 15) -1) + (CONS-POINTER (MACHINE-CONSTANT (? type)) + (BYTE-OFFSET-ADDRESS (REGISTER (? r)) (? n)))) + (LAP (PEA ,(indirect-byte-reference! r n)) + ,(memory-set-type type (INST-EA (@A 7))))) + (define-rule statement (ASSIGN (PRE-INCREMENT (REGISTER 15) -1) (OFFSET (REGISTER (? r)) (? n))) (LAP (MOV L ,(indirect-reference! r n) (@-A 7)))) @@ -606,9 +667,9 @@ MIT in each case. |# (let ((target (reference-target-alias! target 'DATA))) (LAP (MOV L (A 5) ,target) (OR L (& ,(make-non-pointer-literal (ucode-type flonum) 0)) ,target) - ,(load-non-pointer (ucode-type manifest-nm-vector) - flonum-size - (INST-EA (@A+ 5))) + ,@(load-non-pointer (ucode-type manifest-nm-vector) + flonum-size + (INST-EA (@A+ 5))) (FMOVE D ,source (@A+ 5)))))) (define-rule statement @@ -657,7 +718,7 @@ MIT in each case. |# (define (load-char-into-register type source target) (delete-dead-registers!) (let ((target (reference-target-alias! target 'DATA))) - (LAP ,(load-non-pointer type 0 target) + (LAP ,@(load-non-pointer type 0 target) (MOV B ,source ,target)))) (define-rule statement diff --git a/v7/src/compiler/machines/bobcat/rules3.scm b/v7/src/compiler/machines/bobcat/rules3.scm index 3f39ea401..f99ca5bb3 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.23 1990/01/18 22:44:09 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules3.scm,v 4.24 1990/05/03 15:17:33 jinx Exp $ Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology @@ -33,6 +33,7 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; LAP Generation Rules: Invocations and Entries +;;; package: (compiler lap-syntaxer) (declare (usual-integrations)) @@ -133,7 +134,7 @@ MIT in each case. |# (delete-dead-registers!) (LAP ,@set-environment ,@(clear-map!) - ,(load-constant name (INST-EA (D 2))) + ,@(load-constant name (INST-EA (D 2))) ,(load-dnl frame-size 3) ,@(invoke-interface code:compiler-lookup-apply)))) @@ -205,10 +206,10 @@ MIT in each case. |# (cond ((zero? how-far) (LAP)) ((zero? frame-size) - (increment-machine-register 15 how-far)) + (increment-machine-register 15 (* 4 how-far))) ((= frame-size 1) (LAP (MOV L (@A+ 7) ,(offset-reference a7 (-1+ how-far))) - ,@(increment-machine-register 15 (-1+ how-far)))) + ,@(increment-machine-register 15 (* 4 (-1+ how-far))))) ((= frame-size 2) (if (= how-far 1) (LAP (MOV L (@AO 7 4) (@AO 7 8)) @@ -218,7 +219,7 @@ MIT in each case. |# ,(offset-reference a7 (-1+ how-far))))))) (LAP ,(i) ,(i) - ,@(increment-machine-register 15 (- how-far 2)))))) + ,@(increment-machine-register 15 (* 4 (- how-far 2))))))) (else (generate/move-frame-up frame-size (offset-reference a7 offset)))))) @@ -322,20 +323,22 @@ MIT in each case. |# (define internal-entry-code-word (make-code-word #xff #xfe)) +(define (frame-size->code-word offset) + (cond ((not offset) + (make-code-word #xff #xfc)) + ((< offset #x2000) + ;; This uses up through (#xff #xdf). + (let ((qr (integer-divide offset #x80))) + (make-code-word (+ #x80 (integer-divide-remainder qr)) + (+ #x80 (integer-divide-quotient qr))))) + (else + (error "Unable to encode continuation offset" offset)))) + (define (continuation-code-word label) - (let ((offset - (if label - (rtl-continuation/next-continuation-offset (label->object label)) - 0))) - (cond ((not offset) - (make-code-word #xff #xfc)) - ((< offset #x2000) - ;; This uses up through (#xff #xdf). - (let ((qr (integer-divide offset #x80))) - (make-code-word (+ #x80 (integer-divide-remainder qr)) - (+ #x80 (integer-divide-quotient qr))))) - (else - (error "Unable to encode continuation offset" offset))))) + (frame-size->code-word + (if label + (rtl-continuation/next-continuation-offset (label->object label)) + 0))) ;;;; Procedure headers @@ -415,56 +418,57 @@ MIT in each case. |# entry:compiler-interrupt-procedure))) ;;;; Closures. These two statements are intertwined: +;;; Note: If the closure is a multiclosure, the closure object on the +;;; stack corresponds to the first (official) entry point. +;;; Thus on entry and interrupt it must be bumped around. -(define magic-closure-constant - (- (make-non-pointer-literal (ucode-type compiled-entry) 0) 6)) +(define (make-magic-closure-constant entry) + (- (make-non-pointer-literal (ucode-type compiled-entry) 0) + (+ (* entry 10) 6))) (define-rule statement - (CLOSURE-HEADER (? internal-label)) + (CLOSURE-HEADER (? internal-label) (? nentries) (? entry)) + nentries ; ignored (let ((procedure (label->object internal-label))) (let ((gc-label (generate-label)) (external-label (rtl-procedure/external-label procedure))) - (LAP (LABEL ,gc-label) - (JMP ,entry:compiler-interrupt-closure) - ,@(make-external-label internal-entry-code-word external-label) - (ADD UL (& ,magic-closure-constant) (@A 7)) - (LABEL ,internal-label) - (CMP L ,reg:compiled-memtop (A 5)) - (B GE B (@PCR ,gc-label)))))) + (if (zero? nentries) + (LAP (EQUATE ,external-label ,internal-label) + ,@(simple-procedure-header internal-entry-code-word + internal-label + entry:compiler-interrupt-procedure)) + (LAP (LABEL ,gc-label) + ,@(let ((distance (* 10 entry))) + (cond ((zero? distance) + (LAP)) + ((< distance 128) + (LAP (MOVEQ (& ,distance) (D 0)) + (ADD L (D 0) (@A 7)))) + (else + (LAP (ADD L (& ,distance) (@A 7)))))) + (JMP ,entry:compiler-interrupt-closure) + ,@(make-external-label internal-entry-code-word + external-label) + (ADD UL (& ,(make-magic-closure-constant entry)) (@A 7)) + (LABEL ,internal-label) + (CMP L ,reg:compiled-memtop (A 5)) + (B GE B (@PCR ,gc-label))))))) (define-rule statement (ASSIGN (REGISTER (? target)) (CONS-CLOSURE (ENTRY:PROCEDURE (? procedure-label)) (? min) (? max) (? size))) - (generate/cons-closure (reference-target-alias! target 'DATA) + (generate/cons-closure (reference-target-alias! target 'ADDRESS) false procedure-label min max size)) -(define-rule statement - (ASSIGN (REGISTER (? target)) - (CONS-POINTER (MACHINE-CONSTANT (? type)) - (CONS-CLOSURE (ENTRY:PROCEDURE (? procedure-label)) - (? min) (? max) (? size)))) - (generate/cons-closure (reference-target-alias! target 'DATA) - type procedure-label min max size)) - -(define-rule statement - (ASSIGN (? target) - (CONS-POINTER (MACHINE-CONSTANT (? type)) - (CONS-CLOSURE (ENTRY:PROCEDURE (? procedure-label)) - (? min) (? max) (? size)))) - (QUALIFIER (standard-target-expression? target)) - (let ((temporary (reference-temporary-register! 'DATA))) - (LAP ,@(generate/cons-closure temporary type procedure-label min max size) - (MOV L ,temporary ,(standard-target-expression->ea target))))) - (define (generate/cons-closure target type procedure-label min max size) (let ((temporary (reference-temporary-register! 'ADDRESS))) (LAP (LEA (@PCR ,(rtl-procedure/external-label (label->object procedure-label))) ,temporary) - ,(load-non-pointer (ucode-type manifest-closure) - (+ 3 size) - (INST-EA (@A+ 5))) + ,@(load-non-pointer (ucode-type manifest-closure) + (+ 3 size) + (INST-EA (@A+ 5))) (MOV UL (& ,(+ (* (make-procedure-code-word min max) #x10000) 8)) (@A+ 5)) @@ -475,7 +479,70 @@ MIT in each case. |# (MOV UW (& #x4eb9) (@A+ 5)) ; (JSR (L )) (MOV L ,temporary (@A+ 5)) (CLR W (@A+ 5)) - ,@(increment-machine-register 13 size)))) + ,@(increment-machine-register 13 (* 4 size))))) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (CONS-MULTICLOSURE (? nentries) (? size) (? entries))) + (let ((target (reference-target-alias! target 'ADDRESS))) + (case nentries + ((0) + (LAP (MOV L (A 5) ,target) + ,@(load-non-pointer (ucode-type manifest-vector) + size + (INST-EA (@A+ 5))) + ,@(increment-machine-register 13 (* 4 size)))) + ((1) + (let ((entry (vector-ref entries 0))) + (generate/cons-closure target false + (car entry) (cadr entry) (caddr entry) + size))) + (else + (generate/cons-multiclosure target nentries size + (vector->list entries)))))) + +(define (generate/cons-multiclosure target nentries size entries) + (let ((total-size (+ size + (quotient (+ 3 (* 5 nentries)) + 2))) + (temp1 (reference-temporary-register! 'ADDRESS)) + (temp2 (reference-temporary-register! 'DATA))) + + (define (generate-entries entries offset first?) + (if (null? entries) + (LAP) + (let ((entry (car entries))) + (LAP (MOV UL (& ,(+ (* (make-procedure-code-word (cadr entry) + (caddr entry)) + #x10000) + offset)) + (@A+ 5)) + ,@(if first? + (LAP (MOV L (A 5) ,target)) + (LAP)) + (LEA (@PCR ,(rtl-procedure/external-label + (label->object (car entry)))) + ,temp1) + (MOV W ,temp2 (@A+ 5)) ; (JSR (L )) + (MOV L ,temp1 (@A+ 5)) + ,@(generate-entries (cdr entries) + (+ 10 offset) + false))))) + + (LAP ,@(load-non-pointer (ucode-type manifest-closure) + total-size + (INST-EA (@A+ 5))) + (MOV UL (& ,(* nentries #x10000)) (@A+ 5)) + (MOV UW (& #x4eb9) ,temp2) + ,@(generate-entries entries + (if (= nentries 1) + 8 + 12) + true) + ,@(if (odd? nentries) + (LAP (CLR W (@A+ 5))) + (LAP)) + ,@(increment-machine-register 13 (* 4 size))))) ;;;; Entry Header ;;; This is invoked by the top level of the LAP generator. diff --git a/v7/src/compiler/machines/bobcat/rules4.scm b/v7/src/compiler/machines/bobcat/rules4.scm index 1e693db5a..f54ec0cf2 100644 --- a/v7/src/compiler/machines/bobcat/rules4.scm +++ b/v7/src/compiler/machines/bobcat/rules4.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules4.scm,v 4.11 1990/01/20 07:26:13 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules4.scm,v 4.12 1990/05/03 15:17:38 jinx Rel $ Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology @@ -54,14 +54,14 @@ MIT in each case. |# (load-machine-register! (rtl:register-number expression) register)) ((CONSTANT) (LAP ,@(clear-registers! register) - ,(load-constant (rtl:constant-value expression) target))) + ,@(load-constant (rtl:constant-value expression) target))) ((CONS-POINTER) (LAP ,@(clear-registers! register) - ,(load-non-pointer (rtl:machine-constant-value - (rtl:cons-pointer-type expression)) - (rtl:machine-constant-value - (rtl:cons-pointer-datum expression)) - target))) + ,@(load-non-pointer (rtl:machine-constant-value + (rtl:cons-pointer-type expression)) + (rtl:machine-constant-value + (rtl:cons-pointer-datum expression)) + target))) ((OFFSET) (let ((source-reference (offset->indirect-reference! expression))) (LAP ,@(clear-registers! register) @@ -96,7 +96,7 @@ MIT in each case. |# (let ((clear-map (clear-map!))) (LAP ,@set-environment ,@clear-map - ,(load-constant name (INST-EA (D 3))) + ,@(load-constant name (INST-EA (D 3))) ,@(invoke-interface-jsr code))))) (define-rule statement @@ -119,7 +119,7 @@ MIT in each case. |# (LAP ,@set-environment ,@set-value ,@clear-map - ,(load-constant name (INST-EA (D 3))) + ,@(load-constant name (INST-EA (D 3))) ,@(invoke-interface-jsr code)))))) (define-rule statement diff --git a/v7/src/compiler/machines/bobcat/rulrew.scm b/v7/src/compiler/machines/bobcat/rulrew.scm index c2ca7efd2..e89bbce80 100644 --- a/v7/src/compiler/machines/bobcat/rulrew.scm +++ b/v7/src/compiler/machines/bobcat/rulrew.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rulrew.scm,v 1.2 1990/04/03 04:52:22 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rulrew.scm,v 1.3 1990/05/03 15:17:42 jinx Rel $ Copyright (c) 1990 Massachusetts Institute of Technology @@ -33,6 +33,7 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; RTL Rewrite Rules +;;; package: (compiler lap-syntaxer) (declare (usual-integrations)) @@ -77,7 +78,8 @@ MIT in each case. |# (define-rule rewriting (OBJECT->DATUM (REGISTER (? source register-known-value))) (QUALIFIER (rtl:constant-non-pointer? source)) - (rtl:make-machine-constant (careful-object-datum (rtl:constant-value source)))) + (rtl:make-machine-constant + (careful-object-datum (rtl:constant-value source)))) (define (rtl:constant-non-pointer? expression) (and (rtl:constant? expression) diff --git a/v7/src/compiler/rtlbase/rtlcon.scm b/v7/src/compiler/rtlbase/rtlcon.scm index a4b7e90d8..2b0395652 100644 --- a/v7/src/compiler/rtlbase/rtlcon.scm +++ b/v7/src/compiler/rtlbase/rtlcon.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlcon.scm,v 4.20 1990/01/18 22:45:15 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlcon.scm,v 4.21 1990/05/03 15:10:19 jinx Rel $ Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology @@ -33,6 +33,7 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; Register Transfer Language: Complex Constructors +;;; package: (compiler) (declare (usual-integrations)) @@ -463,12 +464,44 @@ MIT in each case. |# (lambda (element) (loop (cdr elements*) (cons element simplified-elements))))))))))) - + (define-expression-method 'TYPED-CONS:PROCEDURE - ;; A NOP for simplification - (lambda (receiver scfg-append! type entry min max size) - scfg-append! - (receiver (rtl:make-typed-cons:procedure type entry min max size)))) + (lambda (receiver scfg-append! entry) + (expression-simplify + entry scfg-append! + (lambda (entry) + (receiver (rtl:make-cons-pointer + (rtl:make-machine-constant type-code:compiled-entry) + entry)))))) + +(define-expression-method 'BYTE-OFFSET-ADDRESS + (lambda (receiver scfg-append! base number) + (expression-simplify + base scfg-append! + (lambda (base) + (receiver (rtl:make-byte-offset-address base number)))))) + +;; NOPs for simplification + +(define-expression-method 'ENTRY:CONTINUATION + (lambda (receiver scfg-append! label) + scfg-append! ; unused + (receiver (rtl:make-entry:continuation label)))) + +(define-expression-method 'ENTRY:PROCEDURE + (lambda (receiver scfg-append! label) + scfg-append! ; unused + (receiver (rtl:make-entry:procedure label)))) + +(define-expression-method 'CONS-CLOSURE + (lambda (receiver scfg-append! entry min max size) + scfg-append! ; unused + (receiver (rtl:make-cons-closure entry min max size)))) + +(define-expression-method 'CONS-MULTICLOSURE + (lambda (receiver scfg-append! nentries size entries) + scfg-append! ; unused + (receiver (rtl:make-cons-multiclosure nentries size entries)))) (define (object-selector make-object-selector) (lambda (receiver scfg-append! expression) diff --git a/v7/src/compiler/rtlbase/rtlexp.scm b/v7/src/compiler/rtlbase/rtlexp.scm index b0af89422..a59060c71 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.15 1990/01/18 22:45:35 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlexp.scm,v 4.16 1990/05/03 15:10:27 jinx Rel $ Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology @@ -33,6 +33,7 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; Register Transfer Language: Expression Operations +;;; package: (compiler) (declare (usual-integrations)) @@ -59,16 +60,23 @@ MIT in each case. |# ((REGISTER) (register-value-class (rtl:register-number expression))) ((CONS-POINTER CONSTANT FIXNUM->OBJECT FLOAT->OBJECT GENERIC-BINARY - GENERIC-UNARY OFFSET POST-INCREMENT PRE-INCREMENT) + GENERIC-UNARY OFFSET POST-INCREMENT PRE-INCREMENT + ;; This is a lie, but it is the only way in which it is + ;; used now! It should be moved to value-class=address, + ;; and a cast type introduced to handle current usage. + BYTE-OFFSET-ADDRESS) value-class=object) - ((ASSIGNMENT-CACHE FIXNUM->ADDRESS OBJECT->ADDRESS OFFSET-ADDRESS - VARIABLE-CACHE) + ((FIXNUM->ADDRESS OBJECT->ADDRESS + OFFSET-ADDRESS + ASSIGNMENT-CACHE VARIABLE-CACHE + CONS-CLOSURE CONS-MULTICLOSURE + ENTRY:CONTINUATION ENTRY:PROCEDURE) value-class=address) ((MACHINE-CONSTANT) value-class=immediate) ((BYTE-OFFSET CHAR->ASCII) value-class=ascii) - ((CONS-CLOSURE ENTRY:CONTINUATION ENTRY:PROCEDURE OBJECT->DATUM) + ((OBJECT->DATUM) value-class=datum) ((ADDRESS->FIXNUM FIXNUM-1-ARG FIXNUM-2-ARGS OBJECT->FIXNUM OBJECT->UNSIGNED-FIXNUM) @@ -246,6 +254,7 @@ MIT in each case. |# (memq (rtl:expression-type expression) '(ASSIGNMENT-CACHE CONS-CLOSURE + CONS-MULTICLOSURE CONSTANT ENTRY:CONTINUATION ENTRY:PROCEDURE @@ -263,7 +272,8 @@ MIT in each case. |# MACHINE-CONSTANT VARIABLE-CACHE) true) - ((CHAR->ASCII + ((BYTE-OFFSET-ADDRESS + CHAR->ASCII CONS-POINTER FIXNUM-1-ARG FIXNUM-2-ARGS diff --git a/v7/src/compiler/rtlbase/rtlty1.scm b/v7/src/compiler/rtlbase/rtlty1.scm index 6c50ed491..941700a76 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.16 1990/01/18 22:45:49 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlty1.scm,v 4.17 1990/05/03 15:10:31 jinx Rel $ Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology @@ -33,6 +33,7 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; Register Transfer Language Type Definitions +;;; package: (compiler) (declare (usual-integrations)) @@ -64,7 +65,10 @@ MIT in each case. |# (define-rtl-expression entry:procedure rtl: procedure) ;;; Allocating a closure object (returns its address) -(define-rtl-expression cons-closure rtl: procedure min max size) +(define-rtl-expression cons-closure rtl: entry min max size) +;;; Allocating a multi-closure object +;;; (returns the address of first entry point) +(define-rtl-expression cons-multiclosure rtl: nentries size entries) ;;; Cache addresses (define-rtl-expression assignment-cache rtl: name) @@ -79,6 +83,7 @@ MIT in each case. |# ;;; Add a constant offset to an address (define-rtl-expression offset-address rtl: base number) +(define-rtl-expression byte-offset-address rtl: base number) ;;; A machine constant (an integer, usually unsigned) (define-rtl-expression machine-constant rtl: value) @@ -134,7 +139,7 @@ MIT in each case. |# (define-rtl-statement ic-procedure-header rtl: procedure) (define-rtl-statement open-procedure-header rtl: procedure) (define-rtl-statement procedure-header rtl: procedure min max) -(define-rtl-statement closure-header rtl: procedure) +(define-rtl-statement closure-header rtl: procedure nentries entry) (define-rtl-statement interpreter-call:access % environment name) (define-rtl-statement interpreter-call:define % environment name value) diff --git a/v7/src/compiler/rtlbase/rtlty2.scm b/v7/src/compiler/rtlbase/rtlty2.scm index fa6dfaa00..d5ae4e5df 100644 --- a/v7/src/compiler/rtlbase/rtlty2.scm +++ b/v7/src/compiler/rtlbase/rtlty2.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlty2.scm,v 4.8 1990/01/18 22:45:53 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlty2.scm,v 4.9 1990/05/03 15:10:34 jinx Rel $ Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology @@ -33,6 +33,7 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; Register Transfer Language Type Definitions +;;; package: (compiler) (declare (usual-integrations)) @@ -150,8 +151,8 @@ MIT in each case. |# (define-integrable (rtl:make-typed-cons:vector type elements) `(TYPED-CONS:VECTOR ,type ,@elements)) -(define-integrable (rtl:make-typed-cons:procedure label arg-info nvars) - `(TYPED-CONS:PROCEDURE ,label ,arg-info ,nvars)) +(define-integrable (rtl:make-typed-cons:procedure entry) + `(TYPED-CONS:PROCEDURE ,entry)) ;;; Linearizer Support diff --git a/v7/src/compiler/rtlgen/fndblk.scm b/v7/src/compiler/rtlgen/fndblk.scm index f460c50dc..638d4ccfe 100644 --- a/v7/src/compiler/rtlgen/fndblk.scm +++ b/v7/src/compiler/rtlgen/fndblk.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/fndblk.scm,v 4.10 1988/12/12 21:52:15 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/fndblk.scm,v 4.11 1990/05/03 15:11:36 jinx Rel $ -Copyright (c) 1988 Massachusetts Institute of Technology +Copyright (c) 1988, 1990 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -33,6 +33,7 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; RTL Generation: Environment Locatives +;;; package: (compiler rtl-generator find-block) (declare (usual-integrations)) @@ -150,9 +151,10 @@ MIT in each case. |# 'TRIVIAL-CLOSURE-BOGUS-LOCATIVE) (define (closure-block/parent-locative block context locative) - block context + context (rtl:make-fetch - (rtl:locative-offset locative closure-block-first-offset))) + (rtl:locative-offset locative + (closure-block-first-offset block)))) (define (stack-block/parent-of-dummy-closure-locative block context locative) (closure-block/parent-locative diff --git a/v7/src/compiler/rtlgen/fndvar.scm b/v7/src/compiler/rtlgen/fndvar.scm index e9d9b32a7..077b92c17 100644 --- a/v7/src/compiler/rtlgen/fndvar.scm +++ b/v7/src/compiler/rtlgen/fndvar.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/fndvar.scm,v 1.4 1990/03/28 06:11:14 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/fndvar.scm,v 1.5 1990/05/03 15:11:40 jinx Rel $ Copyright (c) 1988, 1990 Massachusetts Institute of Technology @@ -33,45 +33,38 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; RTL Generation: Variable Locatives +;;; package: (compiler rtl-generator) (declare (usual-integrations)) -(define (find-variable context variable if-compiler if-ic if-cached) - (if (variable/value-variable? variable) - (if-compiler - (let ((continuation (reference-context/procedure context))) - (if (continuation/ever-known-operator? continuation) - (continuation/register continuation) - register:value))) - (find-variable-internal context variable - (lambda (variable locative) - (if-compiler - (if (variable-in-cell? variable) - (rtl:make-fetch locative) - locative))) - (lambda (variable block locative) - (cond ((variable-in-known-location? context variable) - (if-compiler - (rtl:locative-offset locative - (variable-offset block variable)))) - ((ic-block/use-lookup? block) - (if-ic locative (variable-name variable))) - (else - (if-cached (variable-name variable)))))))) +(define-integrable (find-variable/locative context variable + if-compiler if-ic if-cached) + (find-variable false context variable if-compiler if-ic if-cached)) + +(define-integrable (find-variable/value context variable + if-compiler if-ic if-cached) + (find-variable true context variable if-compiler if-ic if-cached)) + +(define-integrable (find-variable/value/simple context variable message) + (find-variable/value context variable + identity-procedure + (lambda (environment name) + environment ; ignored + (error message name)) + (lambda (name) + (error message name)))) (define (find-known-variable context variable) - (find-variable context variable identity-procedure - (lambda (environment name) - environment - (error "Known variable found in IC frame" name)) - (lambda (name) - (error "Known variable found in IC frame" name)))) + (find-variable/value/simple + context variable + "find-known-variable: Known variable found in IC frame")) (define (find-closure-variable context variable) (find-variable-internal context variable + identity-procedure (lambda (variable locative) - variable - locative) + variable ; ignored + (rtl:make-fetch locative)) (lambda (variable block locative) block locative (error "Closure variable in IC frame" variable)))) @@ -83,36 +76,110 @@ MIT in each case. |# locative) (lambda (variable block locative) block locative - (error "Stack overwrite slot in IC frame" variable)))) + (error "Stack overwrite slot in IC frame" variable)))) + +(define (find-variable get-value? context variable if-compiler if-ic if-cached) + (let ((if-locative + (if get-value? + (lambda (locative) + (if-compiler (rtl:make-fetch locative))) + if-compiler))) + (if (variable/value-variable? variable) + (if-locative + (let ((continuation (reference-context/procedure context))) + (if (continuation/ever-known-operator? continuation) + (continuation/register continuation) + register:value))) + (find-variable-internal context variable + (and get-value? if-compiler) + (lambda (variable locative) + (if-locative + (if (variable-in-cell? variable) + (rtl:make-fetch locative) + locative))) + (lambda (variable block locative) + (cond ((variable-in-known-location? context variable) + (if-locative + (rtl:locative-offset locative + (variable-offset block variable)))) + ((ic-block/use-lookup? block) + (if-ic locative (variable-name variable))) + (else + (if-cached (variable-name variable))))))))) -(define (find-variable-internal context variable if-compiler if-ic) - (let ((rvalue (lvalue-known-value variable))) - (if (and rvalue - (rvalue/procedure? rvalue) - (procedure/closure? rvalue) - (block-ancestor-or-self? (reference-context/block context) - (procedure-block rvalue))) - (begin - ;; This is just for paranoia. - (if (procedure/trivial-closure? rvalue) - (error "Trivial closure value encountered")) - (if-compiler - variable - (block-ancestor-or-self->locative - context - (procedure-block rvalue) - 0 - (procedure-closure-offset rvalue)))) - (let loop ((variable variable)) - (let ((indirection (variable-indirection variable))) - (if indirection - (loop indirection) - (let ((register (variable/register variable))) - (if register - (if-compiler variable (register-locative register)) - (find-variable-no-tricks context variable - if-compiler if-ic))))))))) +(define (find-variable-internal context variable if-value if-locative if-ic) + (define (loop variable) + (let ((indirection (variable-indirection variable))) + (cond ((not indirection) + (let ((register (variable/register variable))) + (if register + (if-locative variable (register-locative register)) + (find-variable-no-tricks context variable + if-locative if-ic)))) + ((not (cdr indirection)) + (loop (car indirection))) + (else + (error "find-variable-internal: Indirection not for value" + variable))))) + (let ((rvalue (lvalue-known-value variable))) + (cond ((or (not if-value) + (not rvalue)) + (loop variable)) + ((rvalue/block? rvalue) + (let* ((sblock (block-nearest-closure-ancestor + (reference-context/block context))) + (cblock (and sblock (block-parent sblock)))) + (if (and cblock (eq? rvalue (block-shared-block cblock))) + (if-value + (redirect-closure context + sblock + (block-procedure sblock) + (indirection-block-procedure rvalue))) + (loop variable)))) + ((not (rvalue/procedure? rvalue)) + (loop variable)) + ((procedure/trivial-or-virtual? rvalue) + (if-value (make-trivial-closure-cons rvalue))) + ((not (procedure/closure? rvalue)) + (error "find-variable-internal: Reference to open procedure" + context variable) + (loop variable)) + (else + (let ((nearest-closure (block-nearest-closure-ancestor + (reference-context/block context))) + (closing-block (procedure-closing-block rvalue))) + (if (and nearest-closure + (eq? (block-shared-block closing-block) + (block-shared-block + (block-parent nearest-closure)))) + (if-value + (redirect-closure context + nearest-closure + (block-procedure nearest-closure) + rvalue)) + (let ((indirection (variable-indirection variable))) + (cond ((not indirection) + (loop variable)) + ((not (cdr indirection)) + (loop (car indirection))) + (else + (let ((source (car indirection))) + ;; Should not be indirected. + (find-variable-no-tricks + context source + (lambda (variable locative) + variable ; ignored + (if-value (make-closure-redirection + (rtl:make-fetch locative) + (indirection-block-procedure + (lvalue-known-value source)) + rvalue))) + (lambda (new-variable block locative) + new-variable block locative ; ignored + (error "find-variable-internal: Bad indirection" + variable))))))))))))) + (define (find-variable-no-tricks context variable if-compiler if-ic) (find-block/variable context variable (lambda (offset-locative) @@ -122,7 +189,7 @@ MIT in each case. |# (variable-offset block variable))))) (lambda (block locative) (if-ic variable block locative)))) - + (define (find-definition-variable context lvalue) (find-block/variable context lvalue (lambda (offset-locative) @@ -153,7 +220,7 @@ MIT in each case. |# ((IC) if-ic) (else (error "Illegal result type" block))) block locative)))) - + (define (nearest-ic-block-expression context) (with-values (lambda () diff --git a/v7/src/compiler/rtlgen/opncod.scm b/v7/src/compiler/rtlgen/opncod.scm index 51c83e32b..498378a46 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.36 1990/04/03 06:01:54 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/opncod.scm,v 4.37 1990/05/03 15:11:44 jinx Exp $ Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology @@ -33,6 +33,7 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; RTL Generation: Inline Combinations +;;; package: (compiler rtl-generator combination/inline) (declare (usual-integrations)) @@ -148,9 +149,8 @@ MIT in each case. |# ((and (rvalue/reference? rvalue) (not (variable/value-variable? (reference-lvalue rvalue))) (reference-to-known-location? rvalue)) - (rtl:make-fetch - (find-known-variable (reference-context rvalue) - (reference-lvalue rvalue)))) + (find-known-variable (reference-context rvalue) + (reference-lvalue rvalue))) (else (rtl:make-fetch (continuation*/register diff --git a/v7/src/compiler/rtlgen/rgcomb.scm b/v7/src/compiler/rtlgen/rgcomb.scm index 5966c7a7d..88e1296b2 100644 --- a/v7/src/compiler/rtlgen/rgcomb.scm +++ b/v7/src/compiler/rtlgen/rgcomb.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgcomb.scm,v 4.14 1989/12/05 20:17:13 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgcomb.scm,v 4.15 1990/05/03 15:11:50 jinx Rel $ -Copyright (c) 1988, 1989 Massachusetts Institute of Technology +Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -33,6 +33,7 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; RTL Generation: Combinations +;;; package: (compiler rtl-generator generate/combination) (declare (usual-integrations)) @@ -52,9 +53,9 @@ MIT in each case. |# (case (procedure/type model) ((OPEN-EXTERNAL OPEN-INTERNAL) invocation/jump) ((CLOSURE TRIVIAL-CLOSURE) - ;; *** For the time being, known lexpr closures are - ;; invoked through apply. This makes the code - ;; simpler and probably does not matter much. *** + ;; Known lexpr closures are invoked through apply. + ;; This makes the code simpler and probably does + ;; not matter much. (if (procedure-rest model) invocation/apply invocation/jump)) @@ -90,26 +91,56 @@ MIT in each case. |# (generate/procedure-entry/inline callee)) (else (enqueue-procedure! callee) - (if (not (procedure-rest callee)) - (rtl:make-invocation:jump - frame-size - continuation - (procedure-label callee)) - (let* ((callee-block (procedure-block callee)) - (core - (lambda (frame-size) - (rtl:make-invocation:lexpr - (if (stack-block/static-link? callee-block) - (-1+ frame-size) - frame-size) - continuation - (procedure-label callee))))) - (if (not (block/dynamic-link? callee-block)) - (core frame-size) - (scfg*scfg->scfg! - (rtl:make-push-link) - (core (1+ frame-size))))))))))) + (let ((trivial-call + (lambda () + (rtl:make-invocation:jump + frame-size + continuation + (procedure-label callee))))) + (cond ((procedure-rest callee) + ;; Note that callee can't be a closure because of + ;; the dispatch in generate/combination! + (let* ((callee-block (procedure-block callee)) + (core + (lambda (frame-size) + (rtl:make-invocation:lexpr + (if (stack-block/static-link? callee-block) + (-1+ frame-size) + frame-size) + continuation + (procedure-label callee))))) + (if (not (block/dynamic-link? callee-block)) + (core frame-size) + (scfg*scfg->scfg! + (rtl:make-push-link) + (core (1+ frame-size)))))) + ((and (procedure/closure? callee) + (not (procedure/trivial-closure? callee))) + (let* ((block (procedure-closing-block callee)) + (block* (block-shared-block block))) + (if (eq? block block*) + (trivial-call) + (invocation/adjust-closure-prefix block block* + (trivial-call))))) + (else + (trivial-call))))))))) +(define (invocation/adjust-closure-prefix block block* call-code) + (let ((distance (closure-environment-adjustment + (block-number-of-entries block*) + (closure-block-entry-number block)))) + (if (zero? distance) + call-code + (let ((locative + (rtl:make-offset (rtl:make-fetch (interpreter-stack-pointer)) + (stack->memory-offset 0)))) + (scfg*scfg->scfg! + (rtl:make-assignment + locative + (rtl:make-byte-offset-address (rtl:make-fetch locative) + distance)) + call-code))))) + (define (invocation/apply model operator frame-size continuation prefix) model operator ; ignored (invocation/apply* frame-size 0 continuation prefix)) @@ -144,10 +175,10 @@ MIT in each case. |# (invocation/apply* frame-size 0 continuation prefix) (let ((context (reference-context operator)) (variable (reference-lvalue operator))) - (find-variable context variable - (lambda (locative) + (find-variable/value context variable + (lambda (expression) (scfg*scfg->scfg! - (rtl:make-push (rtl:make-fetch locative)) + (rtl:make-push expression) (invocation/apply* (1+ frame-size) 1 continuation prefix))) (lambda (environment name) (invocation/lookup frame-size diff --git a/v7/src/compiler/rtlgen/rgproc.scm b/v7/src/compiler/rtlgen/rgproc.scm index 45d443aea..1dfa3ae9b 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.11 1990/04/01 22:24:35 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgproc.scm,v 4.12 1990/05/03 15:11:55 jinx Rel $ Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology @@ -33,6 +33,7 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; RTL Generation: Procedure Headers +;;; package: (compiler rtl-generator generate/procedure-header) (declare (usual-integrations)) @@ -53,22 +54,35 @@ MIT in each case. |# (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) + (let ((needs-entry? + (or (procedure-rest procedure) (closure-procedure-needs-external-descriptor? - procedure)) - (with-values - (lambda () (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)))) + (cond ((not (procedure/trivial-closure? procedure)) + (let* ((block (procedure-closing-block procedure)) + (nentries (block-entry-number + (block-shared-block block)))) + (if (or (not needs-entry?) (zero? nentries)) + ;; It's not an open procedure but it looks like + ;; one at the rtl level. + (rtl:make-open-procedure-header + (procedure-label procedure)) + (rtl:make-closure-header + (procedure-label procedure) + nentries + (closure-block-entry-number block))))) + (needs-entry? + (with-values + (lambda () (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-values (lambda () (procedure-arity-encoding procedure)) (lambda (min max) @@ -133,20 +147,16 @@ MIT in each case. |# (if rest (cellify-variable rest) (make-null-cfg))) - (scfg*->scfg! - (map (lambda (name value) - (if (and (procedure? value) - (not (procedure/trivial-or-virtual? value))) - (letrec-close context name value) - (make-null-cfg))) - names values)))))) - + (scfg*->scfg! (map (lambda (name value) + (close-binding context name value)) + names values)))))) + (define (setup-bindings names values pushes) (if (null? names) (scfg*->scfg! pushes) (setup-bindings (cdr names) (cdr values) - (letrec-value (car values) + (letrec-value (car names) (car values) (lambda (scfg expression) (cons (scfg*scfg->scfg! scfg @@ -157,8 +167,8 @@ MIT in each case. |# (rtl:make-push (if (variable-in-cell? variable) (rtl:make-cell-cons value) value))) - -(define (letrec-value value recvr) + +(define (letrec-value name value recvr) (cond ((constant? value) (recvr (make-null-cfg) (rtl:make-constant (constant-value value)))) @@ -166,8 +176,22 @@ MIT in each case. |# (enqueue-procedure! value) (case (procedure/type value) ((CLOSURE) - (recvr (make-null-cfg) - (make-non-trivial-closure-cons value))) + (let ((closing-block (procedure-closing-block value))) + (recvr + (make-null-cfg) + (if (eq? closing-block (block-shared-block closing-block)) + (make-non-trivial-closure-cons value false) + (let ((how (procedure-closure-cons value))) + (cond ((or (not (eq? (car how) 'INDIRECTED)) + (not (eq? (variable-block (cdr how)) + (variable-block name)))) + (make-cons-closure-redirection value)) + ((not (variable-in-cell? name)) + (error "letrec-value: Non-indirected shared sibling!" + value)) + (else + (rtl:make-constant + (make-unassigned-reference-trap))))))))) ((IC) (with-values (lambda () (make-ic-cons value 'USE-ENV)) recvr)) ((TRIVIAL-CLOSURE) @@ -180,18 +204,56 @@ MIT in each case. |# (error "Letrec value is open procedure" value)) (else (error "Unknown procedure type" value)))) + ((block? value) + (for-each + (lambda (block*) + (enqueue-procedure! + (block-procedure (car (block-children block*))))) + (block-grafted-blocks value)) + (recvr (make-null-cfg) + (make-non-trivial-closure-cons + (indirection-block-procedure value) + value))) (else (error "Unknown letrec binding value" value)))) + +(define (close-binding context name value) + (cond ((block? value) + (letrec-close context name + (indirection-block-procedure value))) + ((and (procedure? value) + (not (procedure/trivial-or-virtual? value))) + (let ((closing-block (procedure-closing-block value))) + (if (eq? closing-block (block-shared-block closing-block)) + (letrec-close context name value) + (let ((how (procedure-closure-cons value))) + (cond ((or (not (eq? (car how) 'INDIRECTED)) + (not (eq? (variable-block (cdr how)) + (variable-block name)))) + (make-null-cfg)) + ((not (variable-in-cell? name)) + (error "close-binding: Non-indirected shared sibling!" + value)) + (else + (find-variable/locative + context name + (lambda (locative) + (rtl:make-assignment + locative + (make-cons-closure-indirection value))) + (lambda (environment name) + environment + (error "close-binding: IC letrec name" name)) + (lambda (name) + (error "close-binding: cached letrec name" + name))))))))) + (else + (make-null-cfg)))) (define (letrec-close context variable value) (load-closure-environment value - (find-variable context - variable - rtl:make-fetch - (lambda (nearest-ic-locative name) - nearest-ic-locative name ;; ignored - (error "Missing closure variable" variable)) - (lambda (name) - name ;; ignored - (error "Missing closure variable" variable))))) \ No newline at end of file + (find-variable/value/simple + context variable + "letrec-close: Missing closure variable") + context)) \ No newline at end of file diff --git a/v7/src/compiler/rtlgen/rgrval.scm b/v7/src/compiler/rtlgen/rgrval.scm index 3bb36ae61..9d57c0fdb 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.15 1990/01/18 22:47:04 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgrval.scm,v 4.16 1990/05/03 15:11:58 jinx Exp $ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgrval.scm,v 4.15 1990/01/18 22:47:04 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgrval.scm,v 4.16 1990/05/03 15:11:58 jinx Exp $ Copyright (c) 1988, 1990 Massachusetts Institute of Technology @@ -33,6 +33,7 @@ provide any services, by way of maintenance, update, or otherwise. there shall be no use of the name of the Massachusetts Institute of Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from +MIT in each case. |# ;;;; RTL Generation: RValues ;;; package: (compiler rtl-generator generate/rvalue) @@ -72,11 +73,11 @@ promotional, or sales literature without prior written consent from (define-method-table-entry 'REFERENCE rvalue-methods (lambda (reference) (let ((context (reference-context reference)) + (lvalue (reference-lvalue reference)) (safe? (reference-safe? reference))) - (lambda (lvalue) - (find-variable context lvalue - (lambda (locative) - (expression-value/simple (rtl:make-fetch locative))) + (let ((value (lvalue-known-value lvalue)) + #| (indirection (variable-indirection lvalue)) |# + (perform-fetch (lambda (#| lvalue |#) (find-variable/value context lvalue expression-value/simple @@ -94,17 +95,27 @@ promotional, or sales literature without prior written consent from safe?)))) (rtl:interpreter-call-result:lookup))) (lambda (name) - (rtl:make-variable-cache name) - rtl:make-fetch) + (if (memq 'IGNORE-REFERENCE-TRAPS + (variable-declarations lvalue)) (load-temporary-register values (rtl:make-variable-cache name) - (perform-fetch (or (variable-indirection lvalue) lvalue))) + rtl:make-fetch) + (generate/cached-reference context name safe?))))))) + (cond ((not value) + #| + (if (and indirection (cdr indirection)) + (error "reference: Unknown mapped indirection" lvalue)) |# + (perform-fetch #| (if indirection (car indirection) lvalue) |#)) ((not (rvalue/procedure? value)) (generate/rvalue* value)) + #| + ((procedure/trivial-or-virtual? value) + (expression-value/simple (make-trivial-closure-cons value))) + ((and indirection (cdr indirection)) (generate/indirected-closure indirection value context - (perform-fetch lvalue))))))) + reference)) |# (else (perform-fetch #| lvalue |#))))))) @@ -152,15 +163,23 @@ promotional, or sales literature without prior written consent from (lambda (procedure) (enqueue-procedure! procedure) (case (procedure/type procedure) - (load-temporary-register - (lambda (assignment reference) - (values - (scfg*scfg->scfg! - assignment - (load-closure-environment procedure reference)) - reference)) - (make-non-trivial-closure-cons procedure) - identity-procedure)) + ((TRIVIAL-CLOSURE) + (expression-value/simple (make-trivial-closure-cons procedure))) + ((CLOSURE) + (case (car (procedure-closure-cons procedure)) + ((NORMAL) + (load-temporary-register + (lambda (assignment reference) + (values + (scfg*scfg->scfg! + assignment + (load-closure-environment procedure reference false)) + reference)) + (make-non-trivial-closure-cons procedure false) + identity-procedure)) + ((DESCENDANT) + (expression-value/simple + (make-cons-closure-redirection procedure))) (else (expression-value/simple (make-cons-closure-indirection procedure))))) @@ -170,12 +189,6 @@ promotional, or sales literature without prior written consent from (if (not (procedure-virtual-closure? procedure)) (error "Reference to open procedure" procedure)) (expression-value/simple (make-trivial-closure-cons procedure))) -(define (make-trivial-closure-cons procedure) - (enqueue-procedure! procedure) - (rtl:make-cons-pointer - (rtl:make-machine-constant type-code:compiled-entry) - (rtl:make-entry:procedure (procedure-label procedure)))) - (else (error "Unknown procedure type" procedure))))) @@ -209,42 +222,143 @@ promotional, or sales literature without prior written consent from kernel) ;; Is this right if the procedure is being closed ;; inside another IC procedure? -(define (make-non-trivial-closure-cons procedure) - (rtl:make-cons-pointer - (rtl:make-machine-constant type-code:compiled-entry) - (with-values (lambda () (procedure-arity-encoding procedure)) - (lambda (min max) - (rtl:make-cons-closure - (rtl:make-entry:procedure (procedure-label procedure)) - min - max - (procedure-closure-size procedure)))))) - -(define (load-closure-environment procedure closure-locative) - (define (load-closure-parent block force?) - (if (and (not force?) - (or (not block) - (not (ic-block/use-lookup? block)))) - (make-null-cfg) - (rtl:make-assignment - (rtl:locative-offset closure-locative closure-block-first-offset) - (if (not (ic-block/use-lookup? block)) - (rtl:make-constant false) - (let ((context (procedure-closure-context procedure))) - (if (not (reference-context? context)) - (error "load-closure-environment: bad closure context" - procedure)) - (if (ic-block? (reference-context/block context)) - (rtl:make-fetch register:environment) - (closure-ic-locative context block))))))) + (kernel (make-null-cfg) + (rtl:make-fetch register:environment))))))) + +(define (make-trivial-closure-cons procedure) (enqueue-procedure! procedure) - (let ((block (procedure-closing-block procedure))) + (rtl:make-typed-cons:procedure + (rtl:make-entry:procedure (procedure-label procedure)))) + +(define (make-cons-closure-indirection procedure) + (let* ((context (procedure-closure-context procedure)) + (variable (cdr (procedure-closure-cons procedure)))) + (make-closure-redirection + (find-variable/value/simple + context variable + "make-cons-closure-indirection: Unavailable indirection variable") + (indirection-block-procedure + (block-shared-block (procedure-closing-block procedure))) + procedure))) + +(define (make-cons-closure-redirection procedure) + (let* ((context (procedure-closure-context procedure)) + (block (stack-block/external-ancestor + (reference-context/block context)))) + (redirect-closure context + block + (block-procedure block) + procedure))) + +(define (redirect-closure context block* procedure* procedure) + (make-closure-redirection + (rtl:make-fetch (block-ancestor-or-self->locative + context block* 0 + (procedure-closure-offset procedure*))) + procedure* + procedure)) + +(define (make-closure-redirection expression procedure procedure*) + (enqueue-procedure! procedure*) + (let ((block (procedure-closing-block procedure)) + (block* (procedure-closing-block procedure*))) + (let* ((block** (block-shared-block block))) + (if (not (eq? (block-shared-block block*) block**)) + (error "make-closure-redirection: non-shared redirection" + procedure procedure*)) + (let ((nentries (block-number-of-entries block**)) + (entry (closure-block-entry-number block)) + (entry* (closure-block-entry-number block*))) + (let ((distance + (- (closure-entry-distance nentries entry entry*) + (closure-environment-adjustment nentries entry)))) + (if (zero? distance) + expression + ;; This is cheaper than the obvious thing with object->address, + ;; etc. + (rtl:make-byte-offset-address expression distance))))))) + (define (make-non-trivial-closure-cons procedure block**) - (make-null-cfg)) - ((ic-block? block) - (load-closure-parent block true)) - ((closure-block? block) - (let ((context (procedure-closure-context procedure))) + (let* ((block (procedure-closing-block procedure)) + (block* (or block** block))) + (cond ((not block) + (error "make-non-trivial-closure-cons: Consing trivial closure" + procedure)) + ((not (eq? (block-shared-block block) block*)) + (error "make-non-trivial-closure-cons: Non-canonical closure" + procedure)) + ((= (block-entry-number block*) 1) + ;; Single entry point. This could use the multiclosure case + ;; below, but this is simpler. + (with-values (lambda () (procedure-arity-encoding procedure)) + (lambda (min max) + (rtl:make-typed-cons:procedure + (rtl:make-cons-closure + (rtl:make-entry:procedure (procedure-label procedure)) + min + max + (procedure-closure-size procedure)))))) + ((= (block-entry-number block*) 0) + ;; No entry point (used for environment only) + (rtl:make-cons-pointer + (rtl:make-machine-constant (ucode-type vector)) + (rtl:make-cons-multiclosure 0 + (procedure-closure-size procedure) + '#()))) + (else + ;; Multiple entry points + (let* ((procedures + (let ((children + ;; This depends on the order of entries established + ;; by graft-block! in fgopt/blktyp.scm . + (reverse + (map (lambda (block) + (block-procedure + (car (block-children block)))) + (list-transform-negative + (block-grafted-blocks block*) + (lambda (block) + (zero? (block-entry-number block)))))))) + ;; Official entry point. + (cons procedure children))) + (entries + (map (lambda (proc) + (with-values + (lambda () (procedure-arity-encoding proc)) + (lambda (min max) + (list (procedure-label proc) min max)))) + procedures))) + (if (not (= (length entries) (block-entry-number block*))) + (error "make-non-trivial-closure-cons: disappearing entries" + procedure)) + (rtl:make-typed-cons:procedure + (rtl:make-cons-multiclosure (block-entry-number block*) + (procedure-closure-size procedure) + (list->vector entries)))))))) + +(define (load-closure-environment procedure closure-locative context*) + (let ((context (or context* (procedure-closure-context procedure)))) + (define (load-closure-parent block force?) + (if (and (not force?) + (or (not block) + (not (ic-block/use-lookup? block)))) + (make-null-cfg) + (rtl:make-assignment + (rtl:locative-offset closure-locative + (closure-block-first-offset block)) + (if (not (ic-block/use-lookup? block)) + (rtl:make-constant false) + (begin + (if (not (reference-context? context)) + (error "load-closure-environment: bad closure context" + procedure)) + (if (ic-block? (reference-context/block context)) + (rtl:make-fetch register:environment) + (closure-ic-locative context block))))))) + + (let ((block (procedure-closing-block procedure))) + (cond ((not block) + (make-null-cfg)) ((ic-block? block) (load-closure-parent block true)) ((closure-block? block) @@ -270,11 +384,11 @@ promotional, or sales literature without prior written consent from value variable)) (make-trivial-closure-cons value)) ((eq? value + (else (rtl:make-fetch - (find-closure-variable context variable)))))) - code)))))) - (else - (error "Unknown block type" block))))) (find-closure-variable context variable))))) + (block-closure-locative context))) + (else + (find-closure-variable context variable))))) code))))) (error "Unknown block type" block)))))) (error "Unknown block type" block)))))) diff --git a/v7/src/compiler/rtlgen/rgstmt.scm b/v7/src/compiler/rtlgen/rgstmt.scm index e4b8bbc6f..5ce99ca64 100644 --- a/v7/src/compiler/rtlgen/rgstmt.scm +++ b/v7/src/compiler/rtlgen/rgstmt.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgstmt.scm,v 4.14 1990/03/28 06:11:39 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgstmt.scm,v 4.15 1990/05/03 15:12:04 jinx Rel $ Copyright (c) 1988, 1990 Massachusetts Institute of Technology @@ -33,6 +33,7 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; RTL Generation: Statements +;;; package: (compiler rtl-generator) (declare (usual-integrations)) @@ -46,7 +47,7 @@ MIT in each case. |# (make-null-cfg) (generate/rvalue rvalue scfg*scfg->scfg! (lambda (expression) - (find-variable context lvalue + (find-variable/locative context lvalue (lambda (locative) (rtl:make-assignment locative expression)) (lambda (environment name) @@ -277,9 +278,8 @@ MIT in each case. |# (let ((value (lvalue-known-value lvalue))) (cond ((not value) (pcfg*scfg->scfg! - (find-variable context lvalue - (lambda (locative) - (rtl:make-unassigned-test (rtl:make-fetch locative))) + (find-variable/value context lvalue + rtl:make-unassigned-test (lambda (environment name) (scfg*pcfg->pcfg! (load-temporary-register scfg*scfg->scfg! environment diff --git a/v7/src/compiler/rtlopt/rdflow.scm b/v7/src/compiler/rtlopt/rdflow.scm index c8881b42d..f510faac6 100644 --- a/v7/src/compiler/rtlopt/rdflow.scm +++ b/v7/src/compiler/rtlopt/rdflow.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rdflow.scm,v 1.1 1990/01/18 22:49:11 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rdflow.scm,v 1.2 1990/05/03 15:22:24 jinx Rel $ Copyright (c) 1990 Massachusetts Institute of Technology @@ -33,6 +33,7 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; RTL Dataflow Analysis +;;; package: (compiler rtl-optimizer rtl-dataflow-analysis) (declare (usual-integrations)) @@ -127,13 +128,26 @@ MIT in each case. |# (let ((target (get-rnode address))) (if (rtl:pseudo-register-expression? expression) (rnode/connect! target (get-rnode expression)) - (let ((values (rnode/initial-values target))) - (if (not (there-exists? values - (lambda (value) - (rtl:expression=? expression value)))) - (set-rnode/initial-values! - target - (cons expression values))))))))))) + (add-rnode/initial-value! target expression)))))) + (let loop ((rtl rtl)) + (rtl:for-each-subexpression rtl + (lambda (expression) + (if (rtl:volatile-expression? expression) + (if (or (rtl:post-increment? expression) + (rtl:pre-increment? expression)) + (add-rnode/initial-value! + (get-rnode (rtl:address-register expression)) + expression) + (error "Unknown volatile expression" expression)) + (loop expression))))))) + +(define (add-rnode/initial-value! target expression) + (let ((values (rnode/initial-values target))) + (if (not (there-exists? values + (lambda (value) + (rtl:expression=? expression value)))) + (set-rnode/initial-values! target + (cons expression values))))) (define (rnode/connect! target source) (if (not (memq source (rnode/backward-links target))) @@ -157,7 +171,7 @@ MIT in each case. |# (lambda (rnode) (let ((expression (initial-known-value (rnode/classified-values rnode)))) (set-rnode/known-value! rnode expression) - (if (not (eq? expression 'UNDETERMINED)) + (if (not (memq expression '(UNDETERMINED #F))) (set-rnode/classified-values! rnode '()))))) (let loop () (let ((new-constant? false)) @@ -197,6 +211,9 @@ MIT in each case. |# (define (initial-known-value values) (and (not (null? values)) + (not (there-exists? values + (lambda (value) + (rtl:volatile-expression? (cdr value))))) (let loop ((value (car values)) (rest (cdr values))) (cond ((eq? (car value) 'SUBSTITUTABLE-REGISTERS) 'UNDETERMINED) ((null? rest) (values-unique-expression values)) diff --git a/v7/src/compiler/rtlopt/rinvex.scm b/v7/src/compiler/rtlopt/rinvex.scm index 1d8971315..f60f46580 100644 --- a/v7/src/compiler/rtlopt/rinvex.scm +++ b/v7/src/compiler/rtlopt/rinvex.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rinvex.scm,v 1.3 1990/01/18 22:48:02 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rinvex.scm,v 1.4 1990/05/03 15:22:29 jinx Rel $ Copyright (c) 1989, 1990 Massachusetts Institute of Technology @@ -33,6 +33,7 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; RTL Invertible Expression Elimination +;;; package: (compiler rtl-optimizer invertible-expression-elimination) (declare (usual-integrations)) @@ -112,6 +113,14 @@ MIT in each case. |# unspecific) (define (expression-update! get-expression set-expression! object) + ;; Note: The following code may cause pseudo register copies to be + ;; generated since it would have to propagate some of the + ;; simplifications, and then delete the now-unused registers. + ;; This is not worth it since the previous register is likely to be + ;; dead at this point, so the lap-level register allocator will + ;; reuse the alias achieving the effect of the deletion. Ultimately + ;; the expression invertibility code should be integrated into the + ;; CSE and this register deletion would happen there. (set-expression! object (let loop ((expression (get-expression object))) @@ -120,35 +129,78 @@ MIT in each case. |# (optimize-expression (rtl:map-subexpressions expression loop)))))) (define (optimize-expression expression) - (let ((type (rtl:expression-type expression)) - (try-unary-fold - (lambda (types) - (let loop ((types types) - (expression (cadr expression))) - (if (null? types) - expression - (let ((subexpression - (canonicalize-subexpression expression))) - (and (eq? (car types) (rtl:expression-type subexpression)) - (loop (cdr types) - (cadr subexpression))))))))) - (let next-inversion ((unary-inversions unary-inversions)) - (if (null? unary-inversions) - expression - (let ((first-inversion (car unary-inversions))) - (or (and (eq? type (caar first-inversion)) - (try-unary-fold (append (cdar first-inversion) - (cdr first-inversion)))) - (and (eq? type (cadr first-inversion)) - (try-unary-fold (append (cddr first-inversion) - (car first-inversion)))) - (next-inversion (cdr unary-inversions)))))))) - -(define unary-inversions - '(((OBJECT->FIXNUM) . (FIXNUM->OBJECT)) - ((OBJECT->UNSIGNED-FIXNUM) . (FIXNUM->OBJECT)) - ((ADDRESS->FIXNUM) . (FIXNUM->ADDRESS)) - ((@ADDRESS->FLOAT OBJECT->ADDRESS) . (FLOAT->OBJECT)))) + (define (try-identity identity) + (let ((in-domain? (car identity)) + (matching-operation (cadr identity))) + (let loop ((operations (cddr identity)) + (subexpression ((cadr matching-operation) expression))) + (if (null? operations) + (and (valid-subexpression? subexpression) + (in-domain? (rtl:expression-value-class subexpression)) + subexpression) + (let ((subexpression (canonicalize-subexpression subexpression))) + (and (eq? (caar operations) (rtl:expression-type subexpression)) + (loop (cdr operations) + ((cadar operations) subexpression)))))))) + + (let loop ((rules (list-transform-positive + identities + (let ((type (rtl:expression-type expression))) + (lambda (identity) + (eq? type (car (cadr identity)))))))) + + (cond ((null? rules) expression) + ((try-identity (car rules)) => optimize-expression) + (else (loop (cdr rules)))))) + +(define identities + ;; Each entry is composed of a value class and a sequence + ;; of operations whose composition is the identity for that + ;; value class. + ;; Each operation is described by the operator and the selector for + ;; the relevant operand. + `((,value-class=value? (OBJECT->FIXNUM ,rtl:object->fixnum-expression) + (FIXNUM->OBJECT ,rtl:fixnum->object-expression)) + (,value-class=value? (FIXNUM->OBJECT ,rtl:fixnum->object-expression) + (OBJECT->FIXNUM ,rtl:object->fixnum-expression)) + (,value-class=value? (OBJECT->UNSIGNED-FIXNUM + ,rtl:object->unsigned-fixnum-expression) + (FIXNUM->OBJECT ,rtl:fixnum->object-expression)) + (,value-class=value? (FIXNUM->OBJECT ,rtl:fixnum->object-expression) + (OBJECT->UNSIGNED-FIXNUM + ,rtl:object->unsigned-fixnum-expression)) + (,value-class=value? (FIXNUM->ADDRESS ,rtl:fixnum->address-expression) + (ADDRESS->FIXNUM ,rtl:address->fixnum-expression)) + (,value-class=value? (ADDRESS->FIXNUM ,rtl:address->fixnum-expression) + (FIXNUM->ADDRESS ,rtl:fixnum->address-expression)) + (,value-class=value? (@ADDRESS->FLOAT ,rtl:@address->float-expression) + (OBJECT->ADDRESS ,rtl:object->address-expression) + (FLOAT->OBJECT ,rtl:float->object-expression)) + (,value-class=value? (FLOAT->OBJECT ,rtl:float->object-expression) + (@ADDRESS->FLOAT ,rtl:@address->float-expression) + (OBJECT->ADDRESS ,rtl:object->address-expression)) + #| + ;; This one, although true, is useless. + (,value-class=value? (OBJECT->ADDRESS ,rtl:object->address-expression) + (FLOAT->OBJECT ,rtl:float->object-expression) + (@ADDRESS->FLOAT ,rtl:@address->float-expression)) + |# + (,value-class=address? (OBJECT->ADDRESS ,rtl:object->address-expression) + (CONS-POINTER ,rtl:cons-pointer-datum)) + (,value-class=datum? (OBJECT->DATUM ,rtl:object->datum-expression) + (CONS-POINTER ,rtl:cons-pointer-datum)) + ;; Perhaps this should be value-class=type + (,value-class=immediate? (OBJECT->TYPE ,rtl:object->type-expression) + (CONS-POINTER ,rtl:cons-pointer-type)))) + +(define (valid-subexpression? expression) + ;; Machine registers not allowed because they are volatile. + ;; Ideally at this point we could introduce a copy to the + ;; value of the machine register required, but it is too late + ;; to do this. Perhaps always copying machine registers out + ;; before using them would make this win. + (or (not (rtl:register? expression)) + (rtl:pseudo-register-expression? expression))) (define (canonicalize-subexpression expression) (or (and (rtl:pseudo-register-expression? expression) -- 2.25.1