From 0750f6c4b2e6ea9969ec058ab23ff1b5a59f0efb Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Thu, 26 Oct 1989 07:41:21 +0000 Subject: [PATCH] * Rewrite the flonum lap-generation rules to perform register-reusing, as is already the case for fixnum rules. Generalize some tools so that most code can be shared between fixnum and flonum rules. * Implement assorted changes to conform to new R4RS arithmetic. * Redesign closure-analysis/procedure-undrifting. New design should perform better than old, and I believe that this one is substantially more correct. * Add "variable indirections", which come into play when the a variable is known to be bound to the value of another variable which is bound in an ancestor frame of the first variable (i.e. the first variable can be considered an alias for the second). * Don't inline-code procedures with rest variables. * New pass notices when two returns are equivalent, and merges them. Another new pass notices when the tails of two basic blocks are equivalent, and merges them. These two work together to eliminate multiple copies of suffixes in various cases (most notably predicates). * Introduce concept that certain procedures are "boolean-valued" and can be treated specially if they appear in the predicate of a disjunction. * Disconnect registerizable-parameter code because it introduces instability in the three-stage compilation test. This code doesn't seem to be doing much right now anyway. * Fix bug in "remote links": must use another addressing-mode when the offset is too large to fit in 16 bits. * Add rule to permit static-links to be pushed in two instructions instead of three on the 68020. * Change RTL constructors to reduce the number of intermediate registers generated for trivial expressions. Improve definition of "trivial expression" to include certain kinds of constants. * Change open-coded combinations in the case where they appear in reduction position, and where the open-coding of the combination will include a close-coded call. The new strategy is to setup the arguments as if the combination was close-coded, then open-code assuming the arguments are in those positions. This has the advantage of allowing the internal close-coded call to be transformed into a jump with no clumsy argument manipulation required. * Change RTL CSE to treat small (8-bit) numeric constants as cheaper than registers. --- v7/src/compiler/back/lapgn1.scm | 18 +- v7/src/compiler/back/lapgn2.scm | 67 +- v7/src/compiler/back/linear.scm | 7 +- v7/src/compiler/back/syntax.scm | 11 +- v7/src/compiler/base/blocks.scm | 18 +- v7/src/compiler/base/cfg1.scm | 71 +- v7/src/compiler/base/cfg2.scm | 88 +- v7/src/compiler/base/cfg3.scm | 10 +- v7/src/compiler/base/crstop.scm | 15 +- v7/src/compiler/base/ctypes.scm | 16 +- v7/src/compiler/base/debug.scm | 6 +- v7/src/compiler/base/infnew.scm | 15 +- v7/src/compiler/base/lvalue.scm | 67 +- v7/src/compiler/base/object.scm | 8 +- v7/src/compiler/base/proced.scm | 15 +- v7/src/compiler/base/toplev.scm | 43 +- v7/src/compiler/base/utils.scm | 161 ++-- v7/src/compiler/fggen/fggen.scm | 59 +- v7/src/compiler/fgopt/blktyp.scm | 91 +-- v7/src/compiler/fgopt/closan.scm | 498 ++++++------ v7/src/compiler/fgopt/contan.scm | 43 +- v7/src/compiler/fgopt/delint.scm | 19 +- v7/src/compiler/fgopt/operan.scm | 4 +- v7/src/compiler/fgopt/order.scm | 250 ++---- v7/src/compiler/fgopt/param.scm | 427 ++++------ v7/src/compiler/fgopt/reuse.scm | 20 +- v7/src/compiler/fgopt/simple.scm | 5 +- v7/src/compiler/fgopt/subfre.scm | 13 +- v7/src/compiler/machines/bobcat/compiler.pkg | 26 +- v7/src/compiler/machines/bobcat/dassm1.scm | 8 +- v7/src/compiler/machines/bobcat/dassm2.scm | 7 +- v7/src/compiler/machines/bobcat/decls.scm | 14 +- v7/src/compiler/machines/bobcat/insmac.scm | 5 +- v7/src/compiler/machines/bobcat/insutl.scm | 68 +- v7/src/compiler/machines/bobcat/lapgen.scm | 291 ++++--- .../compiler/machines/bobcat/make.scm-68040 | 4 +- v7/src/compiler/machines/bobcat/rules1.scm | 210 +++-- v7/src/compiler/machines/bobcat/rules2.scm | 28 +- v7/src/compiler/machines/bobcat/rules3.scm | 30 +- v7/src/compiler/machines/bobcat/rules4.scm | 7 +- v7/src/compiler/rtlbase/rgraph.scm | 12 +- v7/src/compiler/rtlbase/rtlcfg.scm | 113 ++- v7/src/compiler/rtlbase/rtlcon.scm | 23 +- v7/src/compiler/rtlbase/rtlexp.scm | 34 +- v7/src/compiler/rtlbase/rtline.scm | 18 +- v7/src/compiler/rtlbase/rtlty2.scm | 71 +- v7/src/compiler/rtlgen/fndvar.scm | 40 +- v7/src/compiler/rtlgen/opncod.scm | 758 ++++++++++-------- v7/src/compiler/rtlgen/rgcomb.scm | 6 +- v7/src/compiler/rtlgen/rgretn.scm | 72 +- v7/src/compiler/rtlgen/rgrval.scm | 228 +++++- v7/src/compiler/rtlgen/rtlgen.scm | 45 +- v7/src/compiler/rtlopt/rcse2.scm | 121 +-- v7/src/compiler/rtlopt/rcseht.scm | 53 +- 54 files changed, 2455 insertions(+), 1902 deletions(-) diff --git a/v7/src/compiler/back/lapgn1.scm b/v7/src/compiler/back/lapgn1.scm index 40ed7cf1b..ad0ecab54 100644 --- a/v7/src/compiler/back/lapgn1.scm +++ b/v7/src/compiler/back/lapgn1.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/lapgn1.scm,v 4.7 1989/08/21 19:30:23 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/lapgn1.scm,v 4.8 1989/10/26 07:34:56 cph Exp $ Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology @@ -81,12 +81,12 @@ MIT in each case. |# (*pending-bblocks* '())) (for-each (lambda (edge) (if (not (node-marked? (edge-right-node edge))) - (cgen-entry edge))) + (cgen-entry rgraph edge))) (rgraph-entry-edges rgraph)) (if (not (null? *pending-bblocks*)) (error "CGEN-RGRAPH: pending blocks left at end of pass")))) -(define (cgen-entry edge) +(define (cgen-entry rgraph edge) (define (loop bblock map) (cgen-bblock bblock map) (if (sblock? bblock) @@ -99,11 +99,14 @@ MIT in each case. |# (let ((next (edge-next-node edge))) (if (and next (not (node-marked? next))) (let ((previous (node-previous-edges next))) - (cond ((not (for-all? previous edge-left-node)) + (cond ((for-all? previous + (lambda (edge) + (memq edge (rgraph-entry-edges rgraph)))) ;; Assumption: no action needed to clear existing ;; register map at this point. (loop next (empty-register-map))) - ((null? (cdr previous)) + ((and (null? (cdr previous)) + (edge-left-node (car previous))) (loop next (let ((previous (edge-left-node edge))) @@ -164,7 +167,10 @@ MIT in each case. |# (loop))))))) (define (adjust-maps-at-merge! bblock) - (let ((edges (node-previous-edges bblock))) (let ((maps + (let ((edges + (list-transform-positive (node-previous-edges bblock) + edge-left-node))) + (let ((maps (map (let ((live-registers (bblock-live-at-entry bblock))) (lambda (edge) diff --git a/v7/src/compiler/back/lapgn2.scm b/v7/src/compiler/back/lapgn2.scm index 9dda33ff3..400d6e128 100644 --- a/v7/src/compiler/back/lapgn2.scm +++ b/v7/src/compiler/back/lapgn2.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/lapgn2.scm,v 1.10 1989/07/25 12:42:02 arthur Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/lapgn2.scm,v 1.11 1989/10/26 07:35:00 cph Exp $ Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology @@ -266,37 +266,41 @@ MIT in each case. |# (set! *register-map* map) (prefix-instructions! instructions))))) -(define (standard-register-reference register preferred-type) +(define (standard-register-reference register preferred-type alternate-types?) ;; Generate a standard reference for `register'. This procedure ;; uses a number of heuristics, aided by `preferred-type', to ;; determine the optimum reference. This should be used only when ;; the reference need not have any special properties, as the result ;; is not even guaranteed to be a register reference. - (let ((no-preference - (lambda () - ;; Next, attempt to find an alias of any type. If there - ;; are no aliases, and the register is not dead, allocate - ;; an alias of the preferred type. This is desirable - ;; because the register will be used again. Otherwise, - ;; this is the last use of this register, so we might as - ;; well just use the register's home. - (let ((alias (register-alias register false))) - (cond (alias - (register-reference alias)) - ((dead-register? register) - (pseudo-register-home register)) - (else - (reference-alias-register! register preferred-type))))))) - (cond ((machine-register? register) - (register-reference register)) + (if (machine-register? register) + (if alternate-types? + (register-reference register) + (machine-register-reference register preferred-type)) + (let ((no-reuse-possible + (lambda () + ;; If there are no aliases, and the register is not dead, + ;; allocate an alias of the preferred type. This is + ;; desirable because the register will be used again. + ;; Otherwise, this is the last use of this register, so we + ;; might as well just use the register's home. + (if (and (dead-register? register) + (register-saved-into-home? register)) + (pseudo-register-home register) + (reference-alias-register! register preferred-type))))) + (let ((no-preference + (lambda () + ;; Next, attempt to find an alias of any type. + (let ((alias (register-alias register false))) + (if alias + (register-reference alias) + (no-reuse-possible)))))) ;; First, attempt to find an alias of the preferred type. - (preferred-type - (let ((alias (register-alias register preferred-type))) - (if alias - (register-reference alias) - (no-preference)))) - (else - (no-preference))))) + (if preferred-type + (let ((alias (register-alias register preferred-type))) + (cond (alias (register-reference alias)) + (alternate-types? (no-preference)) + (else (no-reuse-possible)))) + (no-preference)))))) (define (machine-register-reference register type) ;; Returns a reference to a machine register which contains the same @@ -311,12 +315,6 @@ MIT in each case. |# temp)) (load-alias-register! register type)))) -(define (float-register-reference register) - (register-reference - (if (machine-register? register) - register - (load-alias-register! register 'FLOAT)))) - (define (load-machine-register! source-register machine-register) (if (machine-register? source-register) (if (eqv? source-register machine-register) @@ -325,7 +323,7 @@ MIT in each case. |# (if (is-alias-for-register? machine-register source-register) (LAP) (reference->register-transfer - (standard-register-reference source-register false) + (standard-register-reference source-register false true) machine-register)))) (define (move-to-alias-register! source type target) @@ -375,7 +373,8 @@ MIT in each case. |# (delete-dead-registers!) (if-reusable alias)) (lambda () - (let ((source (standard-register-reference source false))) (delete-dead-registers!) + (let ((source (standard-register-reference source false true))) + (delete-dead-registers!) (if-not source))))) (define (reuse-pseudo-register-alias! source type if-reusable if-not) diff --git a/v7/src/compiler/back/linear.scm b/v7/src/compiler/back/linear.scm index e6b68cc4e..5b6aacc68 100644 --- a/v7/src/compiler/back/linear.scm +++ b/v7/src/compiler/back/linear.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/linear.scm,v 4.7 1988/11/06 14:50:00 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/linear.scm,v 4.8 1989/10/26 07:35:04 cph Exp $ Copyright (c) 1987, 1988 Massachusetts Institute of Technology @@ -41,9 +41,8 @@ MIT in each case. |# (node-mark! bblock) (queue-continuations! bblock) (if (and (not (bblock-label bblock)) - (let ((edges (node-previous-edges bblock))) - (and (not (null? edges)) - (not (null? (cdr edges)))))) (bblock-label! bblock)) + (node-previous>1? bblock)) + (bblock-label! bblock)) (let ((kernel (lambda () (LAP ,@(bblock-instructions bblock) diff --git a/v7/src/compiler/back/syntax.scm b/v7/src/compiler/back/syntax.scm index 4583ad646..6adaf5f10 100644 --- a/v7/src/compiler/back/syntax.scm +++ b/v7/src/compiler/back/syntax.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/syntax.scm,v 1.23 1989/04/15 18:04:59 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/syntax.scm,v 1.24 1989/10/26 07:35:06 cph Exp $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -96,12 +96,12 @@ MIT in each case. |# (define (integer-syntaxer expression coercion-type size) (let ((name (make-coercion-name coercion-type size))) - (if (integer? expression) + (if (exact-integer? expression) `',((lookup-coercion name) expression) `(SYNTAX-EVALUATION ,expression ,name)))) (define (syntax-evaluation expression coercion) - (if (integer? expression) + (if (exact-integer? expression) (coercion expression) `(EVALUATION ,expression ,(coercion-size coercion) ,coercion))) @@ -159,7 +159,7 @@ MIT in each case. |# (choose-clause value (cdr clauses)))) (define (variable-width-expression-syntaxer name expression clauses) - (if (integer? expression) + (if (exact-integer? expression) (let ((chosen (choose-clause expression clauses))) `(LET ((,name ,expression)) (DECLARE (INTEGRATE ,name)) @@ -176,7 +176,8 @@ MIT in each case. |# clauses))))) (define (syntax-variable-width-expression expression clauses) - (if (integer? expression) (let ((chosen (choose-clause expression clauses))) + (if (exact-integer? expression) + (let ((chosen (choose-clause expression clauses))) (car ((car chosen) expression))) `(VARIABLE-WIDTH-EXPRESSION ,expression diff --git a/v7/src/compiler/base/blocks.scm b/v7/src/compiler/base/blocks.scm index 0a9167ee8..ecfe469e4 100644 --- a/v7/src/compiler/base/blocks.scm +++ b/v7/src/compiler/base/blocks.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/blocks.scm,v 4.11 1989/08/10 11:05:07 cph Exp $ +$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 $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -87,6 +87,7 @@ from the continuation, and then "glued" into place afterwards. 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) popping-limit ;for stack block (see continuation analysis) layout-frozen? ;used by frame reuse to tell parameter @@ -268,18 +269,9 @@ from the continuation, and then "glued" into place afterwards. (procedure block) (for-each loop (block-children block)))) -(define-integrable (internal-block/parent-known? block) - (block-stack-link block)) - -(define (stack-block/static-link? block) - (and (not (null? (block-free-variables block))) - (let ((parent (block-parent block))) - (and parent - (cond ((stack-block? parent) - (not (internal-block/parent-known? block))) - ((ic-block? parent) - (ic-block/use-lookup? parent)) - (else true)))))) +(define-integrable (stack-block/static-link? block) + (block-static-link? block)) + (define-integrable (stack-block/continuation-lvalue block) (procedure-continuation-lvalue (block-procedure block))) diff --git a/v7/src/compiler/base/cfg1.scm b/v7/src/compiler/base/cfg1.scm index 5e2860989..8b9df0f4b 100644 --- a/v7/src/compiler/base/cfg1.scm +++ b/v7/src/compiler/base/cfg1.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/cfg1.scm,v 4.3 1987/12/31 10:01:31 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/cfg1.scm,v 4.4 1989/10/26 07:35:30 cph Rel $ -Copyright (c) 1987 Massachusetts Institute of Technology +Copyright (c) 1987, 1989 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -80,13 +80,6 @@ MIT in each case. |# (define (delete-node-previous-edge! node edge) (set-node-previous-edges! node (delq! edge (node-previous-edges node)))) - -;;;; Edge Datatype - -(define-structure (edge (type vector)) left-node left-connect right-node) - -(define (edge-next-node edge) - (and edge (edge-right-node edge))) (define-integrable (snode-next snode) (edge-next-node (snode-next-edge snode))) @@ -97,6 +90,27 @@ MIT in each case. |# (define-integrable (pnode-alternative pnode) (edge-next-node (pnode-alternative-edge pnode))) +(define (cfg-node-get node key) + (let ((entry (assq key (node-alist node)))) + (and entry + (cdr entry)))) + +(define (cfg-node-put! node key item) + (let ((entry (assq key (node-alist node)))) + (if entry + (set-cdr! entry item) + (set-node-alist! node (cons (cons key item) (node-alist node)))))) + +(define (cfg-node-remove! node key) + (set-node-alist! node (del-assq! key (node-alist node)))) + +;;;; Edge Datatype + +(define-structure (edge (type vector)) + left-node + left-connect + right-node) + (define (create-edge! left-node left-connect right-node) (let ((edge (make-edge left-node left-connect right-node))) (if left-node @@ -105,6 +119,12 @@ MIT in each case. |# (add-node-previous-edge! right-node edge)) edge)) +(define-integrable (node->edge node) + (create-edge! false false node)) + +(define (edge-next-node edge) + (and edge (edge-right-node edge))) + (define (edge-connect-left! edge left-node left-connect) (if (edge-left-node edge) (error "Attempt to doubly connect left node of edge" edge)) @@ -121,7 +141,7 @@ MIT in each case. |# (begin (set-edge-right-node! edge right-node) (add-node-previous-edge! right-node edge)))) - + (define (edge-disconnect-left! edge) (let ((left-node (edge-left-node edge)) (left-connect (edge-left-connect edge))) @@ -138,28 +158,23 @@ MIT in each case. |# (set-edge-right-node! edge false) (delete-node-previous-edge! right-node edge))))) -(define (edges-connect-right! edges right-node) - (for-each (lambda (edge) (edge-connect-right! edge right-node)) edges)) - (define (edge-disconnect! edge) (edge-disconnect-left! edge) (edge-disconnect-right! edge)) -(define (edges-disconnect-right! edges) - (for-each edge-disconnect-right! edges)) - -;;;; Node Properties +(define (edge-replace-left! edge left-node left-connect) + (edge-disconnect-left! edge) + (edge-connect-left! edge left-node left-connect)) -(define (cfg-node-get node key) - (let ((entry (assq key (node-alist node)))) - (and entry - (cdr entry)))) +(define (edge-replace-right! edge right-node) + (edge-disconnect-right! edge) + (edge-connect-right! edge right-node)) -(define (cfg-node-put! node key item) - (let ((entry (assq key (node-alist node)))) - (if entry - (set-cdr! entry item) - (set-node-alist! node (cons (cons key item) (node-alist node)))))) +(define (edges-connect-right! edges right-node) + (for-each (lambda (edge) (edge-connect-right! edge right-node)) edges)) -(define (cfg-node-remove! node key) - (set-node-alist! node (del-assq! key (node-alist node)))) \ No newline at end of file +(define (edges-disconnect-right! edges) + (for-each edge-disconnect-right! edges)) + +(define (edges-replace-right! edges right-node) + (for-each (lambda (edge) (edge-replace-right! edge right-node)) edges)) \ No newline at end of file diff --git a/v7/src/compiler/base/cfg2.scm b/v7/src/compiler/base/cfg2.scm index 464fda5ca..e4104ac93 100644 --- a/v7/src/compiler/base/cfg2.scm +++ b/v7/src/compiler/base/cfg2.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/cfg2.scm,v 4.2 1987/12/30 06:58:00 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/cfg2.scm,v 4.3 1989/10/26 07:35:34 cph Rel $ -Copyright (c) 1987 Massachusetts Institute of Technology +Copyright (c) 1987, 1989 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -39,32 +39,78 @@ MIT in each case. |# ;;;; Editing (define (snode-delete! snode) - (let ((previous-edges (node-previous-edges snode)) - (next-edge (snode-next-edge snode))) + (let ((next-edge (snode-next-edge snode))) (if next-edge - (let ((node (edge-right-node next-edge))) - (edges-disconnect-right! previous-edges) - (edge-disconnect! next-edge) - (edges-connect-right! previous-edges node)) - (edges-disconnect-right! previous-edges)))) + (begin + (edges-replace-right! (node-previous-edges snode) + (edge-right-node next-edge)) + (edge-disconnect! next-edge)) + (edges-disconnect-right! (node-previous-edges snode))))) (define (edge-insert-snode! edge snode) (let ((next (edge-right-node edge))) - (edge-disconnect-right! edge) - (edge-connect-right! edge snode) + (edge-replace-right! edge snode) (create-edge! snode set-snode-next-edge! next))) (define (node-insert-snode! node snode) - (let ((previous-edges (node-previous-edges node))) - (edges-disconnect-right! previous-edges) - (edges-connect-right! previous-edges snode) - (create-edge! snode set-snode-next-edge! node))) - -(define-integrable (node->edge node) - (create-edge! false false node)) - -(define-integrable (cfg-entry-edge cfg) - (node->edge (cfg-entry-node cfg))) + (edges-replace-right! (node-previous-edges node) snode) + (create-edge! snode set-snode-next-edge! node)) + +(define-integrable (node-disconnect-on-right! node) + (edges-disconnect-right! (node-previous-edges node))) + +(define (node-disconnect-on-left! node) + (if (snode? node) + (snode-disconnect-on-left! node) + (pnode-disconnect-on-left! node))) + +(define (snode-disconnect-on-left! node) + (let ((edge (snode-next-edge node))) + (if edge + (edge-disconnect-left! edge)))) + +(define (pnode-disconnect-on-left! node) + (let ((edge (pnode-consequent-edge node))) + (if edge + (edge-disconnect-left! edge))) + (let ((edge (pnode-alternative-edge node))) + (if edge + (edge-disconnect-left! edge)))) + +(define (node-replace! old-node new-node) + (if (snode? old-node) + (snode-replace! old-node new-node) + (pnode-replace! old-node new-node))) + +(define (snode-replace! old-node new-node) + (node-replace-on-right! old-node new-node) + (snode-replace-on-left! old-node new-node)) + +(define (pnode-replace! old-node new-node) + (node-replace-on-right! old-node new-node) + (pnode-replace-on-left! old-node new-node)) + +(define-integrable (node-replace-on-right! old-node new-node) + (edges-replace-right! (node-previous-edges old-node) new-node)) + +(define (node-replace-on-left! old-node new-node) + (if (snode? old-node) + (snode-replace-on-left! old-node new-node) + (pnode-replace-on-left! old-node new-node))) + +(define (snode-replace-on-left! old-node new-node) + (let ((edge (snode-next-edge old-node))) + (if edge + (edge-replace-left! edge new-node set-snode-next-edge!)))) + +(define (pnode-replace-on-left! old-node new-node) + (let ((edge (pnode-consequent-edge old-node))) + (if edge + (edge-replace-left! edge new-node set-pnode-consequent-edge!))) + (let ((edge (pnode-alternative-edge old-node))) + (if edge + (edge-replace-left! edge new-node set-pnode-alternative-edge!)))) + ;;;; Previous Connections (define-integrable (node-previous=0? node) diff --git a/v7/src/compiler/base/cfg3.scm b/v7/src/compiler/base/cfg3.scm index 9f66f2f53..7e614fe8c 100644 --- a/v7/src/compiler/base/cfg3.scm +++ b/v7/src/compiler/base/cfg3.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/cfg3.scm,v 4.3 1989/03/28 20:41:57 arthur Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/cfg3.scm,v 4.4 1989/10/26 07:35:37 cph Rel $ -Copyright (c) 1987 Massachusetts Institute of Technology +Copyright (c) 1987, 1989 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -68,7 +68,11 @@ MIT in each case. |# (vector-ref pcfg 3)) (define-integrable (make-null-cfg) false) -(define-integrable cfg-null? false?) +(define-integrable cfg-null? false?) + +(define-integrable (cfg-entry-edge cfg) + (node->edge (cfg-entry-node cfg))) + (define-integrable (snode->scfg snode) (node->scfg snode set-snode-next-edge!)) diff --git a/v7/src/compiler/base/crstop.scm b/v7/src/compiler/base/crstop.scm index 0a687abca..c6c2fd412 100644 --- a/v7/src/compiler/base/crstop.scm +++ b/v7/src/compiler/base/crstop.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/crstop.scm,v 1.4 1989/08/21 19:32:21 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/crstop.scm,v 1.5 1989/10/26 07:35:41 cph Exp $ $MC68020-Header: toplev.scm,v 4.16 89/04/26 05:09:52 GMT cph Exp $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -95,14 +95,13 @@ MIT in each case. |# (if (default-object? info-output-pathname) (set! info-output-pathname false)) - (fluid-let ((*info-output-pathname* - (if (and info-output-pathname - (not (eq? info-output-pathname true))) - info-output-pathname - *info-output-pathname*)) + (fluid-let ((*info-output-filename* + (if (pathname? info-output-pathname) + (pathname->string info-output-pathname) + *info-output-filename*)) (*rtl-output-pathname* - (if (and rtl-output-pathname - (not (eq? rtl-output-pathname true))) rtl-output-pathname + (if (pathname? rtl-output-pathname) + rtl-output-pathname *rtl-output-pathname*))) ((if (default-object? wrapper) in-compiler diff --git a/v7/src/compiler/base/ctypes.scm b/v7/src/compiler/base/ctypes.scm index 5491f7c74..b32dfe530 100644 --- a/v7/src/compiler/base/ctypes.scm +++ b/v7/src/compiler/base/ctypes.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/ctypes.scm,v 4.13 1989/08/10 11:05:10 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/ctypes.scm,v 4.14 1989/10/26 07:35:44 cph Exp $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -49,7 +49,6 @@ MIT in each case. |# operand-values ;set by outer-analysis, used by identify-closure-limits continuation-push model ;set by identify-closure-limits, used in generation - destination-block ;used by identify-closure-limits to quench propagation frame-adjustment ;set by setup-frame-adjustments, used in generation reuse-existing-frame? ;set by setup-frame-adjustments, used in generation ) @@ -60,7 +59,7 @@ MIT in each case. |# (let ((application (make-snode application-tag type block operator operands false '() '() - continuation-push false true false false))) + continuation-push false false false))) (set! *applications* (cons application *applications*)) (add-block-application! block application) (if (rvalue/reference? operator) @@ -141,10 +140,16 @@ MIT in each case. |# (define-integrable (combination/operands combination) (cdr (application-operands combination))) +(define (combination/simple-inline? combination) + (let ((inliner (combination/inliner combination))) + (and inliner + (not (inliner/internal-close-coding? inliner))))) + (define-structure (inliner (type vector) (conc-name inliner/)) (handler false read-only true) (generator false read-only true) - operands) + operands + internal-close-coding?) (define-integrable (make-return block continuation rvalue) (make-application 'RETURN block continuation (list rvalue) false)) @@ -155,6 +160,9 @@ MIT in each case. |# (define-integrable return/context application-context) (define-integrable return/operator application-operator) (define-integrable return/continuation-push application-continuation-push) +(define-integrable return/equivalence-class application-model) +(define-integrable set-return/equivalence-class! set-application-model!) + (define-integrable (return/operand return) (car (application-operands return))) diff --git a/v7/src/compiler/base/debug.scm b/v7/src/compiler/base/debug.scm index 9b97e1bbe..7b5bcad0d 100644 --- a/v7/src/compiler/base/debug.scm +++ b/v7/src/compiler/base/debug.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/debug.scm,v 4.10 1989/08/21 19:32:23 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/debug.scm,v 4.11 1989/10/26 07:35:47 cph Exp $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -78,8 +78,8 @@ MIT in each case. |# (compiled-code-address->block object))) (write-string "\nOffset: ") (write-string - (number->string (compiled-code-address->offset object) - '(HEUR (RADIX X S))))) (else + (number->string (compiled-code-address->offset object) 16))) + (else (error "debug/where -- what?" object)))) (define (compiler:write-rtl-file input-path #!optional output-path) diff --git a/v7/src/compiler/base/infnew.scm b/v7/src/compiler/base/infnew.scm index 7d5bc83ac..29a549524 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.5 1989/08/21 19:32:26 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/infnew.scm,v 4.6 1989/10/26 07:35:51 cph Exp $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -199,14 +199,21 @@ MIT in each case. |# (define (variable->dbg-variable variable) (or (lvalue-get variable dbg-variable-tag) - (let ((integrated? (lvalue-integrated? variable))) + (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)) - (and integrated? - (lvalue-known-value variable))))) (if integrated? + (cond (integrated? + (lvalue-known-value variable)) + (indirection + (variable->dbg-variable indirection)) + (else + false))))) + (if integrated? (set! *integrated-variables* (cons dbg-variable *integrated-variables*))) (lvalue-put! variable dbg-variable-tag dbg-variable) diff --git a/v7/src/compiler/base/lvalue.scm b/v7/src/compiler/base/lvalue.scm index a3ee48871..2dd4a7ba9 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.15 1989/08/10 11:05:16 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/lvalue.scm,v 4.16 1989/10/26 07:35:56 cph Exp $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -86,6 +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] ) (define continuation-variable/type variable-in-cell?) @@ -93,7 +94,7 @@ MIT in each case. |# (define (make-variable block name) (make-lvalue variable-tag block name '() false false '() false false - false)) + false false)) (define variable-assoc (association-procedure eq? variable-name)) @@ -127,7 +128,7 @@ MIT in each case. |# (define-named-variable continuation) (define-named-variable value)) -(define-integrable (variable/register variable) +(define (variable/register variable) (let ((maybe-delayed-register (variable-register variable))) (if (promise? maybe-delayed-register) (force maybe-delayed-register) @@ -238,7 +239,7 @@ MIT in each case. |# variable (cons assignment (variable-assignments variable)))) -(define (variable-assigned? variable) +(define-integrable (variable-assigned? variable) (not (null? (variable-assignments variable)))) ;; Note: @@ -255,6 +256,10 @@ MIT in each case. |# (or (rvalue/constant? value) (and (rvalue/procedure? value) (procedure/virtually-open? value)))))) + +(define (variable-unused? variable) + (or (lvalue-integrated? variable) + (variable-indirection variable))) (define (lvalue=? lvalue lvalue*) (or (eq? lvalue lvalue*) @@ -283,8 +288,9 @@ MIT in each case. |# (define-integrable (lvalue/external-source? lvalue) ;; (number? (lvalue-passed-in? lvalue)) - (and (lvalue-passed-in? lvalue) - (not (eq? (lvalue-passed-in? lvalue) 'INHERITED)))) + (let ((passed-in? (lvalue-passed-in? lvalue))) + (and passed-in? + (not (eq? passed-in? 'INHERITED))))) (define-integrable (lvalue/internal-source? lvalue) (not (null? (lvalue-initial-values lvalue)))) @@ -306,4 +312,51 @@ MIT in each case. |# ;; is the outermost IC block of the expression in ;; which the variable is referenced. (memq variable - (block-bound-variables reference-block)))))))) \ No newline at end of file + (block-bound-variables reference-block)))))))) + +(define (lvalue/articulation-points lvalue) + ;; This won't work if (memq lvalue (lvalue-backward-links lvalue))? + (let ((articulation-points '()) + (number-tag "number-tag")) + (let ((articulation-point! + (lambda (lvalue) + (if (not (memq lvalue articulation-points)) + (begin + (set! articulation-points (cons lvalue articulation-points)) + unspecific)))) + (allocate-number! + (let ((n 0)) + (lambda () + (let ((number n)) + (set! n (1+ n)) + number))))) + (with-new-lvalue-marks + (lambda () + (let loop ((lvalue lvalue) (parent false) (number (allocate-number!))) + (lvalue-mark! lvalue) + (lvalue-put! lvalue number-tag number) + (if (lvalue/source? lvalue) + number + (apply min + (cons number + (map (lambda (link) + (cond ((not (lvalue-marked? link)) + (let ((low + (loop link + lvalue + (allocate-number!)))) + (if (<= number low) + (articulation-point! lvalue)) + low)) + ((eq? link parent) + number) + (else + (lvalue-get link number-tag)))) + (lvalue-initial-backward-links lvalue))))))))) + (set! articulation-points + (sort (delq! lvalue articulation-points) + (lambda (x y) + (< (lvalue-get x number-tag) (lvalue-get y number-tag))))) + (for-each (lambda (lvalue) (lvalue-remove! lvalue number-tag)) + (cons lvalue (lvalue-backward-links lvalue))) + articulation-points)) \ No newline at end of file diff --git a/v7/src/compiler/base/object.scm b/v7/src/compiler/base/object.scm index cfe335652..1cd37f03b 100644 --- a/v7/src/compiler/base/object.scm +++ b/v7/src/compiler/base/object.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/object.scm,v 4.7 1989/08/10 11:05:19 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/object.scm,v 4.8 1989/10/26 07:36:00 cph Rel $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -118,7 +118,11 @@ MIT in each case. |# (vector-tag? (tagged-vector/tag object)))) (define (->tagged-vector object) - (let ((object (if (integer? object) (unhash object) object))) (and (or (tagged-vector? object) + (let ((object + (if (exact-nonnegative-integer? object) + (unhash object) + object))) + (and (or (tagged-vector? object) (named-structure? object)) object))) diff --git a/v7/src/compiler/base/proced.scm b/v7/src/compiler/base/proced.scm index 4b27ca9f5..b62a49001 100644 --- a/v7/src/compiler/base/proced.scm +++ b/v7/src/compiler/base/proced.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/proced.scm,v 4.14 1989/08/10 11:05:23 cph Exp $ +$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 $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -153,10 +153,6 @@ MIT in each case. |# (define-integrable set-procedure-passed-out?! set-rvalue-%passed-out?!) - -(define (close-procedure? procedure) - (not (eq? (procedure-closing-limit procedure) - (procedure-closing-block procedure)))) (define-integrable (closure-procedure-needs-operator? procedure) ;; This must be true if the closure needs its parent frame since the @@ -184,10 +180,11 @@ MIT in each case. |# (assq 'TRIVIAL (procedure-properties procedure))) (define (procedure-inline-code? procedure) - (or (procedure/trivial? procedure) - (and (procedure-always-known-operator? procedure) - (procedure-application-unique? procedure) - (procedure/virtually-open? procedure)))) + (and (not (procedure-rest procedure)) + (or (procedure/trivial? procedure) + (and (procedure-always-known-operator? procedure) + (procedure-application-unique? procedure) + (procedure/virtually-open? procedure))))) (define-integrable (open-procedure-needs-static-link? procedure) (stack-block/static-link? (procedure-block procedure))) diff --git a/v7/src/compiler/base/toplev.scm b/v7/src/compiler/base/toplev.scm index d16956cc9..3a0362ec1 100644 --- a/v7/src/compiler/base/toplev.scm +++ b/v7/src/compiler/base/toplev.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/toplev.scm,v 4.21 1989/09/24 03:39:40 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/toplev.scm,v 4.22 1989/10/26 07:36:07 cph Exp $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -586,12 +586,12 @@ MIT in each case. |# (phase/fold-constants) (phase/open-coding-analysis) (phase/operator-analysis) + (phase/variable-indirection) (phase/environment-optimization) (phase/identify-closure-limits) (phase/setup-block-types) (phase/compute-call-graph) (phase/side-effect-analysis) (phase/continuation-analysis) - (phase/setup-frame-adjustments) (phase/subproblem-analysis) (phase/delete-integrated-parameters) (phase/subproblem-ordering) @@ -599,6 +599,7 @@ MIT in each case. |# (phase/design-environment-frames) (phase/connectivity-analysis) (phase/compute-node-offsets) + (phase/return-equivalencing) (phase/info-generation-1) (phase/fg-optimization-cleanup)))) @@ -627,6 +628,11 @@ MIT in each case. |# (lambda () (operator-analysis *procedures* *applications*)))) +(define (phase/variable-indirection) + (compiler-subphase "Variable Indirection" + (lambda () + (initialize-variable-indirections! *lvalues*)))) + (define (phase/environment-optimization) (compiler-subphase "Environment Optimization" (lambda () @@ -635,7 +641,15 @@ MIT in each case. |# (define (phase/identify-closure-limits) (compiler-subphase "Closure Limit Identification" (lambda () - (identify-closure-limits! *procedures* *applications* *lvalues*)))) + (identify-closure-limits! *procedures* *applications* *lvalues*) + (if (not compiler:preserve-data-structures?) + (for-each (lambda (procedure) + (if (not (procedure-continuation? procedure)) + (begin + (set-procedure-free-callees! procedure '()) + (set-procedure-free-callers! procedure '()) + (set-procedure-variables! procedure '())))) + *procedures*))))) (define (phase/setup-block-types) (compiler-subphase "Block Type Determination" @@ -656,13 +670,10 @@ MIT in each case. |# (define (phase/continuation-analysis) (compiler-subphase "Continuation Analysis" (lambda () - (continuation-analysis *blocks*)))) + (continuation-analysis *blocks*) + (setup-frame-adjustments *applications*) + (setup-block-static-links! *blocks*)))) -(define (phase/setup-frame-adjustments) - (compiler-subphase "Frame Adjustment Determination" - (lambda () - (setup-frame-adjustments *applications*)))) - (define (phase/subproblem-analysis) (compiler-subphase "Subproblem Analysis" (lambda () @@ -694,6 +705,11 @@ MIT in each case. |# (lambda () (compute-node-offsets *root-expression*)))) +(define (phase/return-equivalencing) + (compiler-subphase "Return Equivalencing" + (lambda () + (find-equivalent-returns! *lvalues* *applications*)))) + (define (phase/info-generation-1) (compiler-subphase "Debugging Information Initialization" (lambda () @@ -766,6 +782,7 @@ MIT in each case. |# (if compiler:cse? (phase/common-subexpression-elimination)) (phase/invertible-expression-elimination) + (phase/common-suffix-merging) (phase/lifetime-analysis) (if compiler:code-compression? (phase/code-compression)) @@ -782,7 +799,13 @@ MIT in each case. |# (compiler-subphase "Invertible Expression Elimination" (lambda () (invertible-expression-elimination *rtl-graphs*)))) - (define (phase/lifetime-analysis) + +(define (phase/common-suffix-merging) + (compiler-subphase "Common Suffix Merging" + (lambda () + (merge-common-suffixes! *rtl-graphs*)))) + +(define (phase/lifetime-analysis) (compiler-subphase "Lifetime Analysis" (lambda () (lifetime-analysis *rtl-graphs*)))) diff --git a/v7/src/compiler/base/utils.scm b/v7/src/compiler/base/utils.scm index 20ff3b2cb..c0ff4d51b 100644 --- a/v7/src/compiler/base/utils.scm +++ b/v7/src/compiler/base/utils.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/utils.scm,v 4.13 1989/08/28 18:33:09 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/utils.scm,v 4.14 1989/10/26 07:36:11 cph Exp $ Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology @@ -77,7 +77,7 @@ MIT in each case. |# ((eq? prefix lambda-tag:fluid-let) 'FLUID-LET) (else prefix))) "-" - (number->string (generate-label-number) 10)))) + (number->string (generate-label-number))))) (define *current-label-number*) @@ -209,35 +209,51 @@ MIT in each case. |# (scode/primitive-procedure? object) (eq? object compiled-error-procedure))) -(define function-names +(define boolean-valued-function-names '( - ;; Predicates OBJECT-TYPE? EQ? FALSE? NULL? PAIR? VECTOR? SYMBOL? STRING? - NUMBER? CHAR? PROMISE? BIT-STRING? CELL? CHAR-ASCII? - - ;; Numbers + NUMBER? CHAR? PROMISE? BIT-STRING? CELL? COMPLEX? REAL? RATIONAL? INTEGER? EXACT? INEXACT? ZERO? POSITIVE? NEGATIVE? ODD? EVEN? - = < > <= >= MAX MIN - + - * / 1+ -1+ ABS QUOTIENT REMAINDER MODULO INTEGER-DIVIDE - GCD LCM FLOOR CEILING TRUNCATE ROUND - EXP LOG EXPT SQRT SIN COS TAN ASIN ACOS ATAN - FIX:ZERO? FIX:NEGATIVE? FIX:POSITIVE? - FIX:= FIX:< FIX:> FIX:1+ FIX:-1+ FIX:+ FIX:- FIX:* - FIX:DIVIDE FIX:GCD FIX:QUOTIENT FIX:REMAINDER - - ;; Random - OBJECT-TYPE NOT ASCII->CHAR CHAR->INTEGER CHAR-BITS CHAR-CODE - CHAR-DOWNCASE CHAR-UPCASE INTEGER->CHAR MAKE-CHAR - PRIMITIVE-PROCEDURE-ARITY - - ;; References (assumes immediate constants are immutable) - CAR CDR LENGTH - VECTOR-REF VECTOR-LENGTH - STRING-REF STRING-LENGTH STRING-MAXIMUM-LENGTH - BIT-STRING-REF BIT-STRING-LENGTH + = < > <= >= + FIX:FIXNUM? FIX:ZERO? FIX:NEGATIVE? FIX:POSITIVE? FIX:= FIX:< FIX:> + FLO:FLONUM? FLO:ZERO? FLO:NEGATIVE? FLO:POSITIVE? FLO:= FLO:< FLO:> + INT:INTEGER? INT:ZERO? INT:NEGATIVE? INT:POSITIVE? INT:= INT:< INT:> + NOT BIT-STRING-REF )) +(define function-names + (append + boolean-valued-function-names + '( + ;; Numbers + MAX MIN + - * / 1+ -1+ CONJUGATE ABS QUOTIENT REMAINDER MODULO + INTEGER-DIVIDE GCD LCM NUMERATOR DENOMINATOR FLOOR CEILING TRUNCATE ROUND + FLOOR->EXACT CEILING->EXACT TRUNCATE->EXACT ROUND->EXACT + RATIONALIZE RATIONALIZE->EXACT SIMPLEST-RATIONAL SIMPLEST-EXACT-RATIONAL + EXP LOG SIN COS TAN ASIN ACOS ATAN SQRT EXPT MAKE-RECTANGULAR MAKE-POLAR + REAL-PART IMAG-PART MAGNITUDE ANGLE EXACT->INEXACT INEXACT->EXACT + FIX:1+ FIX:-1+ FIX:+ FIX:- FIX:* + FIX:DIVIDE FIX:GCD FIX:QUOTIENT FIX:REMAINDER + INT:+ INT:- INT:* INT:DIVIDE INT:QUOTIENT INT:REMAINDER INT:ABS + INT:1+ INT:-1+ INT:NEGATE + FLO:+ FLO:- FLO:* FLO:/ FLO:NEGATE FLO:ABS FLO:EXP FLO:LOG FLO:SIN FLO:COS + FLO:TAN FLO:ASIN FLO:ACOS FLO:ATAN FLO:ATAN2 FLO:SQRT FLO:EXPT FLO:FLOOR + FLO:CEILING FLO:TRUNCATE FLO:ROUND FLO:FLOOR->EXACT FLO:CEILING->EXACT + FLO:TRUNCATE->EXACT FLO:ROUND->EXACT + + ;; Random + OBJECT-TYPE CHAR-ASCII? ASCII->CHAR CHAR->INTEGER CHAR-BITS CHAR-CODE + CHAR-DOWNCASE CHAR-UPCASE INTEGER->CHAR MAKE-CHAR + PRIMITIVE-PROCEDURE-ARITY + + ;; References (assumes immediate constants are immutable) + CAR CDR LENGTH + VECTOR-REF VECTOR-LENGTH + STRING-REF STRING-LENGTH STRING-MAXIMUM-LENGTH + BIT-STRING-LENGTH + ))) + ;; The following definition is used to avoid computation if possible. ;; Not to avoid recomputation. To avoid recomputation, function-names ;; should be used. @@ -254,31 +270,74 @@ MIT in each case. |# LIST->VECTOR VECTOR->LIST MAKE-BIT-STRING MAKE-CELL STRING->SYMBOL )) +(define additional-boolean-valued-function-primitives + (list (ucode-primitive zero?) + (ucode-primitive positive?) + (ucode-primitive negative?) + (ucode-primitive &=) + (ucode-primitive &<) + (ucode-primitive &>))) + (define additional-function-primitives - (list - (ucode-primitive &+) (ucode-primitive &-) - (ucode-primitive &*) (ucode-primitive &/) - (ucode-primitive &<) (ucode-primitive &>) - (ucode-primitive &=) (ucode-primitive &atan))) + (list (ucode-primitive 1+) + (ucode-primitive -1+) + (ucode-primitive &+) + (ucode-primitive &-) + (ucode-primitive &*) + (ucode-primitive &/))) ;;;; "Foldable" and side-effect-free operators -(define function-variables - (map (lambda (name) - (cons name - (lexical-reference system-global-environment name))) - function-names)) +(define boolean-valued-function-variables) +(define function-variables) +(define side-effect-free-variables) +(define boolean-valued-function-primitives) +(define function-primitives) +(define side-effect-free-primitives) + +(let ((global-valued + (lambda (names) + (list-transform-negative names + (lambda (name) + (lexical-unreferenceable? system-global-environment name))))) + (global-value + (lambda (name) + (lexical-reference system-global-environment name))) + (primitives + (let ((primitive-procedure? + (lexical-reference system-global-environment + 'PRIMITIVE-PROCEDURE?))) + (lambda (procedures) + (list-transform-positive procedures primitive-procedure?))))) + (let ((names (global-valued boolean-valued-function-names))) + (let ((procedures (map global-value names))) + (set! boolean-valued-function-variables (map cons names procedures)) + (set! boolean-valued-function-primitives + (append! (primitives procedures) + additional-boolean-valued-function-primitives)))) + (let ((names (global-valued function-names))) + (let ((procedures (map global-value names))) + (set! function-variables + (map* boolean-valued-function-variables cons names procedures)) + (set! function-primitives + (append! (primitives procedures) + (append additional-function-primitives + boolean-valued-function-primitives))))) + (let ((names (global-valued side-effect-free-additional-names))) + (let ((procedures (map global-value names))) + (set! side-effect-free-variables + (map* function-variables cons names procedures)) + (set! side-effect-free-primitives + (append! (primitives procedures) + function-primitives)) + unspecific))) + +(define-integrable (boolean-valued-function-variable? name) + (assq name boolean-valued-function-variables)) (define-integrable (constant-foldable-variable? name) (assq name function-variables)) -(define side-effect-free-variables - (map* function-variables - (lambda (name) - (cons name - (lexical-reference system-global-environment name))) - side-effect-free-additional-names)) - (define-integrable (side-effect-free-variable? name) (assq name side-effect-free-variables)) @@ -287,22 +346,14 @@ MIT in each case. |# (and place (cdr place)))) -(define function-primitives - (append! - (list-transform-positive (map cdr function-variables) - (lexical-reference system-global-environment 'PRIMITIVE-PROCEDURE?)) - additional-function-primitives)) +(define-integrable (boolean-valued-function-primitive? operator) + (memq operator boolean-valued-function-primitives)) -(define (constant-foldable-primitive? operator) +(define-integrable (constant-foldable-primitive? operator) (memq operator function-primitives)) -(define side-effect-free-primitives - (append! - (list-transform-positive (map cdr side-effect-free-variables) - (lexical-reference system-global-environment 'PRIMITIVE-PROCEDURE?)) - additional-function-primitives)) - -(define (side-effect-free-primitive? operator) (memq operator side-effect-free-primitives)) +(define-integrable (side-effect-free-primitive? operator) + (memq operator side-effect-free-primitives)) (define procedure-object? (lexical-reference system-global-environment 'PROCEDURE?)) diff --git a/v7/src/compiler/fggen/fggen.scm b/v7/src/compiler/fggen/fggen.scm index 1c4598044..ab214d757 100644 --- a/v7/src/compiler/fggen/fggen.scm +++ b/v7/src/compiler/fggen/fggen.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fggen/fggen.scm,v 4.22 1989/09/20 16:39:24 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fggen/fggen.scm,v 4.23 1989/10/26 07:36:21 cph Exp $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -44,14 +44,16 @@ MIT in each case. |# (make-expression block continuation - (transmit-values - (if (scode/open-block? scode) - (scode/open-block-components scode - (lambda (names declarations body) - (return-3 (make-variables block names) - declarations - (unscan-defines names '() body)))) - (return-3 '() '() scode)) + (with-values + (lambda () + (let ((collect + (lambda (names declarations body) + (values (make-variables block names) + declarations + (unscan-defines names '() body))))) + (if (scode/open-block? scode) + (scode/open-block-components scode collect) + (scan-defines scode collect)))) (lambda (variables declarations scode) (set-block-bound-variables! block variables) (generate/body block continuation declarations scode)))))) @@ -683,16 +685,32 @@ MIT in each case. |# (define (generate/disjunction/value block continuation expression) (scode/disjunction-components expression (lambda (predicate alternative) - (generate/combination - block - continuation - (let ((temp (generate-uninterned-symbol))) - (scode/make-let (list temp) - (list predicate) - (let ((predicate (scode/make-variable temp))) - (scode/make-conditional predicate - predicate - alternative)))))))) + (if (and (scode/combination? predicate) + (boolean-valued-operator? + (scode/combination-operator predicate))) + (generate/conditional + block + continuation + (scode/make-conditional predicate true alternative)) + (generate/combination + block + continuation + (let ((temp (generate-uninterned-symbol))) + (scode/make-let (list temp) + (list predicate) + (let ((predicate (scode/make-variable temp))) + (scode/make-conditional predicate + predicate + alternative))))))))) + +(define (boolean-valued-operator? operator) + (cond ((scode/primitive-procedure? operator) + (boolean-valued-function-primitive? operator)) + ((scode/absolute-reference? operator) + (boolean-valued-function-variable? + (scode/absolute-reference-name operator))) + (else + false))) (define (generate/access block continuation expression) (scode/access-components expression @@ -738,7 +756,8 @@ MIT in each case. |# ;; Enclose directives are generated only for lambda expressions ;; evaluated in environments whose manipulation has been made -;; explicit. The code should include a syntatic check. The;; expression must be a call to scode-eval with a quotation of a +;; explicit. The code should include a syntactic check. The +;; expression must be a call to scode-eval with a quotation of a ;; lambda and a variable as arguments. ;; NOTE: This code depends on lvalue-integrated? never integrating ;; the hidden reference within the procedure object. See base/lvalue diff --git a/v7/src/compiler/fgopt/blktyp.scm b/v7/src/compiler/fgopt/blktyp.scm index b02abcae1..d6f3b5c0e 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.12 1989/09/24 03:37:31 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/blktyp.scm,v 4.13 1989/10/26 07:36:36 cph Exp $ -Copyright (c) 1987, 1988 Massachusetts Institute of Technology +Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -44,7 +44,7 @@ MIT in each case. |# (block-type! block block-type/ic) (begin (block-type! block block-type/stack) - (maybe-close-procedure! block)))) + (maybe-close-procedure! (block-procedure block))))) ((CONTINUATION) (for-each loop (block-children block))) ((EXPRESSION) @@ -60,56 +60,53 @@ MIT in each case. |# (loop root-block)) -(define (maybe-close-procedure! block) - (if (procedure-closure-context (block-procedure block)) - (close-procedure! block))) - -(define (close-procedure! block) - (let ((procedure (block-procedure block)) - (current-parent (block-parent block))) - - (define (uninteresting-variable? variable) - (or (lvalue-integrated? variable) - ;; Some of this is redundant - (let ((value (lvalue-known-value variable))) - (and value - (or (eq? value procedure) - (and (rvalue/procedure? value) - (procedure/trivial-or-virtual? value))))))) - - (let ((previously-trivial? (procedure/trivial-closure? procedure)) - (parent (or (procedure-target-block procedure) current-parent))) - ;; Note: this should be innocuous if there is already a closure block. - ;; In particular, if there is a closure block which happens to be a - ;; reference placed there by the first-class environment transformation - ;; in fggen/fggen and fggen/canon, and it is replaced by the line below, - ;; the presumpt first-class environment is not really used as one, so - ;; the procedure is being "demoted" from first-class to closure. +(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 parent)) + (make-reference-context original-parent)) (with-values (lambda () - (find-closure-bindings - 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?))) + (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))) - (let ((new (procedure/trivial-closure? procedure))) - (if (or (and previously-trivial? (not new)) - (and (not previously-trivial?) new)) - (error "close-procedure! trivial becoming non-trivial or viceversa" - procedure)))) - (disown-block-child! current-parent block))) + (if (if previously-trivial? + (not (procedure/trivial-closure? procedure)) + (procedure/trivial-closure? procedure)) + (error "trivial procedure becoming non-trivial or vice-versa" + 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))))))) (define (find-closure-bindings block free-variables bound-variables variables-nontransitively-free) diff --git a/v7/src/compiler/fgopt/closan.scm b/v7/src/compiler/fgopt/closan.scm index a91ca6df3..a7172d39e 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.9 1989/09/24 03:33:55 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/closan.scm,v 4.10 1989/10/26 07:36:40 cph Exp $ Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology @@ -36,134 +36,79 @@ MIT in each case. |# (declare (usual-integrations)) -#| - -The closure analysis operates by identifying the "closing limit" of -each procedure, which is defined as the nearest ancestor of the -procedure's closing block which is active during the procedure's -lifetime. The closing limit is false whenever the extent of the -procedure is not fully known, or if the procedure must be fully closed -for any reason (including canonicalization). - -Procedures that are called from a closed procedure must inherit that -procedure's closing limit since only the blocks farther away than the -closing limit can be assumed to exist when those procedures are -called. - -The procedure's free variables which are bound in blocks up to the -closing limit (exclusive) must be consed in the heap. Other free -variables don't necessarily need to be allocated on the heap, provided -that there is a known way to get to them. - -This analysis is maximal in that it is required for ANY closure -construction mechanism that optimizes by means of a stack, because use -of a stack associates procedure extent with block scope. For many -simple techniques it generates more information than is needed. - -**** Unfortunately the analysis is not compatible with the current -implementation of closures. If a closure invokes another procedure -which is not a child, the current implementation requires that the -other procedure also be a closure. However, if the closing-limit of -the (closed) caller is the same as that of the (open) callee, the -callee will not be marked as a closure. This has disastrous results. -As a result, the analysis has been modified to force the closing-limit -to #F whenever a closure is identified. - -|# - (define (identify-closure-limits! procs&conts applications lvalues) (let ((procedures - (list-transform-negative procs&conts procedure-continuation?))) - (for-each initialize-lvalues-lists! lvalues) - (for-each initialize-closure-limit! procedures) - (for-each initialize-arguments! applications) - (transitive-closure - (lambda () - (for-each (lambda (procedure) - (if (procedure-passed-out? procedure) - (maybe-close-procedure! procedure - false - 'PASSED-OUT - false))) - procedures)) - (lambda (item) - (if (rvalue/procedure? item) - (analyze-procedure item) - (analyze-application item))) - (append procedures applications)) - ;; Clean up - (if (not compiler:preserve-data-structures?) - (for-each (lambda (procedure) - (set-procedure-free-callees! procedure '()) - (set-procedure-free-callers! procedure '()) - (set-procedure-variables! procedure '())) - procedures)))) - -(define (initialize-lvalues-lists! lvalue) - (if (lvalue/variable? lvalue) - (for-each (lambda (value) - (if (rvalue/procedure? value) - (set-procedure-variables! - value - (cons lvalue (procedure-variables value))))) - (lvalue-values lvalue)))) - -(define (initialize-closure-limit! procedure) - (set-procedure-closing-limit! procedure (procedure-closing-block procedure)) - ;; This sorting is crucial! It causes a procedure's ancestors to be - ;; considered for undrifting prior to the procedure being - ;; considered. This matters because the decision to undrift a - ;; procedure can be affected by whether or not the ancestors have - ;; been undrifted. - (set-procedure-free-callers! - procedure - (sort (procedure-free-callers procedure) - (lambda (x y) - (let ((y (procedure-block y)) - (x (procedure-block x))) - (and (not (eq? y x)) - (original-block-ancestor-or-self? y x))))))) - -(define (initialize-arguments! application) - (if (application/combination? application) - (begin - (let ((values - (let ((operands (application-operands application))) - (if (null? operands) - '() - (eq-set-union* (rvalue-values (car operands)) - (map rvalue-values (cdr operands))))))) - (set-application-operand-values! application values) - (for-each - (lambda (value) - (if (and (rvalue/procedure? value) - (not (procedure-continuation? value))) - (set-procedure-virtual-closure?! value true))) - values)) - (set-combination/model! - application - (rvalue-known-value (combination/operator application)))))) + (list-transform-negative procs&conts procedure-continuation?)) + (combinations + (list-transform-positive applications application/combination?))) + (for-each (lambda (procedure) + (set-procedure-variables! procedure '())) + procedures) + (for-each + (lambda (lvalue) + (if (lvalue/variable? lvalue) + (for-each (lambda (value) + (if (rvalue/procedure? value) + (set-procedure-variables! + value + (cons lvalue (procedure-variables value))))) + (lvalue-values lvalue)))) + lvalues) + (for-each + (lambda (combination) + (let ((values + (let ((operands (application-operands combination))) + (if (null? operands) + '() + (eq-set-union* (rvalue-values (car operands)) + (map rvalue-values (cdr operands))))))) + (set-application-operand-values! combination values) + (for-each + (lambda (value) + (if (and (rvalue/procedure? value) + (not (procedure-continuation? value))) + (set-procedure-virtual-closure?! value true))) + values)) + (set-combination/model! + combination + (rvalue-known-value (combination/operator combination)))) + combinations) + (undrift-procedures! + (fluid-let ((*undrifting-constraints* '())) + (with-new-node-marks + (lambda () + (transitive-closure + (lambda () + (for-each (lambda (procedure) + (if (procedure-passed-out? procedure) + (close-procedure! procedure 'PASSED-OUT false) + (analyze-procedure procedure))) + procedures)) + analyze-combination + combinations))) + *undrifting-constraints*)))) (define (analyze-procedure procedure) - (for-each (lambda (variable) - (maybe-close-procedure! procedure - (variable-block variable) - 'EXPORTED - variable)) - (procedure-variables procedure))) + (for-each + (lambda (variable) + ;; If this procedure is the value of a variable which is bound + ;; in a non-descendent block, we must close it. + (if (not (procedure-closure-context procedure)) + (close-if-unreachable! (variable-block variable) + (procedure-closing-block procedure) + procedure + 'EXPORTED + variable))) + (procedure-variables procedure))) -(define (analyze-application application) - (let* ((operator (application-operator application)) +(define (analyze-combination combination) + (let* ((operator (combination/operator combination)) (proc (rvalue-known-value operator)) (procs (rvalue-values operator))) - (cond ((not (application/combination? application)) - ;; If the combination is not an application, we need not - ;; examine the operators for compatibility. - unspecific) - ((rvalue-passed-in? operator) + (cond ((rvalue-passed-in? operator) ;; We don't need to close the operands because ;; they have been marked as passed out already. - (close-rvalue! operator 'APPLY-COMPATIBILITY application)) + (close-rvalue! operator 'APPLY-COMPATIBILITY combination)) ((null? procs) ;; The (null? procs) case is the NOP node case. This combination ;; should not be executed, so it should have no effect on any items @@ -172,7 +117,7 @@ to #F whenever a closure is identified. ((not proc) (let ((class (compatibility-class procs)) (model (car procs))) - (set-combination/model! application + (set-combination/model! combination (if (eq? class 'APPLY-COMPATIBILITY) false model)) @@ -181,35 +126,27 @@ to #F whenever a closure is identified. (set-procedure-virtual-closure?! proc true)) procs) (begin - (close-rvalue! operator class application) - (close-application-arguments! application false))))) + (close-rvalue! operator class combination) + (close-combination-arguments! combination))))) ((or (not (rvalue/procedure? proc)) (procedure-closure-context proc)) - (close-application-arguments! application false)) + (close-combination-arguments! combination)) (else unspecific)))) - -(define (close-application-arguments! application block) - (let ((previous (application-destination-block application))) - (let ((new - (if (eq? previous true) - block - (and previous - block - (block-nearest-common-ancestor block previous))))) - (if (not (eq? new previous)) - (begin - (set-application-destination-block! application new) - (close-values! (application-operand-values application) - new - 'ARGUMENT - application)))))) + +(define (close-combination-arguments! combination) + (if (not (node-marked? combination)) + (begin + (node-mark! combination) + (close-values! (application-operand-values combination) + 'ARGUMENT + combination)))) (define (compatibility-class procs) (if (not (for-all? procs rvalue/procedure?)) 'APPLY-COMPATIBILITY (let* ((model (car procs)) - (model-env (procedure-closing-limit model))) + (model-env (procedure-closing-block model))) (with-values (lambda () (procedure-arity-encoding model)) (lambda (model-min model-max) (let loop @@ -225,151 +162,180 @@ to #F whenever a closure is identified. (= model-max this-max)) (loop (cdr procs) (if (and (not (procedure/closure? this)) - (eq? (procedure-closing-limit this) + (eq? (procedure-closing-block this) model-env)) class 'COMPATIBILITY)) 'APPLY-COMPATIBILITY))))))))))) (define-integrable (close-rvalue! rvalue reason1 reason2) - (close-values! (rvalue-values rvalue) false reason1 reason2)) + (close-values! (rvalue-values rvalue) reason1 reason2)) -(define (close-values! values binding-block reason1 reason2) +(define (close-values! values reason1 reason2) (for-each (lambda (value) (if (and (rvalue/procedure? value) (not (procedure-continuation? value))) - (maybe-close-procedure! value - binding-block - reason1 - reason2))) + (close-procedure! value reason1 reason2))) values)) -(define (maybe-close-procedure! procedure binding-block reason1 reason2) - (let ((closing-limit (procedure-closing-limit procedure))) - (cond ((not closing-limit) - (add-closure-reason! procedure reason1 reason2)) - ((not (and binding-block - (block-ancestor-or-self? binding-block closing-limit))) - (close-procedure! procedure reason1 reason2))))) +(define (close-if-unreachable! block block* procedure reason1 reason2) + ;; If `block*' is not an ancestor of `block', close `procedure'. + (if (not (block-ancestor-or-self? block block*)) + ;; However, if it was an ancestor before procedure-drifting took + ;; place, don't close, just undo the drifting. + (if (original-block-ancestor? block block*) + (undrifting-constraint! block block* procedure reason1 reason2) + (close-procedure! procedure reason1 reason2)))) (define (close-procedure! procedure reason1 reason2) - (set-procedure-closing-limit! procedure false) - (if (procedure-virtual-closure? procedure) - (set-procedure-virtual-closure?! procedure false)) - (let ((previously-trivial? (procedure/trivial-closure? procedure))) - ;; We can't change the closing block yet. `setup-block-types!' - ;; has a consistency check that depends on the closing block - ;; remaining the same. - (add-closure-reason! procedure reason1 reason2) - ;; Force the procedure's type to CLOSURE. - (if (not (procedure-closure-context procedure)) - (set-procedure-closure-context! procedure true)) - ;; The code generator needs all callees to be closed. - (let ((block (procedure-block procedure))) - (for-each-callee! block - (lambda (value) - (if (not (block-ancestor-or-self? (procedure-block value) block)) - (maybe-close-procedure! value false 'CONTAGION procedure))))) - ;; The environment optimizer may have moved some procedures in the - ;; environment tree based on the (now incorrect) assumption that this - ;; procedure was not closed. Fix this. - ;; On the other hand, if it was trivial before, it is still trivial - ;; now, so the callers are not affected. - (if (not previously-trivial?) - (examine-free-callers! procedure)) - ;; We need to reexamine those applications which may have this procedure - ;; as an operator, since the compatibility class of the operator may have - ;; changed. - (enqueue-nodes! (procedure-applications procedure)))) + (add-closure-reason! procedure reason1 reason2) + (if (not (procedure-closure-context procedure)) + (begin + + ;; Force the procedure's type to CLOSURE. Don't change the + ;; closing block yet -- that will be taken care of by + ;; `setup-block-types!'. + (set-procedure-closure-context! procedure true) + (if (procedure-virtual-closure? procedure) + (set-procedure-virtual-closure?! procedure false)) + (cancel-dependent-undrifting-constraints! procedure) + (close-non-descendent-callees! procedure (procedure-block procedure)) + + ;; The procedure-drifting may have moved some procedures in + ;; the environment tree based on the (now incorrect) + ;; assumption that this procedure was not closed. Fix this. + ;; On the other hand, if it was trivial before, it is still + ;; trivial now, so the callers are not affected. + (if (not (procedure/trivial-closure? procedure)) + (examine-free-callers! procedure)) + + ;; We need to reexamine those applications which may have + ;; this procedure as an operator, since the compatibility + ;; class of the operator may have changed. + (enqueue-nodes! (procedure-applications procedure))))) -(define (for-each-callee! block procedure) +(define (close-non-descendent-callees! procedure block) (for-each-block-descendent! block (lambda (block*) - (for-each (lambda (application) - (for-each (lambda (value) - (if (and (rvalue/procedure? value) - (not (procedure-continuation? value))) - (procedure value))) - (rvalue-values - (application-operator application)))) - (block-applications block*))))) - + (for-each + (lambda (application) + (for-each (lambda (value) + (if (and (rvalue/procedure? value) + (not (procedure-continuation? value))) + (close-if-unreachable! (procedure-block value) block + value 'CONTAGION procedure))) + (rvalue-values (application-operator application)))) + (block-applications block*))))) + (define (examine-free-callers! procedure) - (let ((block (procedure-block procedure))) - (for-each - (lambda (procedure*) - (if (not (procedure-closure-context procedure*)) - (let ((parent (procedure-closing-block procedure*)) - (original-parent (procedure-target-block procedure*))) - ;; No need to do anything if PROCEDURE* hasn't drifted - ;; relative to PROCEDURE. - (if (and (not (eq? parent original-parent)) - (not (block-ancestor-or-self? parent block))) - (let ((binding-block - (reduce original-block-nearest-common-ancestor - false - (map variable-block - (cdr (assq procedure - (procedure-free-callees - procedure*))))))) - (if (not (block-ancestor-or-self? parent binding-block)) - ;; PROCEDURE* has drifted towards the - ;; environment root past the point where we - ;; have access to PROCEDURE (by means of free - ;; variables). We must drift it away from - ;; the root until we regain access to PROCEDURE. - (undrift-procedure! procedure* binding-block))))))) - (procedure-free-callers procedure)))) + (for-each + (lambda (procedure*) + (let ((block (procedure-block procedure*))) + (for-each + (lambda (block*) + (if (not (block-ancestor-or-self? block block*)) + (undrifting-constraint! block block* false false false))) + (map->eq-set + variable-block + (cdr (or (assq procedure (procedure-free-callees procedure*)) + (error "missing free-callee" procedure procedure*))))))) + (procedure-free-callers procedure))) + +(define *undrifting-constraints*) + +(define (undrifting-constraint! block block* procedure reason1 reason2) + (if (and procedure (procedure-closure-context procedure)) + (add-closure-reason! procedure reason1 reason2) + (let ((block + (let loop ((block block)) + (if (or (eq? (block-parent block) (original-block-parent block)) + (original-block-ancestor? (block-parent block) block*)) + (loop (block-parent block)) + block))) + (condition (and procedure (list procedure reason1 reason2)))) + (let ((entry (assq block *undrifting-constraints*)) + (check-inheritance + (lambda () + (let loop ((block* block*)) + (if block* + (let ((procedure (block-procedure block*))) + (if (eq? true (procedure-closure-context procedure)) + (close-non-descendent-callees! procedure block) + (loop (block-parent block*))))))))) + (if (not entry) + (begin + (set! *undrifting-constraints* + (cons (list block (list block* condition)) + *undrifting-constraints*)) + (check-inheritance)) + (let ((entry* (assq block* (cdr entry)))) + (cond ((not entry*) + (set-cdr! entry + (cons (list block* condition) (cdr entry))) + (check-inheritance)) + ((not + (if condition + (list-search-positive (cdr entry*) + (lambda (condition*) + (and + (eq? (car condition) (car condition*)) + (eqv? (cadr condition) (cadr condition*)) + (eqv? (caddr condition) (caddr condition*))))) + (memq false (cdr entry*)))) + (set-cdr! entry* (cons condition (cdr entry*))) + unspecific)))))))) -(define (undrift-procedure! procedure new-parent) - (let ((block (procedure-block procedure)) - (parent (procedure-closing-block procedure)) - (original-parent (procedure-target-block procedure))) - ;; (assert! (eq? parent (procedure-closing-limit procedure))) - (set-block-children! parent (delq! block (block-children parent))) - (set-block-parent! block new-parent) - (set-block-children! new-parent (cons block (block-children new-parent))) - (set-procedure-closing-limit! procedure new-parent) - (enqueue-nodes! (cons procedure (procedure-applications procedure))) - (if (eq? new-parent original-parent) - (set-block-disowned-children! - original-parent - (delq! block (block-disowned-children original-parent))) - (let ((parent-procedure (block-procedure original-parent))) - (if (and (not (block-ancestor-or-self? original-parent new-parent)) - (rvalue/procedure? parent-procedure) - (not (procedure-closure-context parent-procedure))) - ;; My original parent has drifted to a place where I - ;; can't be closed. I must drag it back. - (if (original-block-ancestor-or-self? original-parent new-parent) - (undrift-procedure! parent-procedure new-parent) - (error "Procedure has free variables in hyperspace!" - procedure))))) - (examine-free-callers! procedure))) +(define (cancel-dependent-undrifting-constraints! procedure) + (for-each + (let ((block (procedure-block procedure))) + (lambda (entry) + (for-each + (lambda (entry*) + (set-cdr! entry* + (list-transform-negative! (cdr entry*) + (lambda (constraint) + (and constraint (eq? procedure (car constraint))))))) + (cdr entry)) + (if (there-exists? (cdr entry) + (lambda (entry*) + (and (not (null? (cdr entry*))) + (block-ancestor-or-self? (car entry*) block)))) + (close-non-descendent-callees! procedure (car entry))))) + *undrifting-constraints*)) -;;; These are like the corresponding standard block operations, but -;;; they ignore any block drifting caused by envopt. +(define (undrift-procedures! constraints) + (for-each + (lambda (entry) + (let ((entries + (list-transform-negative! (cdr entry) + (lambda (entry*) + (null? (cdr entry*)))))) + (if (not (null? entries)) + (undrift-block! (car entry) + (reduce original-block-nearest-ancestor + false + (map car entries)))))) + constraints)) + +(define-integrable (list-transform-negative! items predicate) + ((list-deletor! predicate) items)) -(define (original-block-ancestor-or-self? block block*) - (or (eq? block block*) - (let loop ((block (original-block-parent block))) - (and block - (or (eq? block block*) - (loop (original-block-parent block))))))) +(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))))) -(define (original-block-nearest-common-ancestor block block*) - (let loop - ((join false) - (ancestry (original-block-ancestry block '())) - (ancestry* (original-block-ancestry block* '()))) - (if (and (not (null? ancestry)) - (not (null? ancestry*)) - (eq? (car ancestry) (car ancestry*))) - (loop (car ancestry) (cdr ancestry) (cdr ancestry*)) - join))) +(define (original-block-ancestor? block block*) + (let loop ((block (original-block-parent block))) + (and block + (or (eq? block block*) + (loop (original-block-parent block)))))) -(define (original-block-ancestry block path) - (let ((parent (original-block-parent block))) - (if parent - (original-block-ancestry parent (cons block path)) - (cons block path)))) \ No newline at end of file +(define (original-block-nearest-ancestor block block*) + (cond ((or (eq? block block*) (original-block-ancestor? block block*)) block) + ((original-block-ancestor? block* block) block*) + (else (error "unrelated blocks" block block*)))) \ No newline at end of file diff --git a/v7/src/compiler/fgopt/contan.scm b/v7/src/compiler/fgopt/contan.scm index 918dfc8c9..c2e20769a 100644 --- a/v7/src/compiler/fgopt/contan.scm +++ b/v7/src/compiler/fgopt/contan.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/contan.scm,v 4.8 1988/12/19 20:25:08 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/contan.scm,v 4.9 1989/10/26 07:36:44 cph Rel $ -Copyright (c) 1987, 1988 Massachusetts Institute of Technology +Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -139,6 +139,45 @@ may change if call-with-current-continuation is handled specially. (and (block-ancestor? block parent) block)))))))) +(define (setup-block-static-links! blocks) + (for-each + (lambda (block) + (if (stack-block? block) + (set-block-static-link?! block (compute-block-static-link? block)))) + blocks)) + +(define (compute-block-static-link? block) + ;; (and (not (block/no-free-references? block)) ...) + (let ((parent (block-parent block))) + (and parent + (cond ((stack-block? parent) (not (block-stack-link block))) + ((ic-block? parent) (ic-block/use-lookup? parent)) + (else true))))) + +(define (block/no-free-references? block) + (and (for-all? (block-free-variables block) + (lambda (variable) + (or (lvalue-integrated? variable) + (let ((block (variable-block variable))) + (and (ic-block? block) + (not (ic-block/use-lookup? block))))))) + (let loop ((block* block)) + (and (not + (there-exists? (block-applications block*) + (lambda (application) + (let ((block* + (if (application/combination? application) + (let ((adjustment + (combination/frame-adjustment + application))) + (and adjustment + (cdr adjustment))) + (block-popping-limit + (reference-context/block + (application-context application)))))) + (and block* (block-ancestor? block block*)))))) + (for-all? (block-children block*) loop))))) + (define (compute-block-popping-limits block) (let ((external (stack-block/external-ancestor block))) (map->eq-set diff --git a/v7/src/compiler/fgopt/delint.scm b/v7/src/compiler/fgopt/delint.scm index 50dc260e2..fdaf62327 100644 --- a/v7/src/compiler/fgopt/delint.scm +++ b/v7/src/compiler/fgopt/delint.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/delint.scm,v 1.1 1989/04/21 18:54:53 markf Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/delint.scm,v 1.2 1989/10/26 07:36:48 cph Exp $ Copyright (c) 1989 Massachusetts Institute of Technology @@ -32,8 +32,10 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. |# -;;;; Delete intergrated parameters +;;;; Delete integrated parameters +(declare (usual-integrations)) + (define (delete-integrated-parameters blocks) (for-each (lambda (block) @@ -64,9 +66,10 @@ MIT in each case. |# required))) (delete-integrations procedure-optional set-procedure-optional!)) (let ((rest (procedure-rest procedure))) - (if (and rest (lvalue-integrated? rest)) - (begin (set! deletions (eq-set-adjoin deletions rest)) - (set-procedure-rest! procedure false)))))) + (if (and rest (variable-unused? rest)) + (begin + (set! deletions (eq-set-adjoin deletions rest)) + (set-procedure-rest! procedure false)))))) (with-values (lambda () (find-integrated-bindings (procedure-names procedure) @@ -79,7 +82,7 @@ MIT in each case. |# (set-block-bound-variables! block (eq-set-difference (block-bound-variables block) deletions))))) - + (define (find-integrated-bindings names vals) (if (null? names) (values '() '() '()) @@ -87,7 +90,7 @@ MIT in each case. |# (lambda () (find-integrated-bindings (cdr names) (cdr vals))) (lambda (names* values* integrated) - (if (lvalue-integrated? (car names)) + (if (variable-unused? (car names)) (values names* values* (cons (car names) integrated)) (values (cons (car names) names*) (cons (car vals) values*) @@ -101,7 +104,7 @@ MIT in each case. |# (find-integrated-variables (cdr variables))) (lambda (not-integrated integrated) (if (or (variable-register (car variables)) - (lvalue-integrated? (car variables))) + (variable-unused? (car variables))) (values not-integrated (cons (car variables) integrated)) (values (cons (car variables) not-integrated) diff --git a/v7/src/compiler/fgopt/operan.scm b/v7/src/compiler/fgopt/operan.scm index 22c8560a1..be572047d 100644 --- a/v7/src/compiler/fgopt/operan.scm +++ b/v7/src/compiler/fgopt/operan.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/operan.scm,v 4.6 1989/05/08 22:21:09 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/operan.scm,v 4.7 1989/10/26 07:36:51 cph Rel $ Copyright (c) 1987, 1989 Massachusetts Institute of Technology @@ -66,7 +66,7 @@ MIT in each case. |# (define (continuation-passed-out? continuation) (there-exists? (continuation/combinations continuation) (lambda (combination) - (and (not (combination/inline? combination)) + (and (not (combination/simple-inline? combination)) (let ((operator (combination/operator combination))) (or (rvalue-passed-in? operator) (there-exists? (rvalue-values operator) diff --git a/v7/src/compiler/fgopt/order.scm b/v7/src/compiler/fgopt/order.scm index e9ea55903..c3db3b17b 100644 --- a/v7/src/compiler/fgopt/order.scm +++ b/v7/src/compiler/fgopt/order.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/order.scm,v 4.12 1989/05/31 20:01:50 jinx Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/order.scm,v 4.13 1989/10/26 07:36:55 cph Exp $ -Copyright (c) 1988 Massachusetts Institute of Technology +Copyright (c) 1988, 1989 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -37,53 +37,46 @@ MIT in each case. |# (declare (usual-integrations)) (define (subproblem-ordering parallels) - (for-each - (lambda (parallel) - (order-parallel! parallel false)) - parallels)) + (for-each (lambda (parallel) + (order-parallel! parallel false)) + parallels)) (define (order-parallel! parallel constraints) - (fluid-let ((*current-constraints* constraints)) - (let ((previous-edges (node-previous-edges parallel)) - (next-edge (snode-next-edge parallel))) - (let ((rest - (edge-next-node next-edge))) - (if rest - (begin - (edges-disconnect-right! previous-edges) - (edge-disconnect! next-edge) - (with-values - (lambda () - (order-subproblems/application - (parallel-application-node parallel) - (parallel-subproblems parallel) - rest)) - (lambda (cfg subproblem-order) - subproblem-order - (edges-connect-right! previous-edges cfg) - cfg)))))))) - -(define *current-constraints*) - -(define (order-subproblems-per-current-constraints subproblems) - (if *current-constraints* - (order-per-constraints subproblems *current-constraints*) - subproblems)) + constraints ;ignore + (let ((previous-edges (node-previous-edges parallel)) + (next-edge (snode-next-edge parallel))) + (let ((rest (edge-next-node next-edge))) + (if rest + (begin + (edges-disconnect-right! previous-edges) + (edge-disconnect! next-edge) + (with-values + (lambda () + (order-subproblems/application + (parallel-application-node parallel) + (parallel-subproblems parallel) + rest)) + (lambda (cfg subproblem-order) + subproblem-order + (edges-connect-right! previous-edges cfg) + cfg))))))) (define (order-subproblems/application application subproblems rest) (case (application-type application) ((COMBINATION) - ((if (combination/inline? application) - order-subproblems/inline - order-subproblems/out-of-line) - application subproblems rest)) + (if (and (combination/inline? application) + (or (combination/simple-inline? application) + (not (return-operator/reduction? + (combination/continuation application))))) + (order-subproblems/inline application subproblems rest) + (order-subproblems/out-of-line application subproblems rest))) ((RETURN) (values (linearize-subproblems! continuation-type/effect subproblems rest) subproblems)) (else (error "Unknown application type" application)))) - + (define (linearize-subproblems! continuation-type subproblems rest) (set-subproblem-types! subproblems continuation-type) (linearize-subproblems subproblems rest)) @@ -142,16 +135,12 @@ MIT in each case. |# simple continuation-type/register) (values - (linearize-subproblem! - continuation-type/effect - operator - (linearize-subproblems simple rest)) + (linearize-subproblem! continuation-type/effect + operator + (linearize-subproblems simple rest)) (cons operator simple))) (let ((push-set (cdr complex)) - (value-set - (cons (car complex) - (order-subproblems-per-current-constraints - simple)))) + (value-set (cons (car complex) simple))) (inline-subproblem-types! context push-set continuation-type/push) @@ -198,34 +187,26 @@ MIT in each case. |# (define (order-subproblems/out-of-line combination subproblems rest) (with-values - (combination-ordering - (combination/context combination) - (car subproblems) - (cdr subproblems) - (combination/model combination)) - (lambda (effect-subproblems push-subproblems register-subproblems) + (combination-ordering (combination/context combination) + (car subproblems) + (cdr subproblems) + (combination/model combination)) + (lambda (effect-subproblems push-subproblems) (set-combination/frame-size! combination (length push-subproblems)) (with-values (lambda () - (let ((rest - (linearize-subproblems! continuation-type/register - register-subproblems - rest))) - (order-subproblems/maybe-overwrite-block - combination push-subproblems rest - (lambda () - (values (linearize-subproblems! continuation-type/push - push-subproblems - rest) - push-subproblems))))) + (order-subproblems/maybe-overwrite-block + combination push-subproblems rest + (lambda () + (values (linearize-subproblems! continuation-type/push + push-subproblems + rest) + push-subproblems)))) (lambda (cfg push-subproblem-order) - (values (linearize-subproblems! - continuation-type/effect - effect-subproblems - cfg) - (append effect-subproblems - push-subproblem-order - register-subproblems))))))) + (values (linearize-subproblems! continuation-type/effect + effect-subproblems + cfg) + (append effect-subproblems push-subproblem-order))))))) (define (combination-ordering context operator operands model) (let ((standard @@ -234,8 +215,7 @@ MIT in each case. |# operator (operator-needed? (subproblem-rvalue operator)) '() - (reverse operands) - '()))) + (reverse operands)))) (optimized (lambda () (optimized-combination-ordering context operator operands model))) @@ -263,15 +243,12 @@ MIT in each case. |# (stack-block/static-link? model-block)) (lambda () (with-values thunk - (lambda (effect-subproblems - push-subproblems - register-subproblems) + (lambda (effect-subproblems push-subproblems) (values effect-subproblems (cons (new-subproblem context (block-parent model-block)) - push-subproblems) - register-subproblems)))) + push-subproblems))))) thunk)))) standard))) @@ -280,20 +257,13 @@ MIT in each case. |# (lambda () (sort-subproblems/out-of-line operands callee)) (lambda (n-unassigned integrated non-integrated) - (with-values - (lambda () - (sort-subproblems/pass-in-registers - non-integrated - operator - operands)) - (lambda (registerizable non-registerizable) - (handle-operator - context - operator - (operator-needed? (subproblem-rvalue operator)) - integrated - (make-unassigned-subproblems context n-unassigned non-registerizable) - registerizable)))))) + (handle-operator context + operator + (operator-needed? (subproblem-rvalue operator)) + integrated + (make-unassigned-subproblems context + n-unassigned + non-integrated))))) (define (known-combination-ordering context operator operands procedure) (if (and (not (procedure/closure? procedure)) @@ -314,26 +284,17 @@ MIT in each case. |# (n-optional (length (procedure-original-optional procedure)))) (let ((n-expected (+ n-required n-optional))) (if (or (< n-supplied n-required) (> n-supplied n-expected)) - (error - "known-combination-ordering: wrong number of arguments" - procedure n-supplied n-expected)) + (error "known-combination-ordering: wrong number of arguments" + procedure n-supplied n-expected)) (- n-expected n-supplied))) - (reverse operands)) - '())) + (reverse operands)))) -(define (handle-operator context operator operator-needed? - effect push register) +(define (handle-operator context operator operator-needed? effect push) (if operator-needed? - (values - (order-subproblems-per-current-constraints effect) - (append! push (list operator)) - (order-subproblems-per-current-constraints register)) + (values effect (append! push (list operator))) (begin (update-subproblem-contexts! context operator) - (values - (order-subproblems-per-current-constraints (cons operator effect)) - push - (order-subproblems-per-current-constraints register))))) + (values (cons operator effect) push)))) (define (make-unassigned-subproblems context n rest) (let ((unassigned (make-constant (make-unassigned-reference-trap)))) @@ -393,7 +354,10 @@ MIT in each case. |# 0 ; unassigned-count might work too ;; In this case the caller will ;; make slots for the optionals. - (+ unassigned-count (length optional))) + (+ unassigned-count + (length + (list-transform-negative optional + lvalue-integrated?)))) integrated non-integrated)) ((and (not (null? subproblems)) (not rest)) @@ -408,7 +372,7 @@ MIT in each case. |# (values unassigned-count integrated non-integrated)) - ((and rest (lvalue-integrated? rest)) + ((and rest (variable-unused? rest)) (values unassigned-count (append! (reverse subproblems) integrated) non-integrated)) @@ -421,7 +385,7 @@ MIT in each case. |# (define (sort-integrated lvalues subproblems integrated non-integrated) (cond ((or (null? lvalues) (null? subproblems)) (values lvalues subproblems integrated non-integrated)) - ((lvalue-integrated? (car lvalues)) + ((variable-unused? (car lvalues)) (sort-integrated (cdr lvalues) (cdr subproblems) (cons (car subproblems) integrated) @@ -432,24 +396,6 @@ MIT in each case. |# integrated (cons (car subproblems) non-integrated))))) -(define (sort-subproblems/pass-in-registers subproblems operator - operands) - (let ((operator-value - (rvalue-known-value - (subproblem-rvalue operator)))) - (if (and (rvalue/procedure? operator-value) - (procedure-maybe-registerizable? operator-value)) - (with-values - (lambda () - (discriminate-items subproblems subproblem-simple?)) - (lambda (simple complex) - (connect-subproblems-to-parameters! operator-value - operands - simple - complex))) - (values '() subproblems)))) - - (define (operator-needed? operator) (let ((callee (rvalue-known-value operator))) (cond ((not callee) @@ -488,54 +434,4 @@ MIT in each case. |# (if (let ((context* (procedure-closure-context rvalue))) (and (reference-context? context*) (check-old context*))) - (set-procedure-closure-context! rvalue context)))))) - -(define (connect-subproblems-to-parameters! operator operands simple - complex) - (let ((subproblems->requireds - (map cons - operands - (cdr (procedure-original-required operator)))) - (registerable-variables (parameter-analysis operator))) - - (define (reorder-subproblems subproblems) - (reverse - (list-transform-positive - operands - (lambda (operand) - (memq operand subproblems))))) - - (define (good-subproblem?! subproblem) - (let ((parameter-variable - (cdr (assq subproblem subproblems->requireds)))) - (and (not (variable-stack-overwrite-target? parameter-variable)) - (eq-set-subset? (list->eq-set (list parameter-variable)) - registerable-variables) - (begin - (set-variable-register! - parameter-variable - (delay (subproblem-register subproblem))) - (set-subproblem-type! subproblem - continuation-type/register) - true)))) - - (let loop ((subproblems simple) - (in-register '()) - (not-in-register complex)) - (if (null? subproblems) - (let ((squeeze-it-in - (list-search-positive complex good-subproblem?!)) - (ordered-pushes (reorder-subproblems not-in-register))) - (if squeeze-it-in - (values (cons squeeze-it-in in-register) - (delq squeeze-it-in ordered-pushes)) - (values in-register ordered-pushes))) - (let ((subproblem (car subproblems))) - (if (good-subproblem?! subproblem) - (loop (cdr subproblems) - (cons subproblem in-register) - not-in-register) - (loop (cdr subproblems) - in-register - (cons subproblem not-in-register)))))))) - + (set-procedure-closure-context! rvalue context)))))) \ No newline at end of file diff --git a/v7/src/compiler/fgopt/param.scm b/v7/src/compiler/fgopt/param.scm index 73fae0e4d..35385cf5b 100644 --- a/v7/src/compiler/fgopt/param.scm +++ b/v7/src/compiler/fgopt/param.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/param.scm,v 1.1 1989/04/21 16:23:27 markf Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/param.scm,v 1.2 1989/10/26 07:36:59 cph Rel $ -Copyright (c) 1988 Massachusetts Institute of Technology +Copyright (c) 1988, 1989 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -38,10 +38,11 @@ MIT in each case. |# ;;;; Procedure parameter analysis #| -A procedure is eligible for having it's parameters be placed in + +A procedure is eligible for having its parameters be placed in registers (i.e. the procedure is "registerizable") if the procedure will be inlined and the frame reuse routine has not tried to overwrite -any thing in the stack frame of this procedure or the stack frame +anything in the stack frame of this procedure or the stack frame associated with any ancestors of this procedure's block. Assuming that a procedure is registerizable, the parameter analysis @@ -49,12 +50,13 @@ phase determines which of it's parameters will indeed be passed in registers. A parameter will be passed in a register if all references to that -parameter in the procedure occur before any calls to complex procedures. A -complex procedure is essentially a non-inlined, non-open-coded -procedure. Additionally, we must check to make sure that there are no -references to the parameter in any closures or descendant blocks. Note -that inlined and open-coded procedures that are called within the -analysed procedure are considered to be part of that procedure. +parameter in the procedure occur before any calls to complex +procedures. A complex procedure is essentially a non-inlined, +non-open-coded procedure. Additionally, we must check to make sure +that there are no references to the parameter in any closures or +descendent blocks. Note that inlined and open-coded procedures that +are called within the analysed procedure are considered to be part of +that procedure. At certain times (when we hit an as yet unordered parallel) we have the opportunity to suggest an ordering of subproblems for a particular @@ -64,180 +66,153 @@ The order-parallel! procedure is free to ignore our suggestions. A major deficit with the current scheme is the restriction on registerizable procedures caused by the frame reuse stuff. The frame -reuse code is very aggressive and consequently there are very +reuse code is very aggressive and consequently there are very few occasions where we can in fact place parameters in registers. The -problem is that the frame resue code needs to know the stack layout, +problem is that the frame reuse code needs to know the stack layout, but the placing of parameters in registers affects the use of the stack. And because the parameter analysis code may call the subproblem -ordering code which may call the frame resue code, we have a very +ordering code which may call the frame reuse code, we have a very tricky timing problem. The correct solution may be to use a relaxation technique and iterate the subproblem ordering so that we can put more parameters in registers. + |# - + (define (parameter-analysis procedure) (fluid-let ((*inlined-procedures* '())) (let ((interesting-parameters - (list-transform-positive - (procedure-required procedure) + (list-transform-positive (procedure-required procedure) interesting-variable?))) - (and interesting-parameters - (let ((registerizable-parameters - (search-for-complex-combination - procedure - (lambda (node) - (walk-next node - find-all-variable-references - eq-set-union)) - (lambda () empty-eq-set)))) - ;; We have to check here if this procedure's block layout - ;; has been frozen by the frame reuse stuff which may - ;; have been called due to a call to order-parallel! - (and (not (block-layout-frozen? - (procedure-block procedure))) - (eq-set-difference - (eq-set-difference - (list->eq-set interesting-parameters) - registerizable-parameters) - (list->eq-set (bad-free-variables procedure))))))))) - -(define *inlined-procedures*) - -(define (search-for-complex-combination procedure - if-found - if-not-found) - (walk-proc-for-search (procedure-entry-node procedure) - if-found - if-not-found)) + (if interesting-parameters + (let ((registerizable-parameters + (with-new-node-marks + (lambda () + (walk-node-for-search + (procedure-entry-node procedure)))))) + ;; We have to check here if this procedure's block layout + ;; has been frozen by the frame reuse stuff which may + ;; have been called due to a call to order-parallel! + (if (block-layout-frozen? (procedure-block procedure)) + '() + (eq-set-difference + (eq-set-difference interesting-parameters + registerizable-parameters) + (bad-free-variables procedure)))) + '())))) -(define (walk-proc-for-search entry-node if-found if-not-found) - - (define (walk-node-for-search node) - (if (and node - (or (node-marked? node) - (begin - (node-mark! node) - (not (node-previous>1? node))))) - (or - (node/bad-variables node) - (cond - ((and (application? node) - (application/combination? node) - (combination-complex? node)) - (if-found node)) - ((parallel? node) - (walk-node-for-search - (if (for-all? (parallel-subproblems node) - subproblem-simple?) - (parallel->node node) - (handle-complex-parallel - node - (if-found node))))) - (else (walk-next node - walk-node-for-search - eq-set-union)))) - (if-not-found))) +(define (walk-node-for-search node) + (if (and node + (or (node-marked? node) + (begin + (node-mark! node) + (not (node-previous>1? node))))) + (or (node/bad-variables node) + (cond ((and (application? node) + (application/combination? node) + (not (combination/simple-inline? node)) + (not (let ((operator + (rvalue-known-value + (application-operator node)))) + (and operator + (rvalue/procedure? operator) + (procedure-inline-code? operator))))) + (walk-next node walk-node-for-variables)) + ((parallel? node) + (walk-node-for-search + (order-parallel! + node + (let ((subproblems (parallel-subproblems node))) + (if (for-all? subproblems subproblem-simple?) + false + (complex-parallel-constraints + subproblems + (walk-next node walk-node-for-variables))))))) + (else + (walk-next node walk-node-for-search)))) + '())) + +(define (walk-next node walker) + (cond ((application? node) + (case (application-type node) + ((COMBINATION) + (let ((operator (rvalue-known-value (application-operator node)))) + (if (and operator + (rvalue/procedure? operator) + (procedure-inline-code? operator)) + (begin + (set! *inlined-procedures* + (cons operator *inlined-procedures*)) + (walker (procedure-entry-node operator))) + (walk-continuation (combination/continuation node) walker)))) + ((RETURN) + (walk-continuation (return/operator node) walker)) + (else + (error "Illegal application type" node)))) + ((snode? node) + (walker (snode-next node))) + ((pnode? node) + (eq-set-union (walker (pnode-consequent node)) + (walker (pnode-alternative node)))) + (else + (error "Illegal node" node)))) - (with-new-node-marks - (lambda () - (walk-node-for-search - entry-node)))) - -(define (walk-next node walker combiner) - (cfg-node-case (tagged-vector/tag node) - ((APPLICATION) - (case (application-type node) - ((COMBINATION) - (let ((operator - (rvalue-known-value - (application-operator node)))) - (if (and operator - (rvalue/procedure? operator) - (procedure-inline-code? operator)) - (begin - (set! *inlined-procedures* - (cons operator *inlined-procedures*)) - (walker (procedure-entry-node operator))) - (walk-continuation (combination/continuation node) - walker)))) - ((RETURN) - (walk-continuation (return/operator node) - walker)))) - ((PARALLEL VIRTUAL-RETURN POP ASSIGNMENT - DEFINITION FG-NOOP STACK-OVERWRITE) - (walker (snode-next node))) - ((TRUE-TEST) - (combiner (walker (pnode-consequent node)) - (walker (pnode-alternative node)))))) +(define *inlined-procedures*) (define (walk-continuation continuation walker) (let ((rvalue (rvalue-known-value continuation))) - (walker (and rvalue - (continuation/entry-node rvalue))))) - + (walker (and rvalue (continuation/entry-node rvalue))))) (define (walk-node-for-variables node) (if node (if (parallel? node) - (walk-node-for-variables - (parallel->node node)) + (walk-node-for-variables (order-parallel! node false)) (begin (node-mark! node) - (or - (node/bad-variables node) - (let ((bad-variables - (eq-set-union - (with-values - (lambda () - (find-node-values node)) - values->variables) - (walk-next - node - walk-node-for-variables - eq-set-union)))) - (set-node/bad-variables! node bad-variables) - bad-variables)))) - empty-eq-set)) + (or (node/bad-variables node) + (let ((bad-variables + (eq-set-union + (with-values (lambda () (find-node-values node)) + values->variables) + (walk-next node walk-node-for-variables)))) + (set-node/bad-variables! node bad-variables) + bad-variables)))) + '())) -(define find-all-variable-references walk-node-for-variables) - (define (find-node-values node) - - (define (finish lval rval) - (values lval (list rval))) - - (cfg-node-case (tagged-vector/tag node) - ((APPLICATION) - (case (application-type node) - ((COMBINATION) - (if (combination/inline? node) - (values false (combination/operands node)) - (values false (cons - (combination/operator node) - (combination/operands node))))) - ((RETURN) - (finish false (return/operand node))))) - ((VIRTUAL-RETURN) - (finish false (virtual-return-operand node))) - ((ASSIGNMENT) - (finish (assignment-lvalue node) - (assignment-rvalue node))) - ((DEFINITION) - (finish (definition-lvalue node) - (definition-rvalue node))) - ((STACK-OVERWRITE) - (finish (let ((target (stack-overwrite-target node))) - (and (lvalue? target) target)) - false)) - ((PARALLEL) - (values - false - (safe-mapcan subproblem-free-variables - (parallel-subproblems node)))) - ((POP FG-NOOP) - (finish false false)) - ((TRUE-TEST) - (finish false (true-test-rvalue node))))) + (let ((finish + (lambda (lvalue rvalue) + (values lvalue (if rvalue (list rvalue) '()))))) + (cfg-node-case (tagged-vector/tag node) + ((APPLICATION) + (case (application-type node) + ((COMBINATION) + (values false + (cons (combination/operator node) + (combination/operands node)))) + ((RETURN) + (finish false (return/operand node))) + (else + (error "Illegal application type" node)))) + ((VIRTUAL-RETURN) + (finish false (virtual-return-operand node))) + ((ASSIGNMENT) + (finish (assignment-lvalue node) + (assignment-rvalue node))) + ((DEFINITION) + (finish (definition-lvalue node) + (definition-rvalue node))) + ((STACK-OVERWRITE) + (values (let ((target (stack-overwrite-target node))) + (and (lvalue? target) target)) + '())) + ((PARALLEL) + (values false + (append-map subproblem-free-variables + (parallel-subproblems node)))) + ((POP FG-NOOP) + (values false '())) + ((TRUE-TEST) + (finish false (true-test-rvalue node)))))) (define (values->variables lvalue rvalues) (eq-set-union @@ -246,91 +221,38 @@ parameters in registers. (lvalue/variable? lvalue) (interesting-variable? lvalue) (list lvalue))) - (list->eq-set - (map - (lambda (rvalue) - (reference-lvalue rvalue)) - (list-transform-positive - rvalues - (lambda (rvalue) - (and - rvalue - (rvalue/reference? rvalue) - (let ((ref-lvalue - (reference-lvalue rvalue))) - (and ref-lvalue - (lvalue/variable? ref-lvalue) - (interesting-variable? ref-lvalue)))))))))) + (map->eq-set (lambda (rvalue) (reference-lvalue rvalue)) + (list-transform-positive rvalues + (lambda (rvalue) + (and (rvalue/reference? rvalue) + (let ((lvalue (reference-lvalue rvalue))) + (and lvalue + (lvalue/variable? lvalue) + (interesting-variable? lvalue))))))))) -(define (combination-complex? combination) - (not - (or (and (combination/inline? combination) - (combination/inline/simple? combination)) - (let ((operator (rvalue-known-value - (application-operator - combination)))) - (and operator - (rvalue/procedure? operator) - (procedure-inline-code? operator)))))) - -(define (safe-mapcan proc list) - (let loop ((list list)) - (cond ((null? list) '()) - (else (append (proc (car list)) - (loop (cdr list))))))) - -(define empty-eq-set (list->eq-set '())) - -(define (handle-complex-parallel parallel vars-referenced-later) - (with-values - (lambda () - (discriminate-items (parallel-subproblems parallel) - subproblem-simple?)) +(define (complex-parallel-constraints subproblems vars-referenced-later) + (with-values (lambda () (discriminate-items subproblems subproblem-simple?)) (lambda (simple complex) - (order-parallel! - parallel - (simplicity-constraints - vars-referenced-later - simple - complex))))) - -(define (parallel->node parallel) - (order-parallel! parallel false)) - -(define (simplicity-constraints bad-vars simple complex) - - (define (discriminate-by-bad-vars subproblems) - (discriminate-items - subproblems - (lambda (subproblem) - (there-exists? - (subproblem-free-variables subproblem) - (lambda (var) - (memq var bad-vars)))))) + (let ((discriminate-by-bad-vars + (lambda (subproblems) + (discriminate-items subproblems + (lambda (subproblem) + (there-exists? (subproblem-free-variables subproblem) + (lambda (var) + (memq var vars-referenced-later))))))) + (constraint-graph (make-constraint-graph))) + (with-values (lambda () (discriminate-by-bad-vars simple)) + (lambda (good-simples bad-simples) + (with-values (lambda () (discriminate-by-bad-vars complex)) + (lambda (good-complex bad-complex) + (add-constraint-set! good-simples + good-complex + constraint-graph) + (add-constraint-set! good-complex + (append bad-simples bad-complex) + constraint-graph))) + constraint-graph)))))) - (let ((constraint-graph (make-constraint-graph))) - (with-values - (lambda () - (discriminate-by-bad-vars simple)) - (lambda (good-simples bad-simples) - (with-values - (lambda () - (discriminate-by-bad-vars complex)) - (lambda (good-complex bad-complex) - (add-constraint-set! good-simples - good-complex - constraint-graph) - (add-constraint-set! - good-complex - (append bad-simples bad-complex) - constraint-graph))) - constraint-graph)))) - -(define (bad-subproblem-vars subproblem-order) - (safe-mapcan subproblem-free-variables - (list-search-negative subproblem-order - subproblem-simple?))) - (define-integrable (node/bad-variables node) (cfg-node-get node node/bad-variables-tag)) @@ -341,14 +263,11 @@ parameters in registers. "bad-variables-tag") (define (bad-free-variables procedure) - (safe-mapcan - block-variables-nontransitively-free - (list-transform-negative - (cdr (linearize-block-tree - (procedure-block procedure))) - (lambda (block) - (memq (block-procedure block) - *inlined-procedures*))))) + (append-map block-variables-nontransitively-free + (list-transform-negative + (cdr (linearize-block-tree (procedure-block procedure))) + (lambda (block) + (memq (block-procedure block) *inlined-procedures*))))) ;;; Since the order of this linearization is not important we could ;;; make this routine more efficient. I'm not sure that it is worth @@ -357,14 +276,10 @@ parameters in registers. ;;; "(delq block (line..." (define (linearize-block-tree block) (let ((children - (append (block-children block) - (block-disowned-children block)))) + (append (block-children block) (block-disowned-children block)))) (if (null? children) (list block) - (cons block - (mapcan - linearize-block-tree - children))))) + (cons block (mapcan linearize-block-tree children))))) (define (interesting-variable? variable) ;;; variables that will be in cells are eliminated from diff --git a/v7/src/compiler/fgopt/reuse.scm b/v7/src/compiler/fgopt/reuse.scm index 0809756e2..c996c4245 100644 --- a/v7/src/compiler/fgopt/reuse.scm +++ b/v7/src/compiler/fgopt/reuse.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/reuse.scm,v 1.3 1989/05/21 03:57:49 jinx Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/reuse.scm,v 1.4 1989/10/26 07:37:03 cph Exp $ -Copyright (c) 1988 Massachusetts Institute of Technology +Copyright (c) 1988, 1989 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -50,7 +50,7 @@ MIT in each case. |# (rvalue/procedure? callee) (procedure/open-internal? callee))) (caller (block-procedure block))) - (and (not (combination/inline? combination)) + (and (not (combination/simple-inline? combination)) (return-operator/reduction? (combination/continuation combination)) (rvalue/procedure? caller) @@ -277,8 +277,7 @@ MIT in each case. |# (generate-assignments (cdr nodes) rest))))) (define (trivial-assignments nodes rest) - (let loop ((nodes - (order-nodes-per-current-constraints nodes))) + (let loop ((nodes nodes)) (if (null? nodes) rest (trivial-assignment (car nodes) (loop (cdr nodes)))))) @@ -325,13 +324,4 @@ MIT in each case. |# (make-stack-overwrite (subproblem-context subproblem) target (subproblem-continuation subproblem)) - rest))) - -(define (order-nodes-per-current-constraints nodes) - (if *current-constraints* - (order-per-constraints/extracted - nodes - *current-constraints* - node-value) - nodes)) - + rest))) \ No newline at end of file diff --git a/v7/src/compiler/fgopt/simple.scm b/v7/src/compiler/fgopt/simple.scm index cb8de89b2..9e5933aa2 100644 --- a/v7/src/compiler/fgopt/simple.scm +++ b/v7/src/compiler/fgopt/simple.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/simple.scm,v 4.5 1989/07/18 20:22:38 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/simple.scm,v 4.6 1989/10/26 07:37:06 cph Rel $ Copyright (c) 1987, 1989 Massachusetts Institute of Technology @@ -79,8 +79,7 @@ MIT in each case. |# ((APPLICATION) (case (application-type node) ((COMBINATION) - (if (and (combination/inline? node) - (combination/inline/simple? node)) + (if (combination/simple-inline? node) (walk/return-operator (combination/continuation node) continuation) (let ((callee (rvalue-known-value (combination/operator node)))) (and callee diff --git a/v7/src/compiler/fgopt/subfre.scm b/v7/src/compiler/fgopt/subfre.scm index fe42e8180..4f0af9e33 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.2 1989/04/03 22:03:55 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/subfre.scm,v 1.3 1989/10/26 07:37:09 cph Exp $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -141,6 +141,11 @@ MIT in each case. |# (define (walk-lvalue lvalue walk-rvalue) (let ((value (lvalue-known-value lvalue))) - (cond ((not value) (list lvalue)) - ((lvalue-integrated? lvalue) (walk-rvalue value)) - (else (eq-set-adjoin lvalue (walk-rvalue value)))))) \ No newline at end of file + (if value + (if (lvalue-integrated? lvalue) + (walk-rvalue value) + (eq-set-adjoin lvalue (walk-rvalue value))) + (if (and (variable? lvalue) + (variable-indirection lvalue)) + (walk-lvalue (variable-indirection lvalue) walk-rvalue) + (list lvalue))))) \ 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 c39077d13..c49909086 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.24 1989/08/21 19:33:33 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/compiler.pkg,v 1.25 1989/10/26 07:37:23 cph Exp $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -346,6 +346,11 @@ MIT in each case. |# (parent (compiler fg-optimizer)) (export (compiler top-level) operator-analysis)) +(define-package (compiler fg-optimizer variable-indirection) + (files "fgopt/varind") + (parent (compiler fg-optimizer)) + (export (compiler top-level) initialize-variable-indirections!)) + (define-package (compiler fg-optimizer environment-optimization) (files "fgopt/envopt") (parent (compiler fg-optimizer)) @@ -359,7 +364,9 @@ MIT in each case. |# (define-package (compiler fg-optimizer continuation-analysis) (files "fgopt/contan") (parent (compiler fg-optimizer)) - (export (compiler top-level) continuation-analysis)) + (export (compiler top-level) + continuation-analysis + setup-block-static-links!)) (define-package (compiler fg-optimizer compute-node-offsets) (files "fgopt/offset") @@ -425,6 +432,11 @@ MIT in each case. |# (parent (compiler fg-optimizer subproblem-ordering)) (export (compiler fg-optimizer subproblem-ordering) parameter-analysis)) + +(define-package (compiler fg-optimizer return-equivalencing) + (files "fgopt/reteqv") + (parent (compiler fg-optimizer)) + (export (compiler top-level) find-equivalent-returns!)) (define-package (compiler rtl-generator) (files "rtlgen/rtlgen" ;RTL generator @@ -479,7 +491,9 @@ MIT in each case. |# (files "rtlgen/rgcomb") (parent (compiler rtl-generator)) (export (compiler rtl-generator) - generate/combination)) + generate/combination) + (export (compiler rtl-generator combination/inline) + generate/invocation-prefix)) (define-package (compiler rtl-generator generate/return) (files "rtlgen/rgretn") @@ -509,6 +523,12 @@ MIT in each case. |# (files "rtlopt/rinvex") (parent (compiler rtl-optimizer)) (export (compiler top-level) invertible-expression-elimination)) + +(define-package (compiler rtl-optimizer common-suffix-merging) + (files "rtlopt/rtlcsm") + (parent (compiler rtl-optimizer)) + (export (compiler top-level) merge-common-suffixes!)) + (define-package (compiler rtl-optimizer lifetime-analysis) (files "rtlopt/rlife") (parent (compiler rtl-optimizer)) diff --git a/v7/src/compiler/machines/bobcat/dassm1.scm b/v7/src/compiler/machines/bobcat/dassm1.scm index 2aa6369ca..73ce7452e 100644 --- a/v7/src/compiler/machines/bobcat/dassm1.scm +++ b/v7/src/compiler/machines/bobcat/dassm1.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/dassm1.scm,v 4.13 1989/08/21 19:33:40 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/dassm1.scm,v 4.14 1989/10/26 07:37:28 cph Exp $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -274,13 +274,13 @@ MIT in each case. |# (if disassembler/write-addresses? (begin (write-string - (number->string (+ offset disassembler/base-address) - '(HEUR (RADIX X S)))) + (number->string (+ offset disassembler/base-address) 16)) (write-char #\Tab))) (if disassembler/write-offsets? (begin - (write-string (number->string offset '(HEUR (RADIX X S)))) (write-char #\Tab))) + (write-string (number->string offset 16)) + (write-char #\Tab))) (if symbol-table (write-string " ")) diff --git a/v7/src/compiler/machines/bobcat/dassm2.scm b/v7/src/compiler/machines/bobcat/dassm2.scm index 60c23456c..0317bc4e7 100644 --- a/v7/src/compiler/machines/bobcat/dassm2.scm +++ b/v7/src/compiler/machines/bobcat/dassm2.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/dassm2.scm,v 4.13 1989/07/25 12:40:44 arthur Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/dassm2.scm,v 4.14 1989/10/26 07:37:31 cph Exp $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -293,9 +293,8 @@ MIT in each case. |# (case (car effective-address) ((@AO) (and (or (eq? (cadr effective-address) 'REGS-POINTER) - (and (number? (cadr effective-address)) - (= (cadr effective-address) - interpreter-register-pointer))) (interpreter-register interpreter-register-pointer + (eqv? (cadr effective-address) interpreter-register-pointer)) + (interpreter-register interpreter-register-pointer (caddr effective-address)))) ((REGISTER TEMPORARY ENTRY) effective-address) (else false)))) diff --git a/v7/src/compiler/machines/bobcat/decls.scm b/v7/src/compiler/machines/bobcat/decls.scm index c5f553e49..23df8b128 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.23 1989/08/28 18:33:41 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/decls.scm,v 4.24 1989/10/26 07:37:35 cph Exp $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -347,8 +347,8 @@ MIT in each case. |# (filename/append "fgopt" "blktyp" "closan" "conect" "contan" "delint" "desenv" "envopt" "folcon" "offset" "operan" - "order" "outer" "param" "reord" "reuse" - "sideff" "simapp" "simple" "subfre") + "order" "outer" "param" "reord" "reteqv" "reuse" + "sideff" "simapp" "simple" "subfre" "varind") (filename/append "rtlbase" "regset" "rgraph" "rtlcfg" "rtlcon" "rtlexp" "rtline" "rtlobj" "rtlreg" "rtlty1" "rtlty2" @@ -359,7 +359,7 @@ MIT in each case. |# (filename/append "rtlopt" "ralloc" "rcse1" "rcse2" "rcseep" "rcseht" "rcserq" "rcsesr" "rdeath" "rdebug" "rinvex" - "rlife")) + "rlife" "rtlcsm")) compiler-syntax-table) (file-dependency/syntax/join (filename/append "machines/bobcat" @@ -500,7 +500,8 @@ MIT in each case. |# (filename/append "fgopt" "blktyp" "closan" "conect" "contan" "delint" "desenv" "envopt" "folcon" "offset" "operan" "order" "param" - "outer" "reuse" "sideff" "simapp" "simple" "subfre")) + "outer" "reuse" "reteqv" "sideff" "simapp" "simple" + "subfre" "varind")) (append bobcat-base front-end-base)) (define-integration-dependencies "fgopt" "reuse" "fgopt" "reord") @@ -514,7 +515,8 @@ MIT in each case. |# (file-dependency/integration/join (append cse-base (filename/append "rtlopt" "ralloc" "rdeath" "rdebug" "rinvex" - "rlife")) (append bobcat-base rtl-base)) + "rlife" "rtlcsm")) + (append bobcat-base rtl-base)) (file-dependency/integration/join cse-base cse-base) diff --git a/v7/src/compiler/machines/bobcat/insmac.scm b/v7/src/compiler/machines/bobcat/insmac.scm index 2f754d55c..46e7db8bf 100644 --- a/v7/src/compiler/machines/bobcat/insmac.scm +++ b/v7/src/compiler/machines/bobcat/insmac.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/insmac.scm,v 1.124 1988/06/14 08:47:02 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/insmac.scm,v 1.125 1989/10/26 07:37:39 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -91,7 +91,8 @@ MIT in each case. |# ',categories))) (define (process-ea-field field) - (if (integer? field) (integer-syntaxer field 'UNSIGNED 3) + (if (exact-integer? field) + (integer-syntaxer field 'UNSIGNED 3) (let ((binding (cadr field)) (clauses (cddr field))) (variable-width-expression-syntaxer diff --git a/v7/src/compiler/machines/bobcat/insutl.scm b/v7/src/compiler/machines/bobcat/insutl.scm index 60ce82293..4b6fddaca 100644 --- a/v7/src/compiler/machines/bobcat/insutl.scm +++ b/v7/src/compiler/machines/bobcat/insutl.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/insutl.scm,v 1.7 1989/08/28 18:33:55 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/insutl.scm,v 1.8 1989/10/26 07:37:43 cph Rel $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -146,38 +146,44 @@ MIT in each case. |# base-suppress index-suppress base-displacement-size base-displacement - memory-indirection-type + indirection-type outer-displacement-size outer-displacement) - (append-syntax! - (EXTENSION-WORD (1 index-register-type) - (3 index-register) - (1 index-size) - (2 factor SCALE-FACTOR) - (1 #b1) - (1 base-suppress) - (1 index-suppress) - (2 base-displacement-size) - (1 #b0) - (3 (case memory-indirection-type - ((#F) - #b000) - ((PRE) - outer-displacement-size) - ((POST) - (+ #b100 outer-displacement-size)) - (else - (error "bad memory indirection-type" - memory-indirection-type))))) - (append-syntax! - (output-displacement base-displacement-size base-displacement) - (output-displacement outer-displacement-size outer-displacement)))) - -(define (output-displacement size displacement) - (case size - ((1)) - ((2) (EXTENSION-WORD (16 displacement SIGNED))) - ((3) (EXTENSION-WORD (32 displacement SIGNED))))) + (let ((output-displacement + (lambda (size displacement) + (case size + ((1) false) + ((2) (EXTENSION-WORD (16 displacement SIGNED))) + ((3) (EXTENSION-WORD (32 displacement SIGNED))) + (else (error "illegal displacement-size" size)))))) + (apply + optimize-group + (let loop + ((items + (list + (EXTENSION-WORD + (1 index-register-type) + (3 index-register) + (1 index-size) + (2 factor SCALE-FACTOR) + (1 #b1) + (1 base-suppress) + (1 index-suppress) + (2 base-displacement-size) + (1 #b0) + (3 (case indirection-type + ((#F) #b000) + ((PRE) outer-displacement-size) + ((POST) (+ #b100 outer-displacement-size)) + (else (error "illegal indirection-type" indirection-type))))) + (output-displacement base-displacement-size base-displacement) + (output-displacement outer-displacement-size outer-displacement)))) + (if (null? items) + '() + (let ((rest (loop (cdr items)))) + (if (car items) + (cons-syntax (car items) rest) + rest))))))) ;;;; Common special cases diff --git a/v7/src/compiler/machines/bobcat/lapgen.scm b/v7/src/compiler/machines/bobcat/lapgen.scm index 5106e91eb..7a55de45a 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.21 1989/08/28 18:33:59 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/lapgen.scm,v 4.22 1989/10/26 07:37:46 cph Exp $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -69,24 +69,23 @@ MIT in each case. |# (pseudo-register-offset register))) (define (machine->machine-register source target) - (cond ((float-register? source) - (if (float-register? target) - (INST (FMOVE ,source ,target)) - (error "Moving from floating point register to non-fp register"))) - ((float-register? target) - (error "Moving from non-floating point register to fp register")) - (else (INST (MOV L - ,(register-reference source) - ,(register-reference target)))))) + (if (not (register-types-compatible? source target)) + (error "Moving between incompatible register types" source target)) + (if (float-register? source) + (INST (FMOVE ,(register-reference source) + ,(register-reference target))) + (INST (MOV L + ,(register-reference source) + ,(register-reference target))))) (define (machine-register->memory source target) (if (float-register? source) - (INST (FMOVE X ,(register-reference source) ,target)) + (INST (FMOVE D ,(register-reference source) ,target)) (INST (MOV L ,(register-reference source) ,target)))) (define (memory->machine-register source target) (if (float-register? target) - (INST (FMOVE X ,source ,(register-reference target))) + (INST (FMOVE D ,source ,(register-reference target))) (INST (MOV L ,source ,(register-reference target))))) (package (offset-reference byte-offset-reference) @@ -240,6 +239,9 @@ MIT in each case. |# (define-integrable (effective-address/address-register? ea) (eq? (lap:ea-keyword ea) 'A)) + +(define (effective-address/float-register? ea) + (memq ea '(FP0 FP1 FP2 FP3 FP4 FP5 FP6 FP7))) (define (standard-target-reference target) ;; Our preference for data registers here is a heuristic that works @@ -347,15 +349,111 @@ MIT in each case. |# ((rtl:stack-push? target) (INST-EA (@-A 7))) (else (error "STANDARD-TARGET->EA: Not a standard target" target)))) +;;;; Machine Targets (actually, arithmetic targets) + +(define (reuse-and-load-machine-target! type target source operate-on-target) + (reuse-machine-target! type target + (lambda (target) + (operate-on-target (move-to-alias-register! source type target))) + (lambda (target) + (LAP + ,(if (eq? type 'FLOAT) + (let ((source (standard-register-reference source type false))) + (if (effective-address/float-register? source) + (INST (FMOVE ,source ,target)) + (INST (FMOVE D ,source ,target)))) + (INST (MOV L ,(standard-register-reference source type true) + ,target))) + ,@(operate-on-target target))))) + +(define (reuse-machine-target! type + target + operate-on-pseudo-target + operate-on-machine-target) + (let ((use-temporary + (lambda (target) + (let ((temp (reference-temporary-register! type))) + (LAP ,@(operate-on-machine-target temp) + ,(if (eq? type 'FLOAT) + (INST (FMOVE ,temp ,target)) + (INST (MOV L ,temp ,target)))))))) + (case (rtl:expression-type target) + ((REGISTER) + (let ((register (rtl:register-number target))) + (if (pseudo-register? register) + (operate-on-pseudo-target register) + (let ((target (register-reference register))) + (if (eq? type (register-type register)) + (operate-on-machine-target target) + (use-temporary target)))))) + ((OFFSET) + (use-temporary (offset->indirect-reference! target))) + (else + (error "Illegal machine target" target))))) + +(define (reuse-and-operate-on-machine-target! type target operate-on-target) + (reuse-machine-target! type target + (lambda (target) + (operate-on-target (reference-target-alias! target type))) + operate-on-target)) + +(define (machine-operation-target? target) + (or (rtl:register? target) + (rtl:offset? target))) + +(define (two-arg-register-operation + operate commutative? + target-type source-reference alternate-source-reference + target source1 source2) + (let ((worst-case + (lambda (target source1 source2) + (LAP ,(if (eq? target-type 'FLOAT) + (INST (FMOVE ,source1 ,target)) + (INST (MOV L ,source1 ,target))) + ,@(operate target source2))))) + (reuse-machine-target! target-type target + (lambda (target) + (reuse-pseudo-register-alias! source1 target-type + (lambda (alias) + (let ((source2 (if (= source1 source2) + (register-reference alias) + (source-reference source2)))) + (delete-dead-registers!) + (add-pseudo-register-alias! target alias) + (operate (register-reference alias) source2))) + (lambda () + (let ((new-target-alias! + (lambda () + (let ((source1 (alternate-source-reference source1)) + (source2 (source-reference source2))) + (delete-dead-registers!) + (worst-case (reference-target-alias! target target-type) + source1 + source2))))) + (if commutative? + (reuse-pseudo-register-alias source2 target-type + (lambda (alias2) + (let ((source1 (source-reference source1))) + (delete-machine-register! alias2) + (delete-dead-registers!) + (add-pseudo-register-alias! target alias2) + (operate (register-reference alias2) source1))) + new-target-alias!) + (new-target-alias!)))))) + (lambda (target) + (worst-case target + (alternate-source-reference source1) + (source-reference source2)))))) + ;;;; Fixnum Operators (define (signed-fixnum? n) - (and (integer? n) + (and (exact-integer? n) (>= n signed-fixnum/lower-limit) (< n signed-fixnum/upper-limit))) (define (unsigned-fixnum? n) - (and (integer? n) + (and (exact-integer? n) (not (negative? n)) (< n unsigned-fixnum/upper-limit))) @@ -367,7 +465,7 @@ MIT in each case. |# (if (not (unsigned-fixnum? n)) (error "Not a unsigned fixnum" n)) n) -(define fixnum-1 +(define-integrable fixnum-1 (expt 2 scheme-type-width)) (define (load-fixnum-constant constant register-reference) @@ -398,43 +496,9 @@ MIT in each case. |# ((GREATER-THAN-FIXNUM? POSITIVE-FIXNUM?) 'GT) (else (error "FIXNUM-PREDICATE->CC: Unknown predicate" predicate)))) -(define-integrable (fixnum-2-args/commutative? operator) +(define (fixnum-2-args/commutative? operator) (memq operator '(PLUS-FIXNUM MULTIPLY-FIXNUM))) -(define (reuse-and-load-fixnum-target! target source operate-on-target) - (reuse-fixnum-target! target - (lambda (target) - (operate-on-target (move-to-alias-register! source 'DATA target))) - (lambda (target) - (LAP (MOV L ,(standard-register-reference source 'DATA) ,target) - ,@(operate-on-target target))))) - -(define (reuse-fixnum-target! target - operate-on-pseudo-target - operate-on-machine-target) - (let ((use-temporary - (lambda (target) - (let ((temp (reference-temporary-register! 'DATA))) - (LAP ,@(operate-on-machine-target temp) - (MOV L ,temp ,target)))))) - (case (rtl:expression-type target) - ((REGISTER) - (let ((register (rtl:register-number target))) - (if (pseudo-register? register) - (operate-on-pseudo-target register) - (let ((target (register-reference register))) - (if (data-register? register) - (operate-on-machine-target target) - (use-temporary target)))))) - ((OFFSET) - (use-temporary (offset->indirect-reference! target))) - (else - (error "REUSE-FIXNUM-TARGET!: Unknown fixnum target" target))))) - -(define (fixnum-operation-target? target) - (or (rtl:register? target) - (rtl:offset? target))) - (define (define-fixnum-method operator methods method) (let ((entry (assq operator (cdr methods)))) (if entry @@ -463,7 +527,7 @@ MIT in each case. |# (define-integrable (fixnum-2-args/operate-constant operator) (lookup-fixnum-method operator fixnum-methods/2-args-constant)) - + (define-fixnum-method 'ONE-PLUS-FIXNUM fixnum-methods/1-arg (lambda (reference) (LAP (ADD L (& ,fixnum-1) ,reference)))) @@ -484,15 +548,14 @@ MIT in each case. |# (define-fixnum-method 'MULTIPLY-FIXNUM fixnum-methods/2-args (lambda (target source) (if (equal? target source) - (let ((new-source (reference-temporary-register! 'DATA))) - ;;; I should add new-source as an alias for source, but I - ;;; don't have a handle on the actual register here (I just - ;;; have the register-reference). Maybe this should be - ;;; moved into the rules. - (LAP - (MOV L ,source ,new-source) - (AS R L (& ,scheme-type-width) ,target) - (MUL S L ,new-source ,target))) + (if (even? scheme-type-width) + (LAP + (AS R L (& ,(quotient scheme-type-width 2)) ,target) + (MUL S L ,source ,target)) + (LAP + (AS R L (& ,scheme-type-width) ,target) + (MUL S L ,source ,target) + (AS L L (& ,scheme-type-width) ,target))) (LAP (AS R L (& ,scheme-type-width) ,target) (MUL S L ,source ,target))))) @@ -511,7 +574,7 @@ MIT in each case. |# (AS L L ,temp ,target))) (LAP (AS L L (& ,power-of-2) ,target))) (LAP (MUL S L (& ,n) ,target)))))))) - + (define (integer-log-base-2? n) (let loop ((power 1) (exponent 0)) (cond ((< n power) false) @@ -526,15 +589,52 @@ MIT in each case. |# (lambda (target n) (cond ((zero? n) (LAP)) (else (LAP (SUB L (& ,(* n fixnum-1)) ,target)))))) + +(define-fixnum-method 'FIXNUM-QUOTIENT fixnum-methods/2-args + (lambda (target source) + (LAP + (DIV S L ,source ,target) + (AS L L (& ,scheme-type-width) ,target)))) + +(define-fixnum-method 'FIXNUM-QUOTIENT fixnum-methods/2-args-constant + (lambda (target n) + (cond ((= n 1) (LAP)) + ((= n -1) (LAP (NEG L ,target))) + (else + (let ((power-of-2 (integer-log-base-2? n))) + (if power-of-2 + (if (> power-of-2 8) + (let ((temp (reference-temporary-register! 'DATA))) + (LAP (MOV L (& ,power-of-2) ,temp) + (AS R L ,temp ,target))) + (LAP (AS R L (& ,power-of-2) ,target))) + (LAP (DIV S L (& ,n) ,target)))))))) + +(define-fixnum-method 'FIXNUM-REMAINDER fixnum-methods/2-args + (lambda (target source) + (let ((temp (reference-temporary-register! 'DATA))) + (LAP + (DIV S L ,source ,temp ,target) + (MOV L ,temp ,target))))) + +(define-fixnum-method 'FIXNUM-REMAINDER fixnum-methods/2-args-constant + (lambda (target n) + (if (or (= n 1) (= n -1)) + (LAP (CLR L ,target)) + (let ((power-of-2 (integer-log-base-2? n))) + (if power-of-2 + (if (> power-of-2 8) + (let ((temp (reference-temporary-register! 'DATA))) + (LAP (MOV L (& ,power-of-2) ,temp) + (AS R L ,temp ,target))) + (LAP (AS R L (& ,power-of-2) ,target))) + (let ((temp (reference-temporary-register! 'DATA))) + (LAP + (DIV S L (& ,(* n fixnum-1)) ,temp ,target) + (MOV L ,temp ,target)))))))) ;;;; Flonum Operators -(define (float-target-reference target) - (delete-dead-registers!) - (register-reference - (or (register-alias target 'FLOAT) - (allocate-alias-register! target 'FLOAT)))) - (define (define-flonum-method operator methods method) (let ((entry (assq operator (cdr methods)))) (if entry @@ -546,29 +646,37 @@ MIT in each case. |# (cdr (or (assq operator (cdr methods)) (error "Unknown operator" operator)))) - (define flonum-methods/1-arg (list 'FLONUM-METHODS/1-ARG)) (define-integrable (flonum-1-arg/operate operator) (lookup-flonum-method operator flonum-methods/1-arg)) -;;; Notice the weird ,', syntax here. If LAP changes, this may also have to change. +;;; Notice the weird ,', syntax here. +;;; If LAP changes, this may also have to change. (let-syntax ((define-flonum-operation (macro (primitive-name instruction-name) - `(define-flonum-method ',primitive-name flonum-methods/1-arg - (lambda (source target) - (LAP (,instruction-name ,',source ,',target))))))) - (define-flonum-operation SINE-FLONUM FSIN) - (define-flonum-operation COSINE-FLONUM FCOS) - (define-flonum-operation ARCTAN-FLONUM FATAN) - (define-flonum-operation EXP-FLONUM FETOX) - (define-flonum-operation LN-FLONUM FLOGN) - (define-flonum-operation SQRT-FLONUM FSQRT) - (define-flonum-operation TRUNCATE-FLONUM FINT)) - + `(DEFINE-FLONUM-METHOD ',primitive-name FLONUM-METHODS/1-ARG + (LAMBDA (SOURCE TARGET) + (IF (EFFECTIVE-ADDRESS/FLOAT-REGISTER? SOURCE) + (LAP (,instruction-name ,',source ,',target)) + (LAP (,instruction-name D ,',source ,',target)))))))) + (define-flonum-operation flonum-negate fneg) + (define-flonum-operation flonum-abs fabs) + (define-flonum-operation flonum-sin fsin) + (define-flonum-operation flonum-cos fcos) + (define-flonum-operation flonum-tan ftan) + (define-flonum-operation flonum-asin fasin) + (define-flonum-operation flonum-acos facos) + (define-flonum-operation flonum-atan fatan) + (define-flonum-operation flonum-exp fetox) + (define-flonum-operation flonum-log flogn) + (define-flonum-operation flonum-sqrt fsqrt) + (define-flonum-operation flonum-round fint) + (define-flonum-operation flonum-truncate fintrz)) + (define flonum-methods/2-args (list 'FLONUM-METHODS/2-ARGS)) @@ -579,12 +687,12 @@ MIT in each case. |# ((define-flonum-operation (macro (primitive-name instruction-name) `(define-flonum-method ',primitive-name flonum-methods/2-args - (lambda (source target) + (lambda (target source) (LAP (,instruction-name ,',source ,',target))))))) - (define-flonum-operation PLUS-FLONUM FADD) - (define-flonum-operation MINUS-FLONUM FSUB) - (define-flonum-operation MULTIPLY-FLONUM FMUL) - (define-flonum-operation DIVIDE-FLONUM FDIV)) + (define-flonum-operation flonum-add fadd) + (define-flonum-operation flonum-subtract fsub) + (define-flonum-operation flonum-multiply fmul) + (define-flonum-operation flonum-divide fdiv)) (define (invert-float-cc cc) (cdr (or (assq cc @@ -597,7 +705,6 @@ MIT in each case. |# (MI . PL) (PL . MI))) (error "INVERT-FLOAT-CC: Not a known CC" cc)))) - (define (set-flonum-branches! cc) (set-current-branches! (lambda (label) @@ -607,10 +714,14 @@ MIT in each case. |# (define (flonum-predicate->cc predicate) (case predicate - ((EQUAL-FLONUM? ZERO-FLONUM?) 'EQ) - ((LESS-THAN-FLONUM? NEGATIVE-FLONUM?) 'LT) - ((GREATER-THAN-FLONUM? POSITIVE-FLONUM?) 'GT) - (else (error "FLONUM-PREDICATE->CC: Unknown predicate" predicate)))) + ((FLONUM-EQUAL? FLONUM-ZERO?) 'EQ) + ((FLONUM-LESS? FLONUM-NEGATIVE?) 'LT) + ((FLONUM-GREATER? FLONUM-POSITIVE?) 'GT) + (else (error "FLONUM-PREDICATE->CC: Unknown predicate" predicate)))) + +(define (flonum-2-args/commutative? operator) + (memq operator '(FLONUM-ADD FLONUM-MULTIPLY))) + ;;;; OBJECT->DATUM rules - Mhwu ;;; Similar to fixnum rules, but no sign extension diff --git a/v7/src/compiler/machines/bobcat/make.scm-68040 b/v7/src/compiler/machines/bobcat/make.scm-68040 index cd2025672..abd6d7c35 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.55 1989/09/25 21:45:36 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 4.56 1989/10/26 07:41:21 cph Exp $ Copyright (c) 1988, 1989 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 55 '())) \ No newline at end of file +(add-system! (make-system "Liar (Motorola MC68020)" 4 56 '())) \ 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 dd6cc8b7e..44eb2d3f9 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.26 1989/09/25 21:45:23 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules1.scm,v 4.27 1989/10/26 07:37:51 cph Exp $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -42,7 +42,7 @@ MIT in each case. |# (ASSIGN (REGISTER (? target)) (REGISTER (? source))) (QUALIFIER (machine-register? target)) (LAP (MOV L - ,(standard-register-reference source false) + ,(standard-register-reference source false true) ,(register-reference target)))) (define-rule statement @@ -186,7 +186,7 @@ MIT in each case. |# (ADDRESS->FIXNUM (OBJECT->ADDRESS (REGISTER (? source))))) (QUALIFIER (pseudo-register? target)) (convert-object/register->register target source address->fixnum)) - + (define (convert-object/offset->register target address offset conversion) (let ((source (indirect-reference! address offset))) (delete-dead-registers!) @@ -212,7 +212,7 @@ MIT in each case. |# (? offset))))) (QUALIFIER (pseudo-register? target)) (convert-object/offset->register target address offset address->fixnum)) - + (define-rule statement (ASSIGN (REGISTER (? target)) (OFFSET (REGISTER (? address)) (? offset))) (QUALIFIER (pseudo-register? target)) @@ -238,7 +238,7 @@ MIT in each case. |# (QUALIFIER (and (pseudo-register? target) (pseudo-register? datum))) (let ((target (move-to-alias-register! datum 'DATA target))) (LAP (OR UL (& ,(make-non-pointer-literal type 0)) ,target)))) - + (define-rule statement (ASSIGN (REGISTER (? target)) (UNASSIGNED)) (QUALIFIER (pseudo-register? target)) @@ -314,7 +314,7 @@ MIT in each case. |# (ASSIGN (OFFSET (REGISTER (? a)) (? n)) (REGISTER (? r))) (LAP (MOV L - ,(standard-register-reference r false) + ,(standard-register-reference r false true) ,(indirect-reference! a n)))) (define-rule statement @@ -326,7 +326,7 @@ MIT in each case. |# (ASSIGN (OFFSET (REGISTER (? address)) (? offset)) (CONS-POINTER (CONSTANT (? type)) (REGISTER (? datum)))) (let ((target (indirect-reference! address offset))) - (LAP (MOV L ,(standard-register-reference datum 'DATA) ,target) + (LAP (MOV L ,(standard-register-reference datum 'DATA true) ,target) ,(memory-set-type type target)))) (define-rule statement @@ -342,8 +342,10 @@ MIT in each case. |# (define-rule statement (ASSIGN (OFFSET (REGISTER (? a0)) (? n0)) (OFFSET (REGISTER (? a1)) (? n1))) - (let ((source (indirect-reference! a1 n1))) - (LAP (MOV L ,source ,(indirect-reference! a0 n0))))) + (if (and (= a0 a1) (= n0 n1)) + (LAP) + (let ((source (indirect-reference! a1 n1))) + (LAP (MOV L ,source ,(indirect-reference! a0 n0)))))) (define-rule statement (ASSIGN (OFFSET (REGISTER (? a)) (? n)) @@ -371,12 +373,12 @@ MIT in each case. |# (define-rule statement (ASSIGN (POST-INCREMENT (REGISTER 13) 1) (REGISTER (? r))) (QUALIFIER (pseudo-word? r)) - (LAP (MOV L ,(standard-register-reference r false) (@A+ 5)))) + (LAP (MOV L ,(standard-register-reference r false true) (@A+ 5)))) (define-rule statement (ASSIGN (POST-INCREMENT (REGISTER 13) 1) (REGISTER (? r))) (QUALIFIER (pseudo-float? r)) - (LAP (FMOVE D ,(float-register-reference r) (@A+ 5)))) + (LAP (FMOVE D ,(machine-register-reference r 'FLOAT) (@A+ 5)))) (define-rule statement (ASSIGN (POST-INCREMENT (REGISTER 13) 1) (OFFSET (REGISTER (? r)) (? n))) @@ -406,12 +408,12 @@ MIT in each case. |# (define-rule statement (ASSIGN (PRE-INCREMENT (REGISTER 15) -1) (REGISTER (? r))) - (LAP (MOV L ,(standard-register-reference r false) (@-A 7)))) + (LAP (MOV L ,(standard-register-reference r false true) (@-A 7)))) (define-rule statement (ASSIGN (PRE-INCREMENT (REGISTER 15) -1) (CONS-POINTER (CONSTANT (? type)) (REGISTER (? datum)))) - (LAP (MOV L ,(standard-register-reference datum 'DATA) (@-A 7)) + (LAP (MOV L ,(standard-register-reference datum 'DATA true) (@-A 7)) ,(memory-set-type type (INST-EA (@A 7))))) (define-rule statement @@ -420,6 +422,11 @@ MIT in each case. |# (LAP (PEA (@PCR ,(rtl-procedure/external-label (label->object label)))) ,(memory-set-type type (INST-EA (@A 7))))) +(define-rule statement + (ASSIGN (PRE-INCREMENT (REGISTER 15) -1) + (OFFSET-ADDRESS (REGISTER (? r)) (? n))) + (LAP (PEA ,(indirect-reference! r n)))) + (define-rule statement (ASSIGN (PRE-INCREMENT (REGISTER 15) -1) (OFFSET (REGISTER (? r)) (? n))) (LAP (MOV L ,(indirect-reference! r n) (@-A 7)))) @@ -439,17 +446,40 @@ MIT in each case. |# (define-rule statement (ASSIGN (? target) (FIXNUM-1-ARG (? operator) (REGISTER (? source)))) - (QUALIFIER (and (fixnum-operation-target? target) (pseudo-register? source))) - (reuse-and-load-fixnum-target! target - source - (fixnum-1-arg/operate operator))) + (QUALIFIER (and (machine-operation-target? target) + (pseudo-register? source))) + (reuse-and-load-machine-target! 'DATA + target + source + (fixnum-1-arg/operate operator))) + +(define-rule statement + (ASSIGN (? target) + (FIXNUM-2-ARGS (? operator) + (REGISTER (? source1)) + (REGISTER (? source2)))) + (QUALIFIER (and (machine-operation-target? target) + (pseudo-register? source1) + (pseudo-register? source2))) + (two-arg-register-operation (fixnum-2-args/operate operator) + (fixnum-2-args/commutative? operator) + 'DATA + (standard-fixnum-source operator) + (lambda (source) + (standard-register-reference source + 'DATA + true)) + target + source1 + source2)) (define-rule statement (ASSIGN (? target) (FIXNUM-2-ARGS (? operator) (REGISTER (? source)) (OBJECT->FIXNUM (CONSTANT (? constant))))) - (QUALIFIER (and (fixnum-operation-target? target) (pseudo-register? source))) + (QUALIFIER (and (machine-operation-target? target) + (pseudo-register? source))) (fixnum-2-args/register*constant operator target source constant)) (define-rule statement @@ -457,31 +487,31 @@ MIT in each case. |# (FIXNUM-2-ARGS (? operator) (OBJECT->FIXNUM (CONSTANT (? constant))) (REGISTER (? source)))) - (QUALIFIER (and (fixnum-operation-target? target) (pseudo-register? source))) + (QUALIFIER (and (machine-operation-target? target) + (pseudo-register? source))) (if (fixnum-2-args/commutative? operator) (fixnum-2-args/register*constant operator target source constant) (fixnum-2-args/constant*register operator target constant source))) (define (fixnum-2-args/register*constant operator target source constant) - (reuse-and-load-fixnum-target! target source + (reuse-and-load-machine-target! 'DATA target source (lambda (target) ((fixnum-2-args/operate-constant operator) target constant)))) (define (fixnum-2-args/constant*register operator target constant source) - (reuse-and-operate-on-fixnum-target! target + (reuse-and-operate-on-machine-target! 'DATA target (lambda (target) (LAP ,@(load-fixnum-constant constant target) ,@((fixnum-2-args/operate operator) target - (if (eq? operator 'MULTIPLY-FIXNUM) - (standard-multiply-source source) - (standard-register-reference source 'DATA))))))) - -(define (reuse-and-operate-on-fixnum-target! target operate-on-target) - (reuse-fixnum-target! target - (lambda (target) - (operate-on-target (reference-target-alias! target 'DATA))) - operate-on-target)) + ((standard-fixnum-source operator) source)))))) + +(define (standard-fixnum-source operator) + (let ((alternate-types? + (not (memq operator + '(MULTIPLY-FIXNUM FIXNUM-DIVIDE FIXNUM-REMAINDER))))) + (lambda (source) + (standard-register-reference source 'DATA alternate-types?)))) ;;; The maximum value for a shift constant is 8, so these rules can ;;; only be used when the type width is 6 bits or less. @@ -494,7 +524,8 @@ MIT in each case. |# (FIXNUM-2-ARGS MULTIPLY-FIXNUM (OBJECT->FIXNUM (CONSTANT 4)) (OBJECT->FIXNUM (REGISTER (? source))))) - (QUALIFIER (and (fixnum-operation-target? target) (pseudo-register? source))) + (QUALIFIER (and (machine-operation-target? target) + (pseudo-register? source))) (convert-index->fixnum/register target source)) (define-rule statement @@ -502,7 +533,8 @@ MIT in each case. |# (FIXNUM-2-ARGS MULTIPLY-FIXNUM (OBJECT->FIXNUM (REGISTER (? source))) (OBJECT->FIXNUM (CONSTANT 4)))) - (QUALIFIER (and (fixnum-operation-target? target) (pseudo-register? source))) + (QUALIFIER (and (machine-operation-target? target) + (pseudo-register? source))) (convert-index->fixnum/register target source)) (define-rule statement @@ -510,7 +542,7 @@ MIT in each case. |# (FIXNUM-2-ARGS MULTIPLY-FIXNUM (OBJECT->FIXNUM (CONSTANT 4)) (OBJECT->FIXNUM (OFFSET (REGISTER (? r)) (? n))))) - (QUALIFIER (fixnum-operation-target? target)) + (QUALIFIER (machine-operation-target? target)) (convert-index->fixnum/offset target r n)) (define-rule statement @@ -518,7 +550,7 @@ MIT in each case. |# (FIXNUM-2-ARGS MULTIPLY-FIXNUM (OBJECT->FIXNUM (OFFSET (REGISTER (? r)) (? n))) (OBJECT->FIXNUM (CONSTANT 4)))) - (QUALIFIER (fixnum-operation-target? target)) + (QUALIFIER (machine-operation-target? target)) (convert-index->fixnum/offset target r n)) ;;; end (IF (<= SCHEME-TYPE-WIDTH 6) ...) @@ -528,79 +560,16 @@ MIT in each case. |# ;;; not in use. (define (convert-index->fixnum/register target source) - (reuse-and-load-fixnum-target! target source + (reuse-and-load-machine-target! 'DATA target source (lambda (target) (LAP (LS L L (& ,(+ scheme-type-width 2)) ,target))))) (define (convert-index->fixnum/offset target address offset) (let ((source (indirect-reference! address offset))) - (reuse-and-operate-on-fixnum-target! target + (reuse-and-operate-on-machine-target! 'DATA target (lambda (target) (LAP (MOV L ,source ,target) (LS L L (& ,(+ scheme-type-width 2)) ,target)))))) -(define-rule statement - (ASSIGN (? target) - (FIXNUM-2-ARGS (? operator) - (REGISTER (? source1)) - (REGISTER (? source2)))) - (QUALIFIER (and (fixnum-operation-target? target) - (pseudo-register? source1) - (pseudo-register? source2))) - (let ((worst-case - (lambda (target source1 source2) - (LAP (MOV L ,source1 ,target) - ,@((fixnum-2-args/operate operator) target source2)))) - (source-reference - (if (eq? operator 'MULTIPLY-FIXNUM) - standard-multiply-source - (lambda (source) (standard-register-reference source 'DATA))))) - (reuse-fixnum-target! target - (lambda (target) - (reuse-pseudo-register-alias! source1 'DATA - (lambda (alias) - (let ((source2 (if (= source1 source2) - (register-reference alias) - (source-reference source2)))) - (delete-dead-registers!) - (add-pseudo-register-alias! target alias) - ((fixnum-2-args/operate operator) (register-reference alias) - source2))) - (lambda () - (let ((new-target-alias! - (lambda () - (let ((source1 - (standard-register-reference source1 'DATA)) - (source2 (source-reference source2))) - (delete-dead-registers!) - (worst-case (reference-target-alias! target 'DATA) - source1 - source2))))) - (if (fixnum-2-args/commutative? operator) - (reuse-pseudo-register-alias source2 'DATA - (lambda (alias2) - (let ((source1 (source-reference source1))) - (delete-machine-register! alias2) - (delete-dead-registers!) - (add-pseudo-register-alias! target alias2) - ((fixnum-2-args/operate operator) - (register-reference alias2) - source1))) - new-target-alias!) - (new-target-alias!)))))) - (lambda (target) - (worst-case target - (standard-register-reference source1 'DATA) - (source-reference source2)))))) - -(define (standard-multiply-source register) - (let ((alias (register-alias register 'DATA))) - (cond (alias - (register-reference alias)) - ((register-saved-into-home? register) - (pseudo-register-home register)) - (else - (reference-alias-register! register 'DATA))))) - ;;;; Flonum Operations (define-rule statement @@ -614,7 +583,7 @@ MIT in each case. |# flonum-size (INST-EA (@A+ 5))) (FMOVE D - ,(float-register-reference source) + ,(machine-register-reference source 'FLOAT) (@A+ 5))))) (define-rule statement @@ -626,30 +595,39 @@ MIT in each case. |# ,(reference-target-alias! target 'FLOAT)))) (define-rule statement - (ASSIGN (REGISTER (? target)) + (ASSIGN (? target) (FLONUM-1-ARG (? operator) (REGISTER (? source)))) - (QUALIFIER (and (pseudo-float? target) (pseudo-float? source))) - (let ((source-reference (float-register-reference source))) - (let ((target-reference (float-target-reference target))) - (LAP ,@((flonum-1-arg/operate operator) - source-reference - target-reference))))) + (QUALIFIER (and (machine-operation-target? target) + (pseudo-float? source))) + (let ((operate-on-target + (lambda (target) + ((flonum-1-arg/operate operator) + (standard-register-reference source 'FLOAT false) + target)))) + (reuse-machine-target! 'FLOAT target + (lambda (target) + (operate-on-target (reference-target-alias! target 'FLOAT))) + operate-on-target))) (define-rule statement - (ASSIGN (REGISTER (? target)) + (ASSIGN (? target) (FLONUM-2-ARGS (? operator) (REGISTER (? source1)) (REGISTER (? source2)))) - (QUALIFIER (and (pseudo-float? target) + (QUALIFIER (and (machine-operation-target? target) (pseudo-float? source1) (pseudo-float? source2))) - (let ((source1-reference (float-register-reference source1)) - (source2-reference (float-register-reference source2))) - (let ((target-reference (float-target-reference target))) - (LAP (FMOVE ,source1-reference ,target-reference) - ,@((flonum-2-args/operate operator) - source2-reference - target-reference))))) + (let ((source-reference + (lambda (source) (standard-register-reference source 'FLOAT false)))) + (two-arg-register-operation (flonum-2-args/operate operator) + (flonum-2-args/commutative? operator) + 'FLOAT + source-reference + source-reference + target + source1 + source2))) + ;;;; CHAR->ASCII/BYTE-OFFSET (define (load-char-into-register type source target) diff --git a/v7/src/compiler/machines/bobcat/rules2.scm b/v7/src/compiler/machines/bobcat/rules2.scm index 854e80a91..cac365733 100644 --- a/v7/src/compiler/machines/bobcat/rules2.scm +++ b/v7/src/compiler/machines/bobcat/rules2.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules2.scm,v 4.9 1989/08/28 18:34:18 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules2.scm,v 4.10 1989/10/26 07:37:56 cph Exp $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -56,12 +56,12 @@ MIT in each case. |# (let ((finish-1 (lambda (alias) (finish (register-reference alias) - (standard-register-reference register-2 'DATA) + (standard-register-reference register-2 'DATA true) cc))) (finish-2 (lambda (alias) (finish (register-reference alias) - (standard-register-reference register-1 'DATA) + (standard-register-reference register-1 'DATA true) (invert-cc-noncommutative cc))))) (let ((try-type (lambda (type continue) @@ -81,7 +81,7 @@ MIT in each case. |# (finish-1 (load-alias-register! register-1 'DATA))))))))))) (define (compare/register*memory register memory cc) - (let ((reference (standard-register-reference register 'DATA))) + (let ((reference (standard-register-reference register 'DATA true))) (if (effective-address/register? reference) (begin (set-standard-branches! cc) @@ -99,7 +99,7 @@ MIT in each case. |# (set-standard-branches! 'NE) (LAP ,(test-non-pointer (ucode-type false) 0 - (standard-register-reference register false)))) + (standard-register-reference register false true)))) (define-rule predicate (TRUE-TEST (? memory)) @@ -139,7 +139,7 @@ MIT in each case. |# (set-standard-branches! 'EQ) (LAP ,(test-non-pointer (ucode-type unassigned) 0 - (standard-register-reference register 'DATA)))) + (standard-register-reference register 'DATA true)))) (define-rule predicate (UNASSIGNED-TEST (? memory)) @@ -190,7 +190,7 @@ MIT in each case. |# (set-standard-branches! 'EQ) (LAP ,(test-non-pointer-constant constant - (standard-register-reference register 'DATA)))) + (standard-register-reference register 'DATA true)))) (compare/register*memory register (INST-EA (@PCR ,(constant->label constant))) 'EQ))) @@ -226,13 +226,13 @@ MIT in each case. |# (eq-test/constant*memory constant (predicate/memory-operand-reference memory))) -;;;; Fixnum Predicates +;;;; Fixnum/Flonum Predicates (define-rule predicate (FIXNUM-PRED-1-ARG (? predicate) (REGISTER (? register))) (QUALIFIER (pseudo-register? register)) (set-standard-branches! (fixnum-predicate->cc predicate)) - (test-fixnum (standard-register-reference register 'DATA))) + (test-fixnum (standard-register-reference register 'DATA true))) (define-rule predicate (FIXNUM-PRED-1-ARG (? predicate) (? memory)) @@ -278,7 +278,7 @@ MIT in each case. |# (define (fixnum-predicate/register*constant register constant cc) (set-standard-branches! cc) (guarantee-signed-fixnum constant) - (let ((reference (standard-register-reference register 'DATA))) + (let ((reference (standard-register-reference register 'DATA true))) (if (effective-address/register? reference) (LAP (CMP L (& ,(* constant fixnum-1)) ,reference)) (LAP (CMPI L (& ,(* constant fixnum-1)) ,reference))))) @@ -325,14 +325,12 @@ MIT in each case. |# (predicate/memory-operand-reference memory) constant (invert-cc-noncommutative (fixnum-predicate->cc predicate)))) - -;;;; Flonum Predicates (define-rule predicate (FLONUM-PRED-1-ARG (? predicate) (REGISTER (? register))) (QUALIFIER (pseudo-float? register)) (set-flonum-branches! (flonum-predicate->cc predicate)) - (LAP (FTST ,(float-register-reference register)))) + (LAP (FTST ,(standard-register-reference register 'FLOAT false)))) (define-rule predicate (FLONUM-PRED-2-ARGS (? predicate) @@ -340,5 +338,5 @@ MIT in each case. |# (REGISTER (? register2))) (QUALIFIER (and (pseudo-float? register1) (pseudo-float? register2))) (set-flonum-branches! (flonum-predicate->cc predicate)) - (LAP (FCMP ,(float-register-reference register2) - ,(float-register-reference register1)))) \ No newline at end of file + (LAP (FCMP ,(standard-register-reference register2 'FLOAT false) + ,(standard-register-reference register1 'FLOAT false)))) \ No newline at end of file diff --git a/v7/src/compiler/machines/bobcat/rules3.scm b/v7/src/compiler/machines/bobcat/rules3.scm index 1974b4b8a..7276fd103 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.17 1989/08/28 18:34:21 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules3.scm,v 4.18 1989/10/26 07:38:00 cph Exp $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -458,16 +458,24 @@ MIT in each case. |# environment-offset free-ref-offset n-sections) - (LAP (MOV L (@PCR ,code-block-label) (D 0)) - (AND L ,mask-reference (D 0)) - (MOV L (D 0) (A 0)) - (LEA (@AO 0 ,environment-offset) (A 1)) - (MOV L ,reg:environment (@A 1)) - (LEA (@AO 0 ,free-ref-offset) (A 1)) - ,(load-dnw n-sections 0) - (JSR ,entry:compiler-link) - ,@(make-external-label (continuation-code-word false) - (generate-label)))) + (let ((load-offset + (lambda (offset) + (if (<= -32768 offset 32767) + (INST (LEA (@AO 0 ,offset) (A 1))) + (INST (LEA (@AOF 0 E (,offset L) #F + ((D 0) L 1) Z + (0 N)) + (A 1))))))) + (LAP (MOV L (@PCR ,code-block-label) (D 0)) + (AND L ,mask-reference (D 0)) + (MOV L (D 0) (A 0)) + ,(load-offset environment-offset) + (MOV L ,reg:environment (@A 1)) + ,(load-offset free-ref-offset) + ,(load-dnw n-sections 0) + (JSR ,entry:compiler-link) + ,@(make-external-label (continuation-code-word false) + (generate-label))))) (define (generate/constants-block constants references assignments uuo-links) (let ((constant-info diff --git a/v7/src/compiler/machines/bobcat/rules4.scm b/v7/src/compiler/machines/bobcat/rules4.scm index 604e39db5..4b06957cb 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.6 1989/08/28 18:34:25 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules4.scm,v 4.7 1989/10/26 07:38:05 cph Exp $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -99,7 +99,7 @@ MIT in each case. |# (define (assignment-call:cons-pointer entry environment name type datum) (let ((set-environment (expression->machine-register! environment a0))) - (let ((datum (standard-register-reference datum false))) + (let ((datum (standard-register-reference datum false true))) (let ((clear-map (clear-map!))) (LAP ,@set-environment (MOV L ,datum ,reg:temp) @@ -159,7 +159,8 @@ MIT in each case. |# (CONS-POINTER (CONSTANT (? type)) (REGISTER (? datum)))) (let ((set-extension (expression->machine-register! extension a0))) - (let ((datum (standard-register-reference datum false))) (let ((clear-map (clear-map!))) + (let ((datum (standard-register-reference datum false true))) + (let ((clear-map (clear-map!))) (LAP ,@set-extension (MOV L ,datum ,reg:temp) ,(memory-set-type type reg:temp) diff --git a/v7/src/compiler/rtlbase/rgraph.scm b/v7/src/compiler/rtlbase/rgraph.scm index 14fe2f2db..6c27c4267 100644 --- a/v7/src/compiler/rtlbase/rgraph.scm +++ b/v7/src/compiler/rtlbase/rgraph.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rgraph.scm,v 4.5 1989/07/25 12:37:46 arthur Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rgraph.scm,v 4.6 1989/10/26 07:38:21 cph Exp $ Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology @@ -48,8 +48,14 @@ MIT in each case. |# register-n-deaths register-live-length register-crosses-call? - register-value-classes - ) + register-value-classes) + +(define (add-rgraph-bblock! rgraph bblock) + (set-rgraph-bblocks! rgraph (cons bblock (rgraph-bblocks rgraph)))) + +(define (delete-rgraph-bblock! rgraph bblock) + (set-rgraph-bblocks! rgraph (delq! bblock (rgraph-bblocks rgraph)))) + (define (add-rgraph-non-object-register! rgraph register) (set-rgraph-non-object-registers! rgraph diff --git a/v7/src/compiler/rtlbase/rtlcfg.scm b/v7/src/compiler/rtlbase/rtlcfg.scm index af08776a8..476ef810f 100644 --- a/v7/src/compiler/rtlbase/rtlcfg.scm +++ b/v7/src/compiler/rtlbase/rtlcfg.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlcfg.scm,v 4.7 1989/04/15 18:06:41 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlcfg.scm,v 4.8 1989/10/26 07:38:24 cph Rel $ Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology @@ -60,14 +60,6 @@ MIT in each case. |# (define (make-pblock instructions) (make-pnode pblock-tag instructions false false false false '() false false)) -(define-vector-slots rinst 0 - rtl - dead-registers - next) - -(define (make-rtl-instruction rtl) - (vector rtl '() false)) - (define-integrable (statement->srtl statement) (snode->scfg (make-sblock (make-rtl-instruction statement)))) @@ -99,38 +91,39 @@ MIT in each case. |# consequent-lap-generator alternative-lap-generator))))) -(define-integrable (rinst-dead-register? rinst register) - (memq register (rinst-dead-registers rinst))) - -(define (rinst-last rinst) - (if (rinst-next rinst) - (rinst-last (rinst-next rinst)) - rinst)) - -(define (bblock-compress! bblock) - (if (not (node-marked? bblock)) - (begin - (node-mark! bblock) - (if (sblock? bblock) - (let ((next (snode-next bblock))) - (if next - (begin - (if (null? (cdr (node-previous-edges next))) - (begin - (set-rinst-next! - (rinst-last (bblock-instructions bblock)) - (bblock-instructions next)) - (set-bblock-instructions! - next - (bblock-instructions bblock)) - (snode-delete! bblock))) - (bblock-compress! next)))) - (begin (let ((consequent (pnode-consequent bblock))) - (if consequent - (bblock-compress! consequent))) - (let ((alternative (pnode-alternative bblock))) - (if alternative - (bblock-compress! alternative)))))))) +(define-integrable (bblock-reversed-instructions bblock) + (rinst-reversed (bblock-instructions bblock))) + +(define (bblock-compress! bblock limit-predicate) + (let ((walk-next? + (if limit-predicate + (lambda (next) (and next (not (limit-predicate next)))) + (lambda (next) next)))) + (let walk-bblock ((bblock bblock)) + (if (not (node-marked? bblock)) + (begin + (node-mark! bblock) + (if (sblock? bblock) + (let ((next (snode-next bblock))) + (if (walk-next? next) + (begin + (if (null? (cdr (node-previous-edges next))) + (begin + (set-rinst-next! + (rinst-last (bblock-instructions bblock)) + (bblock-instructions next)) + (set-bblock-instructions! + next + (bblock-instructions bblock)) + (snode-delete! bblock))) + (walk-bblock next)))) + (begin + (let ((consequent (pnode-consequent bblock))) + (if (walk-next? consequent) + (walk-bblock consequent))) + (let ((alternative (pnode-alternative bblock))) + (if (walk-next? alternative) + (walk-bblock alternative)))))))))) (define (bblock-walk-forward bblock procedure) (let loop ((rinst (bblock-instructions bblock))) @@ -186,4 +179,40 @@ MIT in each case. |# (cfg-node-get pnode cfg/prefer-branch/tag)) (define cfg/prefer-branch/tag - (intern "#[(compiler)cfg/prefer-branch]")) \ No newline at end of file + (intern "#[(compiler)cfg/prefer-branch]")) + +;;;; RTL Instructions + +(define-vector-slots rinst 0 + rtl + dead-registers + next) + +(define (make-rtl-instruction rtl) + (vector rtl '() false)) + +(define-integrable (rinst-dead-register? rinst register) + (memq register (rinst-dead-registers rinst))) + +(define (rinst-last rinst) + (if (rinst-next rinst) + (rinst-last (rinst-next rinst)) + rinst)) + +(define (rinst-disconnect-previous! bblock rinst) + (let loop ((rinst* (bblock-instructions bblock))) + (if (eq? rinst (rinst-next rinst*)) + (set-rinst-next! rinst* false) + (loop (rinst-next rinst*))))) + +(define (rinst-length rinst) + (let loop ((rinst rinst) (length 0)) + (if rinst + (loop (rinst-next rinst) (1+ length)) + length))) + +(define (rinst-reversed rinst) + (let loop ((rinst rinst) (result '())) + (if rinst + (loop (rinst-next rinst) (cons rinst result)) + result))) \ No newline at end of file diff --git a/v7/src/compiler/rtlbase/rtlcon.scm b/v7/src/compiler/rtlbase/rtlcon.scm index e263b5ff3..afc3b02ac 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.17 1989/07/25 12:37:32 arthur Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlcon.scm,v 4.18 1989/10/26 07:38:28 cph Exp $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -72,11 +72,15 @@ MIT in each case. |# ((or (rtl:machine-register-expression? locative) (rtl:trivial-expression? expression)) (%make-assign locative expression)) + ((and (or (rtl:register? locative) + (rtl:offset? expression)) + (equal? locative expression)) + (make-null-cfg)) (else (let ((register (rtl:make-pseudo-register))) (scfg*scfg->scfg! (assign-register register) (%make-assign locative register))))))) - + (define (rtl:make-eq-test expression-1 expression-2) (expression-simplify-for-predicate expression-1 (lambda (expression-1) @@ -340,10 +344,12 @@ MIT in each case. |# (if (rtl:trivial-expression? expression) (receiver expression) (assign-to-temporary expression scfg-append! receiver))))) - (let ((entry (assq (car expression) expression-methods))) - (if entry - (apply (cdr entry) receiver scfg-append! (cdr expression)) - (receiver expression))))) + (if (rtl:trivial-expression? expression) + (receiver expression) + (let ((entry (assq (car expression) expression-methods))) + (if entry + (apply (cdr entry) receiver scfg-append! (cdr expression)) + (receiver expression)))))) (define (assign-to-temporary expression scfg-append! receiver) (let ((pseudo (rtl:make-pseudo-register))) @@ -554,7 +560,7 @@ MIT in each case. |# (expression-simplify operand scfg-append! (lambda (operand) (receiver (rtl:make-fixnum-1-arg operator operand)))))) - + (define-expression-method 'GENERIC-BINARY (lambda (receiver scfg-append! operator operand1 operand2) (expression-simplify operand1 scfg-append! @@ -569,7 +575,8 @@ MIT in each case. |# (expression-simplify operand scfg-append! (lambda (operand) (receiver (rtl:make-generic-unary operator operand)))))) - (define-expression-method 'FLONUM-1-ARG + +(define-expression-method 'FLONUM-1-ARG (lambda (receiver scfg-append! operator operand) (expression-simplify operand scfg-append! (lambda (s-operand) diff --git a/v7/src/compiler/rtlbase/rtlexp.scm b/v7/src/compiler/rtlbase/rtlexp.scm index 8d4f27764..05b98e9d4 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.12 1989/07/25 12:37:17 arthur Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlexp.scm,v 4.13 1989/10/26 07:38:32 cph Exp $ Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology @@ -54,16 +54,28 @@ MIT in each case. |# '(INVOCATION-PREFIX:DYNAMIC-LINK INVOCATION-PREFIX:MOVE-FRAME-UP))) -(define-integrable (rtl:trivial-expression? expression) - (memq (rtl:expression-type expression) - '(ASSIGNMENT-CACHE - CONS-CLOSURE - CONSTANT - ENTRY:CONTINUATION - ENTRY:PROCEDURE - REGISTER - UNASSIGNED - VARIABLE-CACHE))) +(define (rtl:trivial-expression? expression) + (case (rtl:expression-type expression) + ((ASSIGNMENT-CACHE + CONS-CLOSURE + CONSTANT + ENTRY:CONTINUATION + ENTRY:PROCEDURE + REGISTER + UNASSIGNED + VARIABLE-CACHE) + true) + ((OBJECT->FIXNUM OBJECT->UNSIGNED-FIXNUM) + (rtl:constant? (rtl:object->fixnum-expression expression))) + ((OBJECT->DATUM) + (let ((subexpression (rtl:object->datum-expression expression))) + (and (rtl:constant? subexpression) + (non-pointer-object? (rtl:constant-value subexpression))))) + ((OBJECT->TYPE) + (rtl:constant? (rtl:object->type-expression expression))) + (else + false))) + (define (rtl:non-object-valued-expression? expression) (if (rtl:register? expression) (register-contains-non-object? (rtl:register-number expression)) diff --git a/v7/src/compiler/rtlbase/rtline.scm b/v7/src/compiler/rtlbase/rtline.scm index 417fe3981..affb1a8af 100644 --- a/v7/src/compiler/rtlbase/rtline.scm +++ b/v7/src/compiler/rtlbase/rtline.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtline.scm,v 4.9 1989/08/21 19:34:24 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtline.scm,v 4.10 1989/10/26 07:38:35 cph Rel $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -124,16 +124,13 @@ MIT in each case. |# (node-mark! bblock) (queue-continuations! bblock) (if (and (not (bblock-label bblock)) - (let ((edges (node-previous-edges bblock))) - (and (not (null? edges)) - (not (null? (cdr edges)))))) + (node-previous>1? bblock)) (bblock-label! bblock)) (let ((kernel (lambda () (let loop ((rinst (bblock-instructions bblock))) (cond ((rinst-next rinst) - (cons (rinst-rtl rinst) - (loop (rinst-next rinst)))) + (cons (rinst-rtl rinst) (loop (rinst-next rinst)))) ((sblock? bblock) (cons (rinst-rtl rinst) (let ((next (snode-next bblock))) @@ -182,17 +179,14 @@ MIT in each case. |# (alternative (linearize-bblock an))) `(,(rtl:make-jumpc-statement predicate clabel) ,@alternative - ,@(if (node-marked? cn) - '() - (linearize-bblock cn)))))))))) + ,@(if (node-marked? cn) '() (linearize-bblock cn)))))))))) (linearize-bblock bblock)) (define linearize-rtl (make-linearizer bblock-linearize-rtl - (lambda () - (let ((value (list false))) - (cons value value))) (lambda (accumulator instructions) + (lambda () (let ((value (list false))) (cons value value))) + (lambda (accumulator instructions) (set-cdr! (cdr accumulator) instructions) (set-cdr! accumulator (last-pair instructions)) accumulator) diff --git a/v7/src/compiler/rtlbase/rtlty2.scm b/v7/src/compiler/rtlbase/rtlty2.scm index 2c11bc357..e09d13099 100644 --- a/v7/src/compiler/rtlbase/rtlty2.scm +++ b/v7/src/compiler/rtlbase/rtlty2.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlty2.scm,v 4.6 1988/11/08 08:24:57 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlty2.scm,v 4.7 1989/10/26 07:38:39 cph Exp $ -Copyright (c) 1988 Massachusetts Institute of Technology +Copyright (c) 1988, 1989 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -36,18 +36,21 @@ MIT in each case. |# (declare (usual-integrations)) -(define-integrable rtl:expression-type first) -(define-integrable rtl:address-register second) -(define-integrable rtl:address-number third) -(define-integrable rtl:invocation-pushed second) -(define-integrable rtl:invocation-continuation third) -(define-integrable rtl:test-expression second) +(define-integrable rtl:expression-type car) +(define-integrable rtl:address-register cadr) +(define-integrable rtl:address-number caddr) +(define-integrable rtl:test-expression cadr) +(define-integrable rtl:invocation-pushed cadr) +(define-integrable rtl:invocation-continuation caddr) + +(define-integrable (rtl:set-invocation-continuation! rtl continuation) + (set-car! (cddr rtl) continuation)) (define (rtl:make-constant value) (if (unassigned-reference-trap? value) (rtl:make-unassigned) (%make-constant value))) - + ;;;; Locatives ;;; Locatives are used as an intermediate form by the code generator @@ -85,7 +88,6 @@ MIT in each case. |# (define-integrable (rtl:interpreter-call-result:unbound?) (rtl:make-fetch 'INTERPRETER-CALL-RESULT:UNBOUND?)) - ;;; "Pre-simplification" locative offsets @@ -131,4 +133,53 @@ MIT in each case. |# (quotient scheme-object-width 8)))) BYTE)) (else `(OFFSET ,locative ,byte-offset BYTE)))) + +;;; Expressions that are used in the intermediate form. + +(define-integrable (rtl:make-address locative) + `(ADDRESS ,locative)) + +(define-integrable (rtl:make-environment locative) + `(ENVIRONMENT ,locative)) + +(define-integrable (rtl:make-cell-cons expression) + `(CELL-CONS ,expression)) + +(define-integrable (rtl:make-fetch locative) + `(FETCH ,locative)) + +(define-integrable (rtl:make-typed-cons:pair type car cdr) + `(TYPED-CONS:PAIR ,type ,car ,cdr)) + +(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)) + +;;; Linearizer Support + +(define-integrable (rtl:make-jump-statement label) + `(JUMP ,label)) + +(define-integrable (rtl:make-jumpc-statement predicate label) + `(JUMPC ,predicate ,label)) + +(define-integrable (rtl:make-label-statement label) + `(LABEL ,label)) + +(define-integrable (rtl:negate-predicate expression) + `(NOT ,expression)) + +;;; Stack + +(define-integrable (stack-locative-offset locative offset) + (rtl:locative-offset locative (stack->memory-offset offset))) + +(define-integrable (stack-push-address) + (rtl:make-pre-increment (interpreter-stack-pointer) + (stack->memory-offset -1))) +(define-integrable (stack-pop-address) + (rtl:make-post-increment (interpreter-stack-pointer) + (stack->memory-offset 1))) \ No newline at end of file diff --git a/v7/src/compiler/rtlgen/fndvar.scm b/v7/src/compiler/rtlgen/fndvar.scm index 0fcea9888..135b81d83 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.2 1989/04/21 17:10:02 markf Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/fndvar.scm,v 1.3 1989/10/26 07:38:52 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -44,12 +44,12 @@ MIT in each case. |# (continuation/register continuation) register:value))) (find-variable-internal context variable - (lambda (locative) + (lambda (variable locative) (if-compiler (if (variable-in-cell? variable) (rtl:make-fetch locative) locative))) - (lambda (block locative) + (lambda (variable block locative) (cond ((variable-in-known-location? context variable) (if-compiler (rtl:locative-offset locative @@ -69,8 +69,10 @@ MIT in each case. |# (define (find-closure-variable context variable) (find-variable-internal context variable - identity-procedure - (lambda (block locative) + (lambda (variable locative) + variable + locative) + (lambda (variable block locative) block locative (error "Closure variable in IC frame" variable)))) @@ -86,20 +88,30 @@ MIT in each case. |# (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 ((register (variable/register variable))) - (if register - (if-compiler (register-locative register)) - (find-block/variable context variable - (lambda (offset-locative) - (lambda (block locative) - (if-compiler - (offset-locative locative (variable-offset block variable))))) - if-ic)))))) + (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-block/variable context variable + (lambda (offset-locative) + (lambda (block locative) + (if-compiler + variable + (offset-locative + locative + (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) diff --git a/v7/src/compiler/rtlgen/opncod.scm b/v7/src/compiler/rtlgen/opncod.scm index 46e28f250..00067f4cb 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.31 1989/09/05 22:34:52 arthur Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/opncod.scm,v 4.32 1989/10/26 07:38:56 cph Exp $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -77,47 +77,58 @@ MIT in each case. |# (define (try-handler combination primitive entry) (let ((operands (combination/operands combination))) (and (primitive-arity-correct? primitive (length operands)) - (let ((result ((vector-ref entry 0) operands))) - (and result - (transmit-values result - (lambda (generator indices) - (make-inliner entry generator indices)))))))) + (with-values (lambda () ((vector-ref entry 0) operands)) + (lambda (generator indices internal-close-coding?) + (and generator + (make-inliner entry + generator + indices + internal-close-coding?))))))) ;;;; Code Generator (define (combination/inline combination) - (let ((context (combination/context combination)) - (inliner (combination/inliner combination))) - (generate/return* context - (combination/continuation combination) - (combination/continuation-push combination) - (let ((handler (inliner/handler inliner)) - (generator (inliner/generator inliner)) - (expressions - (map subproblem->expression - (inliner/operands inliner)))) - (make-return-operand - (lambda () - ((vector-ref handler 1) generator - context - expressions)) - (lambda (finish) - ((vector-ref handler 2) generator - context - expressions - finish)) - (lambda (finish) - ((vector-ref handler 3) generator - context - expressions - finish)) - false))))) - -(define (combination/inline/simple? combination) - (not (memq (primitive-procedure-name - (constant-value - (rvalue-known-value (combination/operator combination)))) - non-simple-primitive-names))) + (let ((inliner (combination/inliner combination))) + (let ((finish + (lambda (context operand->expression) + (generate/return* + context + (combination/continuation combination) + (combination/continuation-push combination) + (let ((handler (inliner/handler inliner)) + (generator (inliner/generator inliner)) + (expressions + (map operand->expression (inliner/operands inliner)))) + (make-return-operand (lambda () + ((vector-ref handler 1) generator + combination + expressions)) + (lambda (finish) + ((vector-ref handler 2) generator + combination + expressions + finish)) + (lambda (finish) + ((vector-ref handler 3) generator + combination + expressions + finish)) + false)))))) + (if (and (inliner/internal-close-coding? inliner) + (combination/reduction? combination)) + (let ((prefix (generate/invocation-prefix combination)) + (invocation + (finish + ;; This value of context is a special kludge. See + ;; `generate/return*' for the details. + (length (inliner/operands inliner)) + index->stack-reference))) + (if prefix + (scfg*scfg->scfg! + (prefix (combination/frame-size combination) 0) + invocation) + invocation)) + (finish (combination/context combination) subproblem->expression))))) (define (subproblem->expression subproblem) (let ((rvalue (subproblem-rvalue subproblem))) @@ -138,34 +149,51 @@ MIT in each case. |# (rtl:make-fetch (continuation*/register (subproblem-continuation subproblem)))))))) + +(define (index->stack-reference index) + (rtl:make-fetch + (stack-locative-offset (rtl:make-fetch register:stack-pointer) index))) + +(define-integrable (combination/reduction? combination) + (return-operator/reduction? (combination/continuation combination))) -(define (invoke/effect->effect generator context expressions) - (generator context expressions false)) - -(define (invoke/predicate->value generator context expressions finish) - (generator context expressions - (lambda (pcfg) - (let ((temporary (rtl:make-pseudo-register))) - ;; Force assignments to be made first. - (let ((consequent - (rtl:make-assignment temporary (rtl:make-constant true))) - (alternative - (rtl:make-assignment temporary (rtl:make-constant false)))) - (scfg*scfg->scfg! - (pcfg*scfg->scfg! pcfg consequent alternative) - (finish (rtl:make-fetch temporary)))))))) - -(define (invoke/value->effect generator context expressions) - generator context expressions +(define (invoke/effect->effect generator combination expressions) + (generator combination expressions false)) + +(define (invoke/effect->predicate generator combination expressions finish) + (generator combination expressions + (lambda (expression) + (finish (rtl:make-true-test expression))))) + +(define (invoke/effect->value generator combination expressions finish) + (generator combination expressions finish)) + +(define (invoke/predicate->effect generator combination expressions) + generator combination expressions + (make-null-cfg)) + +(define (invoke/predicate->predicate generator combination expressions finish) + (generator combination expressions finish)) + +(define (invoke/predicate->value generator combination expressions finish) + (generator combination expressions (finish/predicate->value finish))) + +(define ((finish/predicate->value finish) pcfg) + (pcfg*scfg->scfg! pcfg + (finish (rtl:make-constant true)) + (finish (rtl:make-constant false)))) + +(define (invoke/value->effect generator combination expressions) + generator combination expressions (make-null-cfg)) -(define (invoke/value->predicate generator context expressions finish) - (generator context expressions +(define (invoke/value->predicate generator combination expressions finish) + (generator combination expressions (lambda (expression) (finish (rtl:make-true-test expression))))) -(define (invoke/value->value generator context expressions finish) - (generator context expressions finish)) +(define (invoke/value->value generator combination expressions finish) + (generator combination expressions finish)) ;;;; Definers @@ -191,55 +219,56 @@ MIT in each case. |# (define define-open-coder/effect (open-coder-definer invoke/effect->effect - invoke/value->predicate - invoke/value->value)) + invoke/effect->predicate + invoke/effect->value)) (define define-open-coder/predicate - (open-coder-definer invoke/value->effect - invoke/value->value + (open-coder-definer invoke/predicate->effect + invoke/predicate->predicate invoke/predicate->value)) +(define define-open-coder/generic-predicate + (open-coder-definer + invoke/predicate->effect + (lambda (generator combination expressions finish) + (generator combination expressions true finish)) + (lambda (generator combination expressions finish) + (generator combination expressions false finish)))) + (define define-open-coder/value (open-coder-definer invoke/value->effect invoke/value->predicate invoke/value->value)) - -(define (define-non-simple-primitive! name) - (if (not (memq name non-simple-primitive-names)) - (set! non-simple-primitive-names (cons name non-simple-primitive-names))) - unspecific) - -(define non-simple-primitive-names - '()) ;;;; Operand Filters -(define (simple-open-coder generator operand-indices) +(define (simple-open-coder generator operand-indices internal-close-coding?) (lambda (operands) operands - (return-2 generator operand-indices))) + (values generator operand-indices internal-close-coding?))) (define (constant-filter predicate) - (lambda (generator constant-index operand-indices) + (lambda (generator constant-index operand-indices internal-close-coding?) (lambda (operands) (let ((operand (rvalue-known-value (list-ref operands constant-index)))) - (and operand - (rvalue/constant? operand) - (let ((value (constant-value operand))) - (and (predicate value) - (return-2 (generator value) operand-indices)))))))) + (if (and operand + (rvalue/constant? operand) + (predicate (constant-value operand))) + (values (generator (constant-value operand)) + operand-indices + internal-close-coding?) + (values false false false)))))) (define filter/nonnegative-integer - (constant-filter - (lambda (value) (and (integer? value) (not (negative? value)))))) + (constant-filter exact-nonnegative-integer?)) (define filter/positive-integer (constant-filter - (lambda (value) (and (integer? value) (positive? value))))) + (lambda (value) (and (exact-integer? value) (positive? value))))) ;;;; Constraint Checkers -(define (open-code:with-checks context checks non-error-cfg error-finish +(define (open-code:with-checks combination checks non-error-cfg error-finish primitive-name expressions) (let ((checks (list-transform-negative checks cfg-null?))) (if (null? checks) @@ -248,14 +277,24 @@ MIT in each case. |# ;; it creates some unreachable code which we can't easily ;; remove from the output afterwards. (let ((error-cfg - (with-values (lambda () (generate-continuation-entry context)) - (lambda (label setup cleanup) - (scfg-append! - (generate-primitive primitive-name expressions setup label) - cleanup - (if error-finish - (error-finish (rtl:make-fetch register:value)) - (make-null-cfg))))))) + (if (combination/reduction? combination) + (let ((scfg + (generate-primitive primitive-name '() false false))) + (make-scfg (cfg-entry-node scfg) '())) + (with-values + (lambda () + (generate-continuation-entry + (combination/context combination))) + (lambda (label setup cleanup) + (scfg-append! + (generate-primitive primitive-name + expressions + setup + label) + cleanup + (if error-finish + (error-finish (rtl:make-fetch register:value)) + (make-null-cfg)))))))) (let loop ((checks checks)) (if (null? checks) non-error-cfg @@ -265,14 +304,16 @@ MIT in each case. |# (define (generate-primitive name argument-expressions continuation-setup continuation-label) (scfg*scfg->scfg! - (let loop ((args argument-expressions)) - (if (null? args) - (scfg*scfg->scfg! continuation-setup - (rtl:make-push-return continuation-label)) - (load-temporary-register scfg*scfg->scfg! (car args) - (lambda (temporary) - (scfg*scfg->scfg! (loop (cdr args)) - (rtl:make-push temporary)))))) + (if continuation-label + (let loop ((args argument-expressions)) + (if (null? args) + (scfg*scfg->scfg! continuation-setup + (rtl:make-push-return continuation-label)) + (load-temporary-register scfg*scfg->scfg! (car args) + (lambda (temporary) + (scfg*scfg->scfg! (loop (cdr args)) + (rtl:make-push temporary)))))) + (make-null-cfg)) (let ((primitive (make-primitive-procedure name true))) ((or (special-primitive-handler primitive) rtl:make-invocation:primitive) @@ -331,11 +372,11 @@ MIT in each case. |# (define (indexed-memory-reference type length-expression index-locative) (lambda (name value-type generator) - (lambda (context expressions finish) + (lambda (combination expressions finish) (let ((object (car expressions)) (index (cadr expressions))) (open-code:with-checks - context + combination (cons* (open-code:type-check object type) (open-code:type-check index (ucode-type fixnum)) @@ -417,12 +458,16 @@ MIT in each case. |# (rtl:make-assignment locative (rtl:make-char->ascii value))) (define (assignment-finisher make-assignment make-fetch) + make-fetch ;ignore (lambda (locative value finish) (let ((assignment (make-assignment locative value))) (if finish +#| (load-temporary-register scfg*scfg->scfg! (make-fetch locative) (lambda (temporary) (scfg*scfg->scfg! assignment (finish temporary)))) +|# + (scfg*scfg->scfg! assignment (finish (rtl:make-constant unspecific))) assignment)))) (define finish-vector-assignment @@ -435,15 +480,16 @@ MIT in each case. |# (define-open-coder/predicate 'NULL? (simple-open-coder - (lambda (context expressions finish) - context + (lambda (combination expressions finish) + combination (finish (pcfg-invert (rtl:make-true-test (car expressions))))) - '(0))) + '(0) + false)) (let ((open-code/type-test (lambda (type) - (lambda (context expressions finish) - context + (lambda (combination expressions finish) + combination (finish (rtl:make-type-test (rtl:make-object->type (car expressions)) type)))))) @@ -451,46 +497,49 @@ MIT in each case. |# (let ((simple-type-test (lambda (name type) (define-open-coder/predicate name - (simple-open-coder (open-code/type-test type) '(0)))))) + (simple-open-coder (open-code/type-test type) '(0) false))))) (simple-type-test 'PAIR? (ucode-type pair)) (simple-type-test 'STRING? (ucode-type string)) (simple-type-test 'BIT-STRING? (ucode-type vector-1b))) (define-open-coder/predicate 'OBJECT-TYPE? - (filter/nonnegative-integer open-code/type-test 0 '(1)))) + (filter/nonnegative-integer open-code/type-test 0 '(1) false))) (define-open-coder/predicate 'EQ? (simple-open-coder - (lambda (context expressions finish) - context + (lambda (combination expressions finish) + combination (finish (rtl:make-eq-test (car expressions) (cadr expressions)))) - '(0 1))) + '(0 1) + false)) (let ((open-code/pair-cons (lambda (type) - (lambda (context expressions finish) - context + (lambda (combination expressions finish) + combination (finish (rtl:make-typed-cons:pair (rtl:make-constant type) (car expressions) (cadr expressions))))))) (define-open-coder/value 'CONS - (simple-open-coder (open-code/pair-cons (ucode-type pair)) '(0 1))) + (simple-open-coder (open-code/pair-cons (ucode-type pair)) '(0 1) false)) (define-open-coder/value 'SYSTEM-PAIR-CONS - (filter/nonnegative-integer open-code/pair-cons 0 '(1 2)))) + (filter/nonnegative-integer open-code/pair-cons 0 '(1 2) false))) (define-open-coder/value 'VECTOR (lambda (operands) - (and (< (length operands) 32) - (return-2 (lambda (context expressions finish) - context - (finish - (rtl:make-typed-cons:vector - (rtl:make-constant (ucode-type vector)) - expressions))) - (all-operand-indices operands))))) + (if (< (length operands) 32) + (values (lambda (combination expressions finish) + combination + (finish + (rtl:make-typed-cons:vector + (rtl:make-constant (ucode-type vector)) + expressions))) + (all-operand-indices operands) + false) + (values false false false)))) (define (all-operand-indices operands) (let loop ((operands operands) (index 0)) @@ -508,10 +557,10 @@ MIT in each case. |# (define-open-coder/value 'STRING-ALLOCATE (simple-open-coder - (lambda (context expressions finish) + (lambda (combination expressions finish) (let ((length (car expressions))) (open-code:with-checks - context + combination (list (open-code:nonnegative-check length)) (finish (rtl:make-typed-cons:string @@ -520,58 +569,83 @@ MIT in each case. |# finish 'STRING-ALLOCATE expressions))) - '(0))) + '(0) + compiler:generate-range-checks?)) |# -(let ((make-fixed-ref +(let ((user-ref (lambda (name make-fetch type index) - (lambda (context expressions finish) + (define-open-coder/value name + (simple-open-coder + (lambda (combination expressions finish) + (let ((expression (car expressions))) + (open-code:with-checks + combination + (list (open-code:type-check expression type)) + (finish (make-fetch (rtl:locative-offset expression index))) + finish + name + expressions))) + '(0) + compiler:generate-type-checks?))))) + (user-ref 'CELL-CONTENTS rtl:make-fetch (ucode-type cell) 0) + (user-ref 'VECTOR-LENGTH rtl:length-fetch (ucode-type vector) 0) + (user-ref 'STRING-LENGTH rtl:length-fetch (ucode-type string) 1) + (user-ref 'BIT-STRING-LENGTH rtl:length-fetch (ucode-type vector-1b) 1) + (user-ref 'CAR rtl:make-fetch (ucode-type pair) 0) + (user-ref 'CDR rtl:make-fetch (ucode-type pair) 1)) + +(let ((system-ref + (lambda (name make-fetch index) + (define-open-coder/value name + (simple-open-coder + (lambda (combination expressions finish) + combination + (finish + (make-fetch (rtl:locative-offset (car expressions) index)))) + '(0) + false))))) + (system-ref 'SYSTEM-PAIR-CAR rtl:make-fetch 0) + (system-ref 'SYSTEM-PAIR-CDR rtl:make-fetch 1) + (system-ref 'SYSTEM-HUNK3-CXR0 rtl:make-fetch 0) + (system-ref 'SYSTEM-HUNK3-CXR1 rtl:make-fetch 1) + (system-ref 'SYSTEM-HUNK3-CXR2 rtl:make-fetch 2)) + +(let ((make-fixed-ref + (lambda (name index) + (lambda (combination expressions finish) (let ((expression (car expressions))) (open-code:with-checks - context - (if type (list (open-code:type-check expression type)) '()) - (finish (make-fetch (rtl:locative-offset expression index))) + combination + (list (open-code:type-check expression (ucode-type pair))) + (finish (rtl:make-fetch (rtl:locative-offset expression index))) finish name - expressions))))) - (standard-def - (lambda (name fixed-ref) - (define-open-coder/value name - (simple-open-coder fixed-ref '(0)))))) - (let ((user-ref - (lambda (name make-fetch type index) - (standard-def name (make-fixed-ref name make-fetch type index))))) - (user-ref 'CELL-CONTENTS rtl:make-fetch (ucode-type cell) 0) - (user-ref 'VECTOR-LENGTH rtl:length-fetch (ucode-type vector) 0) - (user-ref 'STRING-LENGTH rtl:length-fetch (ucode-type string) 1) - (user-ref 'BIT-STRING-LENGTH rtl:length-fetch (ucode-type vector-1b) 1) - (user-ref 'SYSTEM-PAIR-CAR rtl:make-fetch false 0) - (user-ref 'SYSTEM-PAIR-CDR rtl:make-fetch false 1) - (user-ref 'SYSTEM-HUNK3-CXR0 rtl:make-fetch false 0) - (user-ref 'SYSTEM-HUNK3-CXR1 rtl:make-fetch false 1) - (user-ref 'SYSTEM-HUNK3-CXR2 rtl:make-fetch false 2) - (user-ref 'SYSTEM-VECTOR-SIZE rtl:vector-length-fetch false 0)) - (let ((car-ref (make-fixed-ref 'CAR rtl:make-fetch (ucode-type pair) 0)) - (cdr-ref (make-fixed-ref 'CDR rtl:make-fetch (ucode-type pair) 1))) - (standard-def 'CAR car-ref) - (standard-def 'CDR cdr-ref) + expressions)))))) + (let ((car-ref (make-fixed-ref 'CAR 0)) + (cdr-ref (make-fixed-ref 'CDR 1))) (define-open-coder/value 'GENERAL-CAR-CDR (filter/positive-integer (lambda (pattern) - (lambda (context expressions finish) - context - (finish - (let loop ((pattern pattern) (expression (car expressions))) - (if (= pattern 1) - expression - ((if (odd? pattern) car-ref cdr-ref) - context - (list expression) - (lambda (expression) - (loop (quotient pattern 2) expression)))))))) + (if (= pattern 1) + (lambda (combination expressions finish) + combination + (finish (car expressions))) + (lambda (combination expressions finish) + (let loop ((pattern pattern) + (expression (car expressions))) + (let ((new-pattern (quotient pattern 2))) + ((if (odd? pattern) car-ref cdr-ref) + combination + (list expression) + (if (= new-pattern 1) + finish + (lambda (expression) + (loop new-pattern expression))))))))) 1 - '(0))))) - + '(0) + compiler:generate-type-checks?)))) + (for-each (lambda (name) (define-open-coder/value name (simple-open-coder @@ -579,9 +653,11 @@ MIT in each case. |# (lambda (locative expressions finish) expressions (finish (rtl:make-fetch locative)))) - '(0 1)))) + '(0 1) + (or compiler:generate-type-checks? + compiler:generate-range-checks?)))) '(VECTOR-REF SYSTEM-VECTOR-REF)) - + ;; For now SYSTEM-XXXX side effect procedures are considered ;; dangerous to the garbage collector's health. Some day we will ;; again be able to enable them. @@ -590,10 +666,10 @@ MIT in each case. |# (lambda (name type index) (define-open-coder/effect name (simple-open-coder - (lambda (context expressions finish) + (lambda (combination expressions finish) (let ((object (car expressions))) (open-code:with-checks - context + combination (if type (list (open-code:type-check object type)) '()) (finish-vector-assignment (rtl:locative-offset object index) (cadr expressions) @@ -601,7 +677,8 @@ MIT in each case. |# finish name expressions))) - '(0 1)))))) + '(0 1) + compiler:generate-type-checks?))))) (fixed-assignment 'SET-CAR! (ucode-type pair) 0) (fixed-assignment 'SET-CDR! (ucode-type pair) 1) (fixed-assignment 'SET-CELL-CONTENTS! (ucode-type cell) 0) @@ -621,17 +698,19 @@ MIT in each case. |# (finish-vector-assignment locative (caddr expressions) finish))) - '(0 1 2)))) + '(0 1 2) + (or compiler:generate-type-checks? + compiler:generate-range-checks?)))) '(VECTOR-SET! #| SYSTEM-VECTOR-SET! |#)) ;;;; Character/String Primitives (define-open-coder/value 'CHAR->INTEGER (simple-open-coder - (lambda (context expressions finish) + (lambda (combination expressions finish) (let ((char (car expressions))) (open-code:with-checks - context + combination (list (open-code:type-check char (ucode-type character))) (finish (rtl:make-cons-pointer @@ -640,7 +719,8 @@ MIT in each case. |# finish 'CHAR->INTEGER expressions))) - '(0))) + '(0) + compiler:generate-type-checks?)) (define-open-coder/value 'STRING-REF (simple-open-coder @@ -648,29 +728,34 @@ MIT in each case. |# (lambda (locative expressions finish) expressions (finish (rtl:string-fetch locative)))) - '(0 1))) + '(0 1) + (or compiler:generate-type-checks? + compiler:generate-range-checks?))) (define-open-coder/effect 'STRING-SET! (simple-open-coder (string-memory-reference 'STRING-SET! (ucode-type character) (lambda (locative expressions finish) (finish-string-assignment locative (caddr expressions) finish))) - '(0 1 2))) + '(0 1 2) + (or compiler:generate-type-checks? + compiler:generate-range-checks?))) ;;;; Fixnum Arithmetic (for-each (lambda (fixnum-operator) (define-open-coder/value fixnum-operator (simple-open-coder - (lambda (context expressions finish) - context + (lambda (combination expressions finish) + combination (finish (rtl:make-fixnum->object (rtl:make-fixnum-2-args fixnum-operator (rtl:make-object->fixnum (car expressions)) (rtl:make-object->fixnum (cadr expressions)))))) - '(0 1)))) + '(0 1) + false))) '(PLUS-FIXNUM MINUS-FIXNUM MULTIPLY-FIXNUM @@ -680,39 +765,42 @@ MIT in each case. |# (for-each (lambda (fixnum-operator) (define-open-coder/value fixnum-operator (simple-open-coder - (lambda (context expressions finish) - context + (lambda (combination expressions finish) + combination (finish (rtl:make-fixnum->object (rtl:make-fixnum-1-arg fixnum-operator (rtl:make-object->fixnum (car expressions)))))) - '(0)))) + '(0) + false))) '(ONE-PLUS-FIXNUM MINUS-ONE-PLUS-FIXNUM)) (for-each (lambda (fixnum-pred) (define-open-coder/predicate fixnum-pred (simple-open-coder - (lambda (context expressions finish) - context + (lambda (combination expressions finish) + combination (finish (rtl:make-fixnum-pred-2-args fixnum-pred (rtl:make-object->fixnum (car expressions)) (rtl:make-object->fixnum (cadr expressions))))) - '(0 1)))) + '(0 1) + false))) '(EQUAL-FIXNUM? LESS-THAN-FIXNUM? GREATER-THAN-FIXNUM?)) (for-each (lambda (fixnum-pred) (define-open-coder/predicate fixnum-pred (simple-open-coder - (lambda (context expressions finish) - context + (lambda (combination expressions finish) + combination (finish (rtl:make-fixnum-pred-1-arg fixnum-pred (rtl:make-object->fixnum (car expressions))))) - '(0)))) + '(0) + false))) '(ZERO-FIXNUM? POSITIVE-FIXNUM? NEGATIVE-FIXNUM?)) ;;; Floating Point Arithmetic @@ -724,10 +812,10 @@ MIT in each case. |# (lambda (flonum-operator) (define-open-coder/value flonum-operator (simple-open-coder - (lambda (context expressions finish) + (lambda (combination expressions finish) (let ((argument (car expressions))) (open-code:with-checks - context + combination (list (open-code:type-check argument (ucode-type flonum))) (finish (rtl:make-float->object (rtl:make-flonum-1-arg @@ -737,19 +825,21 @@ MIT in each case. |# finish flonum-operator expressions))) - '(0)))) - '(SINE-FLONUM COSINE-FLONUM ATAN-FLONUM EXP-FLONUM - LN-FLONUM SQRT-FLONUM TRUNCATE-FLONUM)) + '(0) + compiler:generate-type-checks?))) + '(FLONUM-NEGATE FLONUM-ABS FLONUM-SIN FLONUM-COS FLONUM-TAN FLONUM-ASIN + FLONUM-ACOS FLONUM-ATAN FLONUM-EXP FLONUM-LOG FLONUM-SQRT FLONUM-ROUND + FLONUM-TRUNCATE)) (for-each (lambda (flonum-operator) (define-open-coder/value flonum-operator (simple-open-coder - (lambda (context expressions finish) + (lambda (combination expressions finish) (let ((arg1 (car expressions)) (arg2 (cadr expressions))) (open-code:with-checks - context + combination (list (open-code:type-check arg1 (ucode-type flonum)) (open-code:type-check arg2 (ucode-type flonum))) (finish @@ -763,17 +853,18 @@ MIT in each case. |# finish flonum-operator expressions))) - '(0 1)))) - '(PLUS-FLONUM MINUS-FLONUM MULTIPLY-FLONUM DIVIDE-FLONUM)) - + '(0 1) + compiler:generate-type-checks?))) + '(FLONUM-ADD FLONUM-SUBTRACT FLONUM-MULTIPLY FLONUM-DIVIDE)) + (for-each (lambda (flonum-pred) (define-open-coder/predicate flonum-pred (simple-open-coder - (lambda (context expressions finish) + (lambda (combination expressions finish) (let ((argument (car expressions))) (open-code:with-checks - context + combination (list (open-code:type-check argument (ucode-type flonum))) (finish (rtl:make-flonum-pred-1-arg @@ -784,18 +875,19 @@ MIT in each case. |# (finish (rtl:make-true-test expression))) flonum-pred expressions))) - '(0)))) - '(ZERO-FLONUM? POSITIVE-FLONUM? NEGATIVE-FLONUM?)) + '(0) + compiler:generate-type-checks?))) + '(FLONUM-ZERO? FLONUM-POSITIVE? FLONUM-NEGATIVE?)) (for-each (lambda (flonum-pred) (define-open-coder/predicate flonum-pred (simple-open-coder - (lambda (context expressions finish) + (lambda (combination expressions finish) (let ((arg1 (car expressions)) (arg2 (cadr expressions))) (open-code:with-checks - context + combination (list (open-code:type-check arg1 (ucode-type flonum)) (open-code:type-check arg2 (ucode-type flonum))) (finish (rtl:make-flonum-pred-2-args @@ -808,52 +900,64 @@ MIT in each case. |# (finish (rtl:make-true-test expression))) flonum-pred expressions))) - '(0 1)))) - '(EQUAL-FLONUM? LESS-THAN-FLONUM? GREATER-THAN-FLONUM?)) + '(0 1) + compiler:generate-type-checks?))) + '(FLONUM-EQUAL? FLONUM-LESS? FLONUM-GREATER?)) + + ;; end COMPILER:OPEN-CODE-FLOATING-POINT-ARITHMETIC? )) ;;; Generic arithmetic -(define (generic-binary-generator generic-op is-pred?) - (define-non-simple-primitive! generic-op) - ((if is-pred? define-open-coder/predicate define-open-coder/value) - generic-op - (simple-open-coder - (let ((fix-op (generic->fixnum-op generic-op))) - (lambda (context expressions finish) - (let ((op1 (car expressions)) - (op2 (cadr expressions)) - (give-it-up - (generic-default generic-op is-pred? - context expressions finish))) - (if is-pred? - (generate-binary-type-test (ucode-type fixnum) op1 op2 - give-it-up - (lambda () - (finish - (if (eq? fix-op 'EQUAL-FIXNUM?) - ;; This produces better code. - (rtl:make-eq-test op1 op2) - (rtl:make-fixnum-pred-2-args - fix-op - (rtl:make-object->fixnum op1) - (rtl:make-object->fixnum op2)))))) - (let ((give-it-up (give-it-up))) - (generate-binary-type-test (ucode-type fixnum) op1 op2 - (lambda () - give-it-up) - (lambda () - (load-temporary-register scfg*scfg->scfg! - (rtl:make-fixnum-2-args - fix-op - (rtl:make-object->fixnum op1) - (rtl:make-object->fixnum op2)) - (lambda (fix-temp) - (pcfg*scfg->scfg! - (pcfg/prefer-alternative! (rtl:make-overflow-test)) - give-it-up - (finish (rtl:make-fixnum->object fix-temp)))))))))))) - '(0 1)))) +(define (generic-binary-operator generic-op) + (define-open-coder/value generic-op + (simple-open-coder + (let ((fix-op (generic->fixnum-op generic-op))) + (lambda (combination expressions finish) + (let ((op1 (car expressions)) + (op2 (cadr expressions)) + (give-it-up + (generic-default generic-op combination expressions + false finish))) + (let ((give-it-up (give-it-up))) + (generate-binary-type-test (ucode-type fixnum) op1 op2 + (lambda () + give-it-up) + (lambda () + (load-temporary-register scfg*scfg->scfg! + (rtl:make-fixnum-2-args + fix-op + (rtl:make-object->fixnum op1) + (rtl:make-object->fixnum op2)) + (lambda (fix-temp) + (pcfg*scfg->scfg! + (pcfg/prefer-alternative! (rtl:make-overflow-test)) + give-it-up + (finish (rtl:make-fixnum->object fix-temp))))))))))) + '(0 1) + true))) + +(define (generic-binary-predicate generic-op) + (define-open-coder/generic-predicate generic-op + (simple-open-coder + (let ((fix-op (generic->fixnum-op generic-op))) + (lambda (combination expressions predicate? finish) + (let ((op1 (car expressions)) + (op2 (cadr expressions))) + (generate-binary-type-test (ucode-type fixnum) op1 op2 + (generic-default generic-op combination expressions predicate? + finish) + (lambda () + ((if predicate? finish (finish/predicate->value finish)) + (if (eq? fix-op 'EQUAL-FIXNUM?) + ;; This produces better code. + (rtl:make-eq-test op1 op2) + (rtl:make-fixnum-pred-2-args + fix-op + (rtl:make-object->fixnum op1) + (rtl:make-object->fixnum op2))))))))) + '(0 1) + true))) (define (generate-binary-type-test type op1 op2 give-it-up do-it) (generate-type-test type op1 @@ -875,40 +979,47 @@ MIT in each case. |# (pcfg*scfg->scfg! test* (do-it) give-it-up) give-it-up))))))) -(define (generic-unary-generator generic-op is-pred?) - (define-non-simple-primitive! generic-op) - ((if is-pred? define-open-coder/predicate define-open-coder/value) - generic-op - (simple-open-coder - (let ((fix-op (generic->fixnum-op generic-op))) - (lambda (context expressions finish) - (let ((op (car expressions)) - (give-it-up - (generic-default generic-op is-pred? - context expressions finish))) - (if is-pred? - (generate-unary-type-test (ucode-type fixnum) op - give-it-up - (lambda () - (finish - (rtl:make-fixnum-pred-1-arg - fix-op - (rtl:make-object->fixnum op))))) - (let ((give-it-up (give-it-up))) - (generate-unary-type-test (ucode-type fixnum) op - (lambda () - give-it-up) - (lambda () - (load-temporary-register scfg*scfg->scfg! - (rtl:make-fixnum-1-arg - fix-op - (rtl:make-object->fixnum op)) - (lambda (fix-temp) - (pcfg*scfg->scfg! - (pcfg/prefer-alternative! (rtl:make-overflow-test)) - give-it-up - (finish (rtl:make-fixnum->object fix-temp)))))))))))) - '(0)))) +(define (generic-unary-operator generic-op) + (define-open-coder/value generic-op + (simple-open-coder + (let ((fix-op (generic->fixnum-op generic-op))) + (lambda (combination expressions finish) + (let ((op (car expressions))) + (let ((give-it-up + ((generic-default generic-op combination expressions + false finish)))) + (generate-unary-type-test (ucode-type fixnum) op + (lambda () + give-it-up) + (lambda () + (load-temporary-register scfg*scfg->scfg! + (rtl:make-fixnum-1-arg + fix-op + (rtl:make-object->fixnum op)) + (lambda (fix-temp) + (pcfg*scfg->scfg! + (pcfg/prefer-alternative! (rtl:make-overflow-test)) + give-it-up + (finish (rtl:make-fixnum->object fix-temp))))))))))) + '(0) + true))) + +(define (generic-unary-predicate generic-op) + (define-open-coder/generic-predicate generic-op + (simple-open-coder + (let ((fix-op (generic->fixnum-op generic-op))) + (lambda (combination expressions predicate? finish) + (let ((op (car expressions))) + (generate-unary-type-test (ucode-type fixnum) op + (generic-default generic-op combination expressions predicate? + finish) + (lambda () + ((if predicate? finish (finish/predicate->value finish)) + (rtl:make-fixnum-pred-1-arg + fix-op + (rtl:make-object->fixnum op)))))))) + '(0) + true))) (define (generate-unary-type-test type op give-it-up do-it) (generate-type-test type op @@ -917,60 +1028,55 @@ MIT in each case. |# (lambda (test) (pcfg*scfg->scfg! test (do-it) (give-it-up))))) -(define (generic-default generic-op is-pred? context expressions finish) +(define (generic-default generic-op combination expressions predicate? finish) (lambda () - (with-values (lambda () (generate-continuation-entry context)) - (lambda (label setup cleanup) - (scfg-append! - (generate-primitive generic-op expressions setup label) - cleanup - (if is-pred? - (finish (rtl:make-true-test (rtl:make-fetch register:value))) - (expression-simplify-for-statement (rtl:make-fetch register:value) - finish))))))) + (if (combination/reduction? combination) + (let ((scfg (generate-primitive generic-op '() false false))) + (make-scfg (cfg-entry-node scfg) '())) + (with-values + (lambda () + (generate-continuation-entry (combination/context combination))) + (lambda (label setup cleanup) + (scfg-append! + (generate-primitive generic-op expressions setup label) + cleanup + (if predicate? + (finish (rtl:make-true-test (rtl:make-fetch register:value))) + (expression-simplify-for-statement + (rtl:make-fetch register:value) + finish)))))))) (define (generic->fixnum-op generic-op) (case generic-op - ((&+) 'PLUS-FIXNUM) - ((&-) 'MINUS-FIXNUM) - ((&*) 'MULTIPLY-FIXNUM) - ((1+) 'ONE-PLUS-FIXNUM) - ((-1+) 'MINUS-ONE-PLUS-FIXNUM) - ((&<) 'LESS-THAN-FIXNUM?) - ((&>) 'GREATER-THAN-FIXNUM?) - ((&=) 'EQUAL-FIXNUM?) - ((zero?) 'ZERO-FIXNUM?) - ((positive?) 'POSITIVE-FIXNUM?) - ((negative?) 'NEGATIVE-FIXNUM?) + ((integer-add &+) 'plus-fixnum) + ((integer-subtract &-) 'minus-fixnum) + ((integer-multiply &*) 'multiply-fixnum) + ((integer-quotient) 'fixnum-quotient) + ((integer-remainder) 'fixnum-remainder) + ((integer-add-1 1+) 'one-plus-fixnum) + ((integer-subtract-1 -1+) 'minus-one-plus-fixnum) + ((integer-negate) 'fixnum-negate) + ((integer-less? &<) 'less-than-fixnum?) + ((integer-greater? &>) 'greater-than-fixnum?) + ((integer-equal? &=) 'equal-fixnum?) + ((integer-zero? zero?) 'zero-fixnum?) + ((integer-positive? positive?) 'positive-fixnum?) + ((integer-negative? negative?) 'negative-fixnum?) (else (error "Can't find corresponding fixnum op:" generic-op)))) -(define (generic->floatnum-op generic-op) - (case generic-op - ((&+) 'PLUS-FLOATNUM) - ((&-) 'MINUS-FLOATNUM) - ((&*) 'MULTIPLY-FLOATNUM) - ((1+) 'ONE-PLUS-FLOATNUM) - ((-1+) 'MINUS-ONE-PLUS-FLOATNUM) - ((&<) 'LESS-THAN-FLOATNUM?) - ((&>) 'GREATER-THAN-FLOATNUM?) - ((&=) 'EQUAL-FLOATNUM?) - ((zero?) 'ZERO-FLOATNUM?) - ((positive?) 'POSITIVE-FLOATNUM?) - ((negative?) 'NEGATIVE-FLOATNUM?) - (else (error "Can't find corresponding floatnum op:" generic-op)))) - (for-each (lambda (generic-op) - (generic-binary-generator generic-op false)) - '(&+ &- &*)) + (generic-binary-operator generic-op)) + '(&+ &- &* integer-add integer-subtract integer-multiply)) (for-each (lambda (generic-op) - (generic-binary-generator generic-op true)) - '(&= &< &>)) + (generic-binary-predicate generic-op)) + '(&= &< &> integer-equal? integer-less? integer-greater?)) (for-each (lambda (generic-op) - (generic-unary-generator generic-op false)) - '(1+ -1+)) + (generic-unary-operator generic-op)) + '(1+ -1+ integer-add-1 integer-subtract-1)) (for-each (lambda (generic-op) - (generic-unary-generator generic-op true)) - '(zero? positive? negative?)) \ No newline at end of file + (generic-unary-predicate generic-op)) + '(zero? positive? negative? + integer-zero? integer-positive? integer-negative?)) \ No newline at end of file diff --git a/v7/src/compiler/rtlgen/rgcomb.scm b/v7/src/compiler/rtlgen/rgcomb.scm index 8be2ca63e..a45ea39eb 100644 --- a/v7/src/compiler/rtlgen/rgcomb.scm +++ b/v7/src/compiler/rtlgen/rgcomb.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgcomb.scm,v 4.11 1989/06/16 09:14:08 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgcomb.scm,v 4.12 1989/10/26 07:39:03 cph Exp $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -230,8 +230,8 @@ MIT in each case. |# (and (let ((callee (combination/model combination))) (and callee (rvalue/procedure? callee) - (procedure/open-internal? callee) - (internal-block/dynamic-link? (procedure-block callee)))) (if (return-operator/subproblem? (combination/continuation combination)) + (block/dynamic-link? (procedure-block callee)))) + (if (return-operator/subproblem? (combination/continuation combination)) link-prefix/subproblem (let ((context (combination/context combination))) (let ((popping-limit diff --git a/v7/src/compiler/rtlgen/rgretn.scm b/v7/src/compiler/rtlgen/rgretn.scm index cd0c891bc..2bff3384d 100644 --- a/v7/src/compiler/rtlgen/rgretn.scm +++ b/v7/src/compiler/rtlgen/rgretn.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgretn.scm,v 4.12 1989/03/14 19:35:30 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgretn.scm,v 4.13 1989/10/26 07:39:08 cph Rel $ -Copyright (c) 1988 Massachusetts Institute of Technology +Copyright (c) 1988, 1989 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -37,10 +37,17 @@ MIT in each case. |# (declare (usual-integrations)) (define (generate/return return) - (generate/return* (return/context return) - (return/operator return) - (application-continuation-push return) - (trivial-return-operand (return/operand return)))) + (let loop ((returns (return/equivalence-class return))) + (if (null? returns) + (generate/return* (return/context return) + (return/operator return) + (application-continuation-push return) + (trivial-return-operand (return/operand return))) + (let ((memoization (cfg-node-get (car returns) memoization-tag))) + (if (and memoization + (not (eq? memoization loop-memoization-marker))) + memoization + (loop (cdr returns))))))) (define (generate/trivial-return context operator operand) (generate/return* context operator false (trivial-return-operand operand))) @@ -163,9 +170,8 @@ MIT in each case. |# (finish (rtl:make-fetch register)))))) (define (return-operator/pop-frames context operator extra) - (let ((block (reference-context/block context)) - (pop-extra - (lambda () + (let ((pop-extra + (lambda (extra) (if (zero? extra) (make-null-cfg) (rtl:make-assignment register:stack-pointer @@ -173,22 +179,32 @@ MIT in each case. |# (stack-locative-offset (rtl:make-fetch register:stack-pointer) extra))))))) - (if (or (ic-block? block) - (return-operator/subproblem? operator)) - (pop-extra) - (let ((popping-limit (block-popping-limit block))) - (cond ((not popping-limit) - (scfg*scfg->scfg! - (rtl:make-link->stack-pointer) - (pop-extra))) - ((and (eq? popping-limit (reference-context/block context)) - (zero? (block-frame-size popping-limit)) - (zero? (reference-context/offset context)) - (zero? extra)) - (make-null-cfg)) - (else - (rtl:make-assignment register:stack-pointer - (popping-limit/locative context - popping-limit - 0 - extra)))))))) \ No newline at end of file + (if (exact-integer? context) + ;; This kludge is used by open-coding of some primitives in + ;; reduction position. In that case, there is no frame (and + ;; therefore no context) because adjustments prior to the + ;; open-coding have eliminated it. So it is known that only + ;; the primitive's arguments are on the stack, and the return + ;; address appears directly above that. + (pop-extra (+ context extra)) + (let ((block (reference-context/block context))) + (if (or (ic-block? block) + (return-operator/subproblem? operator)) + (pop-extra extra) + (let ((popping-limit (block-popping-limit block))) + (cond ((not popping-limit) + (scfg*scfg->scfg! + (rtl:make-link->stack-pointer) + (pop-extra extra))) + ((and (eq? popping-limit block) + (zero? (block-frame-size popping-limit)) + (zero? (reference-context/offset context)) + (zero? extra)) + (make-null-cfg)) + (else + (rtl:make-assignment + register:stack-pointer + (popping-limit/locative context + popping-limit + 0 + extra)))))))))) \ No newline at end of file diff --git a/v7/src/compiler/rtlgen/rgrval.scm b/v7/src/compiler/rtlgen/rgrval.scm index 9b28c5268..ee6f23d9e 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.13 1988/12/30 07:11:06 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgrval.scm,v 4.14 1989/10/26 07:39:12 cph Exp $ #| -*-Scheme-*- Copyright (c) 1988 Massachusetts Institute of Technology -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgrval.scm,v 4.13 1988/12/30 07:11:06 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgrval.scm,v 4.14 1989/10/26 07:39:12 cph Exp $ Copyright (c) 1988, 1990 Massachusetts Institute of Technology @@ -73,33 +73,207 @@ promotional, or sales literature without prior written consent from (lambda (reference) (let ((context (reference-context reference)) (safe? (reference-safe? reference))) - (lambda () + (lambda (lvalue) (find-variable context lvalue - (lambda (locative) - (expression-value/simple (rtl:make-fetch locative))) - (lambda (environment name) - (expression-value/temporary - (load-temporary-register scfg*scfg->scfg! environment - (lambda (environment) - (wrap-with-continuation-entry - context - (rtl:make-interpreter-call:lookup - environment - (intern-scode-variable! - (reference-context/block context) - name) - safe?)))) - (rtl:interpreter-call-result:lookup))) - (lambda (name) - (if (memq 'IGNORE-REFERENCE-TRAPS - (variable-declarations lvalue)) - (load-temporary-register values - (rtl:make-variable-cache name) - rtl:make-fetch) - (generate/cached-reference context name safe?))))))) - (cond ((not value) (perform-fetch)) + (lambda (locative) + (expression-value/simple (rtl:make-fetch locative))) + (lambda (#| lvalue |#) + (find-variable/value context lvalue + expression-value/simple + (lambda (environment name) + (expression-value/temporary + (load-temporary-register scfg*scfg->scfg! environment + (lambda (environment) + (wrap-with-continuation-entry + context + (rtl:make-interpreter-call:lookup + environment + (intern-scode-variable! + (reference-context/block context) + name) + safe?)))) + (rtl:interpreter-call-result:lookup))) + (lambda (name) + (rtl:make-variable-cache name) + rtl:make-fetch) + (load-temporary-register values + (rtl:make-variable-cache name) + (perform-fetch (or (variable-indirection lvalue) lvalue))) lvalue)) |# ((not (rvalue/procedure? value)) (generate/rvalue* value)) - (else (perform-fetch))))))) + (generate/indirected-closure indirection value context + (perform-fetch lvalue))))))) + |# + (else + (perform-fetch #| lvalue |#))))))) + +(define (generate/cached-reference context name safe?) + (let ((result (rtl:make-pseudo-register))) + (values + (load-temporary-register scfg*scfg->scfg! (rtl:make-variable-cache name) + (lambda (cell) + (let ((reference (rtl:make-fetch cell))) + (let ((n2 (rtl:make-type-test (rtl:make-object->type reference) + (ucode-type reference-trap))) + (n3 (rtl:make-assignment result reference)) + (n4 + (wrap-with-continuation-entry + context + (rtl:make-interpreter-call:cache-reference cell safe?))) + (n5 + (rtl:make-assignment + result + (rtl:interpreter-call-result:cache-reference)))) + (pcfg-alternative-connect! n2 n3) + (scfg-next-connect! n4 n5) + (if safe? + (let ((n6 (rtl:make-unassigned-test reference)) + ;; Make new copy of n3 to keep CSE happy. + ;; Otherwise control merge will confuse it. + (n7 (rtl:make-assignment result reference))) + (pcfg-consequent-connect! n2 n6) + (pcfg-consequent-connect! n6 n7) + (pcfg-alternative-connect! n6 n4) + (make-scfg (cfg-entry-node n2) + (hooks-union + (scfg-next-hooks n3) + (hooks-union (scfg-next-hooks n5) + (scfg-next-hooks n7))))) + (begin + (pcfg-consequent-connect! n2 n4) + (make-scfg (cfg-entry-node n2) + (hooks-union (scfg-next-hooks n3) + (scfg-next-hooks n5))))))))) + (rtl:make-fetch result)))) + +(define-method-table-entry 'PROCEDURE rvalue-methods + (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)) + (else + (expression-value/simple + (make-cons-closure-indirection procedure))))) + ((IC) + (make-ic-cons procedure)) + ((OPEN-EXTERNAL OPEN-INTERNAL) + (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-constant type-code:compiled-entry) + (rtl:make-entry:procedure (procedure-label procedure)))) + + (else + (error "Unknown procedure type" procedure))))) + +(define (make-ic-cons procedure) + ;; IC procedures have their entry points linked into their headers + ;; at load time by the linker. + (let ((header + (scode/make-lambda (procedure-name procedure) + (map variable-name + (procedure-required-arguments procedure)) + (map variable-name (procedure-optional procedure)) + (let ((rest (procedure-rest procedure))) + (and rest (variable-name rest))) + (map variable-name (procedure-names procedure)) + '() + false))) + (let ((kernel + (rtl:make-constant (scode/procedure-type-code header)) + (rtl:make-typed-cons:pair + (rtl:make-machine-constant + (scode/procedure-type-code header)) + (rtl:make-constant header) + expression))))) + (set! *ic-procedure-headers* + (cons (cons header (procedure-label procedure)) + *ic-procedure-headers*)) + (let ((context (procedure-closure-context procedure))) + (if (reference? context) + (with-values (lambda () (generate/rvalue* context)) + 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-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))))))) + (enqueue-procedure! procedure) + (let ((block (procedure-closing-block procedure))) +(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))) + ((ic-block? block) + (load-closure-parent block true)) + ((closure-block? block) + (let loop + ((entries (block-closure-offsets block)) + (code (load-closure-parent (block-parent block) false))) + (if (null? entries) + code + (reference-context/procedure context)) + (loop (cdr entries) + (scfg*scfg->scfg! + (rtl:make-assignment + (rtl:locative-offset closure-locative + (cdar entries)) + (let* ((variable (caar entries)) + (value (lvalue-known-value variable))) + (cond + ;; Paranoia. + ((and value + (rvalue/procedure? value) + (procedure/trivial-or-virtual? value) + (error "known ignorable procedure" + value variable)) + (make-trivial-closure-cons value)) + ((eq? value + (rtl:make-fetch + (find-closure-variable context variable)))))) + code)))))) + (else + (error "Unknown block type" block))))) (find-closure-variable context variable))))) + code))))) + (error "Unknown block type" block)))))) + (error "Unknown block type" block)))))) diff --git a/v7/src/compiler/rtlgen/rtlgen.scm b/v7/src/compiler/rtlgen/rtlgen.scm index 9afb9c613..c5ffa4c52 100644 --- a/v7/src/compiler/rtlgen/rtlgen.scm +++ b/v7/src/compiler/rtlgen/rtlgen.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rtlgen.scm,v 4.20 1989/08/21 19:34:39 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rtlgen.scm,v 4.21 1989/10/26 07:39:15 cph Exp $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -357,7 +357,11 @@ MIT in each case. |# (with-new-node-marks (lambda () (let ((initial-bblocks - (map->eq-set edge-right-node (rgraph-initial-edges rgraph)))) + (map->eq-set edge-right-node (rgraph-initial-edges rgraph))) + (protected-edges + (append! (map rtl-procedure/entry-edge *procedures*) + (map rtl-continuation/entry-edge *continuations*) + (map rtl-continuation/entry-edge *extra-continuations*)))) (let ((result '())) (define (loop bblock) (if (sblock? bblock) @@ -380,7 +384,8 @@ MIT in each case. |# (let ((bblock (edge-left-node edge))) (if bblock (not (node-marked? bblock)) - disallow-entries?)))))) + (and disallow-entries? + (not (memq edge protected-edges))))))))) (lambda (bblock) (set-node-previous-edges! bblock @@ -390,36 +395,4 @@ MIT in each case. |# (for-each loop initial-bblocks) (for-each (delete-block-edges! false) initial-bblocks) (for-each (delete-block-edges! true) result) - (set-rgraph-bblocks! rgraph (append! initial-bblocks result))))))) - -(define (bblock-compress! bblock limit-predicate) - ;; This improved compressor should replace the original in "rtlbase/rtlcfg". - (let ((walk-next? - (if limit-predicate - (lambda (next) (and next (not (limit-predicate next)))) - (lambda (next) next)))) - (let walk-bblock ((bblock bblock)) - (if (not (node-marked? bblock)) - (begin - (node-mark! bblock) - (if (sblock? bblock) - (let ((next (snode-next bblock))) - (if (walk-next? next) - (begin - (if (null? (cdr (node-previous-edges next))) - (begin - (set-rinst-next! - (rinst-last (bblock-instructions bblock)) - (bblock-instructions next)) - (set-bblock-instructions! - next - (bblock-instructions bblock)) - (snode-delete! bblock))) - (walk-bblock next)))) - (begin - (let ((consequent (pnode-consequent bblock))) - (if (walk-next? consequent) - (walk-bblock consequent))) - (let ((alternative (pnode-alternative bblock))) - (if (walk-next? alternative) - (walk-bblock alternative)))))))))) \ No newline at end of file + (set-rgraph-bblocks! rgraph (append! initial-bblocks result))))))) \ No newline at end of file diff --git a/v7/src/compiler/rtlopt/rcse2.scm b/v7/src/compiler/rtlopt/rcse2.scm index 9bfa6fbfa..6e0b2a9b7 100644 --- a/v7/src/compiler/rtlopt/rcse2.scm +++ b/v7/src/compiler/rtlopt/rcse2.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcse2.scm,v 4.11 1989/01/21 09:06:11 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcse2.scm,v 4.12 1989/10/26 07:39:27 cph Exp $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -69,13 +69,14 @@ MIT in each case. |# (define ((expression-inserter expression element hash in-memory?)) (or element - (begin (if (rtl:register? expression) - (set-register-expression! (rtl:register-number expression) - expression) - (mention-registers! expression)) - (let ((element* (hash-table-insert! hash expression false))) - (set-element-in-memory?! element* in-memory?) - (element-first-value element*))))) + (begin + (if (rtl:register? expression) + (set-register-expression! (rtl:register-number expression) + expression) + (mention-registers! expression)) + (let ((element* (hash-table-insert! hash expression false))) + (set-element-in-memory?! element* in-memory?) + (element-first-value element*))))) (define (expression-canonicalize expression) (cond ((rtl:register? expression) @@ -117,8 +118,9 @@ MIT in each case. |# ;; except the compiler's output, which is explicit. (if (interpreter-stack-pointer? (rtl:offset-register expression)) (quantity-number (stack-reference-quantity expression)) - (begin (set! hash-arg-in-memory? true) - (continue expression)))) + (begin + (set! hash-arg-in-memory? true) + (continue expression)))) ((BYTE-OFFSET) (set! hash-arg-in-memory? true) (continue expression)) @@ -126,12 +128,13 @@ MIT in each case. |# (set! hash-arg-in-memory? true) (set! do-not-record? true) 0) - (else (continue expression)))))) + (else + (continue expression)))))) (define (continue expression) (rtl:reduce-subparts expression + 0 loop (lambda (object) - (cond ((integer? object) object) + (cond ((integer? object) (inexact->exact object)) ((symbol? object) (symbol-hash object)) ((string? object) (string-hash object)) (else (hash object)))))) @@ -193,50 +196,44 @@ MIT in each case. |# ;; the hash table as the destination of an assignment. ELEMENT is ;; the hash table element for the value being assigned to ;; EXPRESSION. - (let ((class (element->class element)) - (register (rtl:register-number expression))) + (let ((register (rtl:register-number expression))) (set-register-expression! register expression) - (if class - (let ((expression (element-expression class)) - (register-equivalence! - (lambda (quantity) - (set-register-quantity! register quantity) - (let ((last (quantity-last-register quantity))) - (cond ((not last) - (set-quantity-first-register! quantity register) - (set-register-next-equivalent! register false)) - (else - (set-register-next-equivalent! last register) - (set-register-previous-equivalent! register last)))) - (set-quantity-last-register! quantity register)))) - (cond ((rtl:register? expression) - (register-equivalence! - (get-register-quantity (rtl:register-number expression)))) - ((stack-reference? expression) - (register-equivalence! - (stack-reference-quantity expression)))))) - (set-element-in-memory?! - (hash-table-insert! (expression-hash expression) expression class) - false)) - unspecific) + (let ((quantity (get-element-quantity element))) + (if quantity + (begin + (set-register-quantity! register quantity) + (let ((last (quantity-last-register quantity))) + (cond ((not last) + (set-quantity-first-register! quantity register) + (set-register-next-equivalent! register false)) + (else + (set-register-next-equivalent! last register) + (set-register-previous-equivalent! register last)))) + (set-quantity-last-register! quantity register))))) + (set-element-in-memory?! (hash-table-insert! (expression-hash expression) + expression + (element->class element)) + false)) (define (insert-stack-destination! expression element) - (let ((class (element->class element))) - (if class - (let ((expression (element-expression class)) - (stash-quantity! - (lambda (quantity) - (set-stack-reference-quantity! expression quantity)))) - (cond ((rtl:register? expression) - (stash-quantity! - (get-register-quantity (rtl:register-number expression)))) - ((stack-reference? expression) - (stash-quantity! - (stack-reference-quantity expression)))))) - (set-element-in-memory?! - (hash-table-insert! (expression-hash expression) expression class) - false)) - unspecific) + (let ((quantity (get-element-quantity element))) + (if quantity + (set-stack-reference-quantity! expression quantity))) + (set-element-in-memory?! (hash-table-insert! (expression-hash expression) + expression + (element->class element)) + false)) + +(define (get-element-quantity element) + (let loop ((element (element->class element))) + (and element + (let ((expression (element-expression element))) + (cond ((rtl:register? expression) + (get-register-quantity (rtl:register-number expression))) + ((stack-reference? expression) + (stack-reference-quantity expression)) + (else + (loop (element-next-value element)))))))) (define (insert-memory-destination! expression element hash) (let ((class (element->class element))) @@ -246,16 +243,14 @@ MIT in each case. |# ;; In that case, there is no need to make an element at all. (if (or class hash) (set-element-in-memory?! (hash-table-insert! hash expression class) - true))) - unspecific) + true)))) (define (mention-registers! expression) (if (rtl:register? expression) (let ((register (rtl:register-number expression))) (remove-invalid-references! register) (set-register-in-table! register (register-tick register))) - (rtl:for-each-subexpression expression mention-registers!)) - unspecific) + (rtl:for-each-subexpression expression mention-registers!))) (define (remove-invalid-references! register) ;; If REGISTER is invalid, delete from the hash table all @@ -297,9 +292,15 @@ MIT in each case. |# ;; Invalidate a register expression. These expressions are handled ;; specially for efficiency -- the register is marked invalid but we ;; delay searching the hash table for relevant expressions. - (let ((hash (expression-hash expression))) - (register-invalidate! (rtl:register-number expression)) - (hash-table-delete! hash (hash-table-lookup hash expression)))) + (let ((register (rtl:register-number expression)) + (hash (expression-hash expression))) + (register-invalidate! register) + ;; If we're invalidating the stack pointer, delete its entries + ;; immediately. + (if (interpreter-stack-pointer? expression) + (mention-registers! expression) + (hash-table-delete! hash (hash-table-lookup hash expression))))) + (define (register-invalidate! register) (let ((next (register-next-equivalent register)) (previous (register-previous-equivalent register)) diff --git a/v7/src/compiler/rtlopt/rcseht.scm b/v7/src/compiler/rtlopt/rcseht.scm index 5a20ad00a..20db64709 100644 --- a/v7/src/compiler/rtlopt/rcseht.scm +++ b/v7/src/compiler/rtlopt/rcseht.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcseht.scm,v 4.8 1989/08/10 11:39:43 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcseht.scm,v 4.9 1989/10/26 07:39:32 cph Exp $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -91,8 +91,9 @@ MIT in each case. |# (set-element-previous-value! class element) (let loop ((x element)) (if x - (begin (set-element-first-value! x element) - (loop (element-next-value x)))))) + (begin + (set-element-first-value! x element) + (loop (element-next-value x)))))) (else (set-element-first-value! element class) (let loop ((previous class) @@ -122,8 +123,9 @@ MIT in each case. |# (set-element-next-value! previous next) (let loop ((element next)) (if element - (begin (set-element-first-value! element next) - (loop (element-next-value element))))))) + (begin + (set-element-first-value! element next) + (loop (element-next-value element))))))) (let ((next (element-next-hash element)) (previous (element-previous-hash element))) (if next (set-element-previous-hash! next previous)) @@ -137,24 +139,37 @@ MIT in each case. |# (if (< i (hash-table-size)) (let bucket-loop ((element (hash-table-ref i))) (if element - (begin (if (predicate element) - (hash-table-delete! i element)) - (bucket-loop (element-next-hash element))) + (begin + (if (predicate element) + (hash-table-delete! i element)) + (bucket-loop (element-next-hash element))) (table-loop (1+ i)))))) unspecific) (define (rtl:expression-cost expression) - (case (rtl:expression-type expression) - ((REGISTER) 1) - ((CONSTANT) (rtl:constant-cost (rtl:constant-value expression))) - (else - (let loop ((parts (cdr expression)) (cost 2)) - (if (null? parts) - cost - (loop (cdr parts) - (if (pair? (car parts)) - (+ cost (rtl:expression-cost (car parts))) - cost))))))) + (let ((complex + (lambda () + (let loop ((parts (cdr expression)) (cost 3)) + (if (null? parts) + cost + (loop (cdr parts) + (if (pair? (car parts)) + (+ cost (rtl:expression-cost (car parts))) + cost))))))) + (case (rtl:expression-type expression) + ((CONSTANT) (rtl:constant-cost (rtl:constant-value expression))) + ((REGISTER) 2) + ((OBJECT->FIXNUM) + (if (let ((subexpression (rtl:object->fixnum-expression expression))) + (and (rtl:constant? subexpression) + (let ((n (rtl:constant-value subexpression))) + (and (exact-integer? n) + (<= -128 n 127))))) + 1 + (complex))) + (else + (complex))))) + (define (hash-table-copy table) ;; During this procedure, the `element-cost' slots of `table' are ;; reused as "broken hearts". -- 2.25.1