From: Chris Hanson Date: Thu, 18 Jan 1990 22:48:02 +0000 (+0000) Subject: * Disable early-syntaxing mechanism, and change back end to generate X-Git-Tag: 20090517-FFI~11586 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=94207c5757caf275a96605e077ec7f6da53977c6;p=mit-scheme.git * Disable early-syntaxing mechanism, and change back end to generate LAP instead of assembler directives. The assembler is now responsible for converting the LAP to assembler directives. * Change RTL and LAP output options to cause RTL and LAP files to be written as the information is generated. ".brtl" files are no longer generated. * Add concept of "suffix instructions" to the LAP generator. * Disassociate per-instruction "dead registers" set from the set of registers that need to be deleted after the instruction is generated. This is needed because the LAP generator sometimes needs to know which registers are dead _after_ the dead registers have been deleted. * Many of the high-level register allocator operations have been generalized so that they work for both machine and pseudo registers. This simplifies the writing of powerful rules in the LAP generator. * The LAP linearizer has been improved to notice certain common graph patterns and generate them in a fixed way. For example, if one of the branches of a conditional goes to a block that is a dead end, the linearizer will now force the dead-end block to come before the other branch; this has the advantage that it usually minimizes the branch distance, and prevents that dead-end block from being far away from the conditional. * The value-class abstraction has been generalized to have more classes, and the use of this information has been made more uniform and complete. * The cross-compiler now forces the per-procedure compilation switch off. * The `define-rule' macro has been generalized to allow it to be used with user-defined rulesets. * The RTL definition macros have been changed to collect the RTL expression names in sets that indicate their type. * The compiler now treats self-referential top-level definitions as static by default. * New RTL optimization passes perform limited dataflow analysis and rewriting of the RTL. These permit the LAP-generation rules to be tuned to more fully take advantage of the target machine's instruction set. * The subproblem free-variable analysis pass has been changed to memoize information at every CFG node. The previous memoization scheme had quadratic time complexity for certain programs. * The RTL expression simplifier has been changed to force the use of pseudo registers for all subexpressions, except the right-hand side of a pseudo-register assignment. This guarantees the uniformity of the code-generator's output, permitting the LAP-generator rules to be reduced to a small minimal set. * The RTL `unassigned-test' and `true-test' predicate types have been replaced by `eq-test' with the appropriate argument. * The RTL `constant' expression type has been replaced (in many instances) by the new `machine-constant' type. The former is now used only when the result is a Scheme object, while the latter is used to represent constant fields of words. A `machine-constant' always has an exact integer value. * The RTL `offset' expression type has been changed so that it no longer requires its first argument to be a register; now that may be an arbitrary RTL expression. * The RTL code compressor has been improved to handle many more instruction types, and to permit stack-slot reference expressions to be moved over stack pushes, adjusting their offsets in the process. * The RTL CSE was not copying its state correctly, and as a result was not doing as good a job as possible across certain conditional branches. --- diff --git a/v7/src/compiler/back/bittop.scm b/v7/src/compiler/back/bittop.scm index ee636751a..01700fce1 100644 --- a/v7/src/compiler/back/bittop.scm +++ b/v7/src/compiler/back/bittop.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/bittop.scm,v 1.11 1989/05/17 20:42:19 jinx Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/bittop.scm,v 1.12 1990/01/18 22:41:47 cph Exp $ -Copyright (c) 1988, 1989 Massachusetts Institute of Technology +Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -53,30 +53,41 @@ MIT in each case. |# ;;;; Assembler top level procedure -(define (assemble start-label input linker) - (with-values - (lambda () - (fluid-let ((*equates* (make-queue)) - (*objects* (make-queue)) - (*entry-points* (make-queue)) - (*linkage-info* (make-queue)) - (*the-symbol-table* (make-symbol-table)) - (*start-label* start-label) - (*end-label* (generate-uninterned-symbol 'END-LABEL-))) - (initialize-symbol-table!) - (with-values +(define (assemble start-label instructions) + (fluid-let ((*equates* (make-queue)) + (*objects* (make-queue)) + (*entry-points* (make-queue)) + (*linkage-info* (make-queue)) + (*the-symbol-table* (make-symbol-table)) + (*start-label* start-label) + (*end-label* (generate-uninterned-symbol 'END-LABEL-))) + (initialize-symbol-table!) + (with-values (lambda () - (initial-phase (instruction-sequence->directives input))) - (lambda (directives vars) - (let* ((count (relax! directives vars)) - (block (assemble-objects (final-phase directives)))) - (values count - (object-new-type (ucode-type compiled-code-block) - block) - (queue->list *entry-points*) - (symbol-table->assq-list *the-symbol-table*) - (queue->list *linkage-info*))))))) - linker)) + (initial-phase + (if (null? instructions) + '() + (let ((holder (list 'HOLDER))) + (let loop + ((tail holder) + (instructions + (let ((i instructions)) + (set! instructions) + i))) + (if (not (null? instructions)) + (begin + (set-cdr! tail + (lap:syntax-instruction (car instructions))) + (loop (last-pair tail) (cdr instructions))))) + (cdr holder))))) + (lambda (directives vars) + (let* ((count (relax! directives vars)) + (block (assemble-objects (final-phase directives)))) + (values count + (object-new-type (ucode-type compiled-code-block) block) + (queue->list *entry-points*) + (symbol-table->assq-list *the-symbol-table*) + (queue->list *linkage-info*))))))) (define (relax! directives vars) (define (loop vars count) @@ -84,14 +95,14 @@ MIT in each case. |# (if (null? vars) count (with-values (lambda () (phase-2 vars)) - (lambda (any-modified? number-of-vars) - number-of-vars - (if any-modified? - (begin - (clear-symbol-table!) - (initialize-symbol-table!) - (loop (phase-1 directives) (1+ count))) - count))))) + (lambda (any-modified? number-of-vars) + number-of-vars + (if any-modified? + (begin + (clear-symbol-table!) + (initialize-symbol-table!) + (loop (phase-1 directives) (1+ count))) + count))))) (loop vars 0)) ;;;; Output block generation diff --git a/v7/src/compiler/back/bitutl.scm b/v7/src/compiler/back/bitutl.scm index 3c5ca1130..135a5e7f5 100644 --- a/v7/src/compiler/back/bitutl.scm +++ b/v7/src/compiler/back/bitutl.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/bitutl.scm,v 1.3 1987/07/30 07:05:24 jinx Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/bitutl.scm,v 1.4 1990/01/18 22:41:51 cph Rel $ -Copyright (c) 1987 Massachusetts Institute of Technology +Copyright (c) 1987, 1990 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -250,14 +250,4 @@ MIT in each case. |# (if (null? (cdr queue)) (set-car! queue new) (set-cdr! (cdr queue) new)) - (set-cdr! queue new))) - -;;; Multiple values - -(declare (integrate-operator values with-values)) - -(define values list) - -(define (with-values thunk receiver) - (declare (integrate thunk receiver)) - (apply receiver (thunk))) + (set-cdr! queue new))) \ No newline at end of file diff --git a/v7/src/compiler/back/insseq.scm b/v7/src/compiler/back/insseq.scm index af259bca6..170703b8d 100644 --- a/v7/src/compiler/back/insseq.scm +++ b/v7/src/compiler/back/insseq.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/insseq.scm,v 4.2 1988/08/31 06:38:51 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/insseq.scm,v 4.3 1990/01/18 22:41:55 cph Rel $ -Copyright (c) 1987, 1988 Massachusetts Institute of Technology +Copyright (c) 1987, 1988, 1990 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -41,10 +41,10 @@ MIT in each case. |# '() (car instruction-sequence))) -(define-integrable empty-instruction-sequence +(define empty-instruction-sequence '()) -(define-integrable (directive->instruction-sequence directive) +(define (directive->instruction-sequence directive) (let ((pair (cons directive '()))) (cons pair pair))) diff --git a/v7/src/compiler/back/lapgn1.scm b/v7/src/compiler/back/lapgn1.scm index ad0ecab54..88150fcc4 100644 --- a/v7/src/compiler/back/lapgn1.scm +++ b/v7/src/compiler/back/lapgn1.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$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 $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/lapgn1.scm,v 4.9 1990/01/18 22:41:58 cph Rel $ -Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology +Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -39,7 +39,7 @@ MIT in each case. |# (define *current-bblock*) (define *pending-bblocks*) -(define (generate-bits rgraphs remote-links process-constants-block) +(define (generate-lap rgraphs remote-links process-constants-block) (with-new-node-marks (lambda () (for-each cgen-rgraph rgraphs) @@ -157,12 +157,17 @@ MIT in each case. |# (let loop () (let ((match-result (lap-generator/match-rtl-instruction rtl))) (if match-result - (fluid-let ((*dead-registers* (rinst-dead-registers rinst)) - (*prefix-instructions* (LAP)) - (*needed-registers* '())) - (let ((instructions (match-result))) - (delete-dead-registers!) - (LAP ,@*prefix-instructions* ,@instructions))) + (let ((dead-registers (rinst-dead-registers rinst))) + (fluid-let ((*dead-registers* dead-registers) + (*registers-to-delete* dead-registers) + (*prefix-instructions* (LAP)) + (*suffix-instructions* (LAP)) + (*needed-registers* '())) + (let ((instructions (match-result))) + (delete-dead-registers!) + (LAP ,@*prefix-instructions* + ,@instructions + ,@*suffix-instructions*)))) (begin (error "CGEN-RINST: No matching rules" rtl) (loop))))))) diff --git a/v7/src/compiler/back/lapgn2.scm b/v7/src/compiler/back/lapgn2.scm index d025370d1..f3f0c2d9e 100644 --- a/v7/src/compiler/back/lapgn2.scm +++ b/v7/src/compiler/back/lapgn2.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/lapgn2.scm,v 1.13 1989/12/05 20:38:22 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/lapgn2.scm,v 1.14 1990/01/18 22:42:02 cph Exp $ -Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology +Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -32,17 +32,17 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. |# -;;;; LAP Generator: high level register assignment operations +;;;; LAP Generator: High-Level Register Assignment (declare (usual-integrations)) ;; `*register-map*' holds the current register map. The operations -;; which follow use and update this map appropriately, so that the +;; that follow use and update this map appropriately, so that the ;; writer of LAP generator rules need not pass it around. (define *register-map*) -;; `*needed-registers*' contains a set of machine registers which is +;; `*needed-registers*' contains a set of machine registers that is ;; in use during the LAP generation of a single RTL instruction. The ;; value of this variable is automatically supplied to many low level ;; register map operations. The set is initialized to the empty set @@ -56,59 +56,70 @@ MIT in each case. |# (define *needed-registers*) -(define-integrable (need-register! register) +(define (need-register! register) (set! *needed-registers* (cons register *needed-registers*))) -(define-integrable (need-registers! registers) +(define (need-registers! registers) (set! *needed-registers* (eqv-set-union registers *needed-registers*))) -(define-integrable (dont-need-register! register) +(define (dont-need-register! register) (set! *needed-registers* (delv! register *needed-registers*))) -(define-integrable (dont-need-registers! registers) +(define (dont-need-registers! registers) (set! *needed-registers* (eqv-set-difference *needed-registers* registers))) ;; `*dead-registers*' is initialized at the beginning of each RTL -;; instruction to the set of pseudo registers which become dead during -;; that instruction. This information is used to make informed -;; decisions about whether it is desirable to keep the contents of -;; a particular pseudo register in a machine register, or not. - -;; All dead registers are deleted from the register map after the LAP -;; generation for that instruction, by calling -;; `delete-dead-registers!'. Thus, RTL instructions which alter the -;; contents of any pseudo register must follow this pattern: (1) -;; generate the source operands for the instruction, (2) delete the -;; dead registers from the register map, and (3) generate the code for -;; the assignment. +;; instruction to the set of pseudo registers that become dead during +;; that instruction. This information is used to decide whether or +;; not to keep the contents of a particular pseudo register in a +;; machine register. (define *dead-registers*) -(define-integrable (dead-register? register) +(define (dead-register? register) (memv register *dead-registers*)) +;; `*registers-to-delete*' is also initialized to the set of pseudo +;; registers that are dead after the current RTL instruction; these +;; registers are deleted from the register map after the LAP +;; generation for that instruction. The LAP generation rules can +;; cause these deletions to happen at any time by calling +;; `delete-dead-registers!'. + +;; RTL instructions that alter the contents of any pseudo register +;; must follow this pattern: (1) generate the source operands for the +;; instruction, (2) delete the dead registers from the register map, +;; and (3) generate the code for the assignment. + +(define *registers-to-delete*) + (define (delete-dead-registers!) (set! *register-map* - (delete-pseudo-registers *register-map* *dead-registers*)) - (set! *dead-registers* '())) + (delete-pseudo-registers *register-map* *registers-to-delete*)) + (set! *registers-to-delete* '()) + unspecific) ;; `*prefix-instructions*' is used to accumulate LAP instructions to -;; be inserted before the instructions which are the result of the +;; be inserted before the instructions that are the result of the ;; rule for this RTL instruction. The register map operations ;; generate these automatically whenever alias registers need to be ;; loaded or stored, or when the aliases need to be shuffled in some ;; way. (define *prefix-instructions*) +(define *suffix-instructions*) -(define-integrable (prefix-instructions! instructions) +(define (prefix-instructions! instructions) (set! *prefix-instructions* (LAP ,@*prefix-instructions* ,@instructions))) + +(define (suffix-instructions! instructions) + (set! *suffix-instructions* (LAP ,@instructions ,@*suffix-instructions*))) ;; Register map operations that return `allocator-values' eventually ;; pass those values to `store-allocator-values!', perhaps after some ;; tweaking. -(define-integrable (store-allocator-values! allocator-values) +(define (store-allocator-values! allocator-values) (bind-allocator-values allocator-values (lambda (alias map instructions) (need-register! alias) @@ -131,56 +142,71 @@ MIT in each case. |# (register-type? register type) (pseudo-register-alias *register-map* type register))) -(define-integrable (alias-is-unique? alias) +(define (alias-is-unique? alias) ;; `alias' must be a valid alias for some pseudo register. This ;; predicate is true iff the pseudo register has no other aliases. (machine-register-is-unique? *register-map* alias)) -(define-integrable (alias-holds-unique-value? alias) +(define (alias-holds-unique-value? alias) ;; `alias' must be a valid alias for some pseudo register. This ;; predicate is true iff the contents of the pseudo register are not ;; stored anywhere else that the register map knows of. (machine-register-holds-unique-value? *register-map* alias)) -(define-integrable (is-alias-for-register? potential-alias register) +(define (is-alias-for-register? potential-alias register) ;; True iff `potential-alias' is a valid alias for `register'. ;; `register' must be a pseudo register, and `potential-alias' must ;; be a machine register. (is-pseudo-register-alias? *register-map* potential-alias register)) -(define-integrable (register-saved-into-home? register) +(define (register-saved-into-home? register) ;; True iff `register' is known to be saved in its spill temporary. - ;; `register' must be a pseudo register. - (pseudo-register-saved-into-home? *register-map* register)) + (and (not (machine-register? register)) + (pseudo-register-saved-into-home? *register-map* register))) -(define-integrable (register-alias register type) +(define (register-alias register type) ;; Returns an alias for `register', of the given `type', if one - ;; exists. Otherwise returns #F. `register' must be a pseudo - ;; register. - (maybe-need-register! (pseudo-register-alias *register-map* type register))) + ;; exists. Otherwise returns #F. + (if (machine-register? register) + (and (register-type? register type) register) + (maybe-need-register! + (pseudo-register-alias *register-map* type register)))) (define (load-alias-register! register type) ;; Returns an alias for `register', of the given `type'. If no such ;; alias exists, a new alias is assigned and loaded with the correct - ;; value, and that alias is returned. `register' must be a pseudo - ;; register. - (store-allocator-values! - (load-alias-register *register-map* type *needed-registers* register))) + ;; value, and that alias is returned. + (if (machine-register? register) + (if (register-type? register type) + register + (let ((temp (allocate-temporary-register! type))) + (prefix-instructions! (register->register-transfer register temp)) + temp)) + (store-allocator-values! + (load-alias-register *register-map* type *needed-registers* register)))) -(define-integrable (reference-alias-register! register type) +(define (reference-alias-register! register type) (register-reference (load-alias-register! register type))) (define (allocate-alias-register! register type) ;; This operation is used to allocate an alias for `register', ;; assuming that it is about to be assigned. It first deletes any ;; other aliases for register, then allocates and returns an alias - ;; for `register', of the given `type'. `register' must be a pseudo - ;; register. - (delete-pseudo-register! register) - (store-allocator-values! - (allocate-alias-register *register-map* type *needed-registers* register))) + ;; for `register', of the given `type'. + (delete-register! register) + (if (machine-register? register) + (if (register-type? register type) + register + (let ((temp (allocate-temporary-register! type))) + (suffix-instructions! (register->register-transfer temp register)) + temp)) + (store-allocator-values! + (allocate-alias-register *register-map* + type + *needed-registers* + register)))) -(define-integrable (reference-target-alias! register type) +(define (reference-target-alias! register type) (register-reference (allocate-alias-register! register type))) (define (allocate-temporary-register! type) @@ -191,7 +217,7 @@ MIT in each case. |# (store-allocator-values! (allocate-temporary-register *register-map* type *needed-registers*))) -(define-integrable (reference-temporary-register! type) +(define (reference-temporary-register! type) (register-reference (allocate-temporary-register! type))) (define (add-pseudo-register-alias! register alias) @@ -213,19 +239,33 @@ MIT in each case. |# (add-pseudo-register-alias *register-map* register alias false)) (need-register! alias)) -(define (delete-machine-register! register) - ;; Deletes `register' from the register map. No instructions are - ;; generated. `register' must be either an alias or a temporary. - (set! *register-map* (delete-machine-register *register-map* register)) - (dont-need-register! register)) - -(define (delete-pseudo-register! register) +(define (delete-register! register) ;; Deletes `register' from the register map. No instructions are - ;; generated. `register' must be a pseudo register. - (delete-pseudo-register *register-map* register - (lambda (map aliases) - (set! *register-map* map) - (dont-need-registers! aliases)))) + ;; generated. + (if (machine-register? register) + (begin + (set! *register-map* (delete-machine-register *register-map* register)) + (dont-need-register! register)) + (delete-pseudo-register *register-map* register + (lambda (map aliases) + (set! *register-map* map) + (dont-need-registers! aliases))))) + +(define (save-register! register) + ;; Deletes `register' from the register map, saving it to its home + ;; if it is a live pseudo register. + (let ((save-pseudo + (lambda (register) + (if (not (dead-register? register)) + (save-pseudo-register *register-map* register + (lambda (map instructions) + (set! *register-map* map) + (prefix-instructions! instructions))))))) + (if (machine-register? register) + (let ((contents (machine-register-contents *register-map* register))) + (if contents + (save-pseudo contents))) + (save-pseudo register)))) (define (clear-map!) ;; Deletes all registers from the register map. Generates and @@ -239,7 +279,7 @@ MIT in each case. |# (set! *needed-registers* '()) instructions)) -(define-integrable (clear-map) +(define (clear-map) (clear-map-instructions *register-map*)) (define (clear-registers! . registers) @@ -250,21 +290,10 @@ MIT in each case. |# (lambda (map instructions) (let ((map (delete-machine-register map (car registers)))) (if (null? (cdr registers)) - (begin (set! *register-map* map) - instructions) + (begin + (set! *register-map* map) + instructions) (append! instructions (loop map (cdr registers)))))))))) - -(define (save-machine-register! register) - (let ((contents (machine-register-contents *register-map* register))) - (if contents - (save-pseudo-register! contents)))) - -(define (save-pseudo-register! register) - (if (not (dead-register? register)) - (save-pseudo-register *register-map* register - (lambda (map instructions) - (set! *register-map* map) - (prefix-instructions! instructions))))) (define (standard-register-reference register preferred-type alternate-types?) ;; Generate a standard reference for `register'. This procedure @@ -275,7 +304,7 @@ MIT in each case. |# (if (machine-register? register) (if alternate-types? (register-reference register) - (machine-register-reference register preferred-type)) + (reference-alias-register! register preferred-type)) (let ((no-reuse-possible (lambda () ;; If there are no aliases, and the register is not dead, @@ -302,21 +331,8 @@ MIT in each case. |# (else (no-reuse-possible)))) (no-preference)))))) -(define-integrable (machine-register-reference register type) - (register-reference (guarantee-alias-register! register type))) - -(define (guarantee-alias-register! register type) - ;; Returns a a machine register which contains the same contents as - ;; `register', and which has the given `type'. - (if (machine-register? register) - (if (register-type? register type) - register - (let ((temp (allocate-temporary-register! type))) - (prefix-instructions! (register->register-transfer register temp)) - temp)) - (load-alias-register! register type))) - (define (load-machine-register! source-register machine-register) + ;; Copy the contents of `source-register' to `machine-register'. (if (machine-register? source-register) (if (eqv? source-register machine-register) (LAP) @@ -328,60 +344,56 @@ MIT in each case. |# machine-register)))) (define (move-to-alias-register! source type target) - ;; Performs an assignment from the pseudo register `source' to the - ;; pseudo register `target', allocating an alias for `target' of the - ;; given `type'. Returns a reference to that alias. If `source' - ;; has a reusable alias of the appropriate type, that is used, in - ;; which case no instructions are generated. - (reuse-and-load-pseudo-register-alias! source type - (lambda (alias) - (add-pseudo-register-alias! target alias)) - (lambda () - (allocate-alias-register! target type)))) + ;; Performs an assignment from register `source' to register + ;; `target', allocating an alias for `target' of the given `type'; + ;; returns that alias. If `source' has a reusable alias of the + ;; appropriate type, that is used, in which case no instructions are + ;; generated. + (if (and (machine-register? target) + (register-type? target type)) + (begin + (prefix-instructions! + (reference->register-transfer + (standard-register-reference source type true) + target)) + target) + (reuse-pseudo-register-alias! source type + (lambda (alias) + (delete-dead-registers!) + (if (machine-register? target) + (suffix-instructions! (register->register-transfer alias target)) + (add-pseudo-register-alias! target alias)) + alias) + (lambda () + (let ((source (standard-register-reference source type true))) + (delete-dead-registers!) + (let ((target (allocate-alias-register! target type))) + (prefix-instructions! + (reference->register-transfer source target)) + target)))))) (define (move-to-temporary-register! source type) ;; Allocates a temporary register, of the given `type', and loads - ;; the contents of the pseudo register `source' into it. Returns a + ;; the contents of the register `source' into it. Returns a ;; reference to that temporary. If `source' has a reusable alias of ;; the appropriate type, that is used, in which case no instructions ;; are generated. - (reuse-and-load-pseudo-register-alias! source type - need-register! - (lambda () - (allocate-temporary-register! type)))) - -(define (reuse-and-load-pseudo-register-alias! source type if-reusable if-not) - ;; Attempts to find a reusable alias for `source', of the given - ;; `type'. If one is found, `if-reusable' is invoked on it (for - ;; effect only). Otherwise, `if-not' is invoked with no arguments - ;; to produce a machine register, and the contents of `source' are - ;; transferred into that register. The result of this procedure is - ;; a register reference, to the alias if it is found, otherwise to - ;; the result of `if-not'. Note: dead registers are always deleted - ;; by this procedure. - (reuse-alias-deleting-dead-registers! source type - (lambda (alias) - (if-reusable alias) - (register-reference alias)) - (lambda (source) - (let ((target (if-not))) - (prefix-instructions! (reference->register-transfer source target)) - (register-reference target))))) - -(define (reuse-alias-deleting-dead-registers! source type if-reusable if-not) (reuse-pseudo-register-alias! source type (lambda (alias) - (delete-dead-registers!) - (if-reusable alias)) + (need-register! alias) + alias) (lambda () - (let ((source (standard-register-reference source false true))) - (delete-dead-registers!) - (if-not source))))) + (let ((target (allocate-temporary-register! type))) + (prefix-instructions! + (reference->register-transfer + (standard-register-reference source type true) + target)) + target)))) (define (reuse-pseudo-register-alias! source type if-reusable if-not) (reuse-pseudo-register-alias source type (lambda (alias) - (delete-machine-register! alias) + (delete-register! alias) (if-reusable alias)) if-not)) @@ -393,92 +405,69 @@ MIT in each case. |# ;; reusable are as follows: (1) if `source' is dead, any of its ;; aliases may be reused, and (2) if `source' is live with multiple ;; aliases, then one of its aliases may be reused. - (let ((alias (register-alias source type))) - (cond ((not alias) - (if-not)) - ((dead-register? source) - (if-reusable alias)) - ((not (alias-is-unique? alias)) - (if-reusable alias)) - (else - (if-not))))) + (if (machine-register? source) + (if-not) + (let ((alias (register-alias source type))) + (cond ((not alias) + (if-not)) + ((dead-register? source) + (if-reusable alias)) + ((not (alias-is-unique? alias)) + (if-reusable alias)) + (else + (if-not)))))) -;; The following procedures are used when the copy is going to be -;; transformed, and the machine has 3 operand instructions, which -;; allow an implicit motion in the transformation operation. - -;; For example, on the DEC VAX it is cheaper to do -;; bicl3 op1,source,target -;; than -;; movl source,target -;; bicl2 op1,target - -;; The extra arguments are -;; REC1, invoked if we are reusing an alias of source. -;; It already contains the data to operate on. -;; REC2, invoked if a `brand-new' alias for target has been allocated. -;; We must take care of moving the data ourselves. +;;; The following procedures are used when the copy is going to be +;;; transformed, and the machine has 3 operand instructions, which +;;; allow an implicit motion in the transformation operation. + +;;; For example, on the DEC VAX it is cheaper to do +;;; bicl3 op1,source,target +;;; than +;;; movl source,target +;;; bicl2 op1,target + +;;; The extra arguments are +;;; REC1, invoked if we are reusing an alias of source. +;;; It already contains the data to operate on. +;;; REC2, invoked if a `brand-new' alias for target has been allocated. +;;; We must take care of moving the data ourselves. (define (with-register-copy-alias! source type target rec1 rec2) - (provide-copy-reusing-alias! source type rec1 rec2 - (lambda (reusable-alias) - (add-pseudo-register-alias! target reusable-alias)) - (lambda () - (allocate-alias-register! target type)))) - -(define (with-temporary-register-copy! register type rec1 rec2) - (provide-copy-reusing-alias! register type rec1 rec2 - need-register! + (reuse-pseudo-register-alias! source type + (lambda (alias) + (delete-dead-registers!) + (add-pseudo-register-alias! target alias) + (rec1 (register-reference alias))) (lambda () - (allocate-temporary-register! type)))) + (let ((source (standard-register-reference source type true))) + (delete-dead-registers!) + (rec2 source (reference-target-alias! target type)))))) -(define (provide-copy-reusing-alias! source type rec1 rec2 if-reusable if-not) - (reuse-alias-deleting-dead-registers! source type +(define (with-temporary-register-copy! source type rec1 rec2) + (reuse-pseudo-register-alias! source type (lambda (alias) - (if-reusable alias) + (need-register! alias) (rec1 (register-reference alias))) - (lambda (source) - (rec2 source (register-reference (if-not)))))) - -;;; Move a copy to a specific special register - -(define (copy-to-special-register source-register type special-register) - (let ((alias (register-alias source-register type))) - (cond (alias - (machine->machine-register alias special-register)) - ((not (dead-register? source-register)) - (delete-dead-registers!) - (machine->machine-register - (load-alias-register! source-register type) - special-register)) - ((not (register-saved-into-home? source-register)) - (error "copy-to-special-register: no valid copy" - source-register)) - (else - (reference->register-transfer - (pseudo-register-home source-register) - special-register))))) - -;;;; 2/3 Operand register allocation - -(define (with-copy-if-available source type if-win if-lose use-register!) - (reuse-pseudo-register-alias - source type - (lambda (reusable-alias) - (if-win (lambda () - (delete-machine-register! reusable-alias) - (delete-dead-registers!) - (use-register! reusable-alias) - (register-reference reusable-alias)))) - if-lose)) - -(define-integrable (with-register-copy-if-available - source type target if-win if-lose) - (with-copy-if-available source type if-win if-lose + (lambda () + (rec2 (standard-register-reference source type true) + (reference-temporary-register! type))))) + +(define (register-copy-if-available source type target if-win if-lose) + (reuse-pseudo-register-alias source type (lambda (reusable-alias) - (add-pseudo-register-alias! target reusable-alias)))) + (lambda () + (delete-register! reusable-alias) + (delete-dead-registers!) + (add-pseudo-register-alias! target reusable-alias) + (register-reference reusable-alias))) + (lambda () false))) -(define-integrable (with-temporary-copy-if-available - source type if-win if-lose) - (with-copy-if-available source type if-win if-lose need-register!)) - \ No newline at end of file +(define (temporary-copy-if-available source type if-win if-lose) + (reuse-pseudo-register-alias source type + (lambda (reusable-alias) + (lambda () + (delete-register! reusable-alias) + (need-register! reusable-alias) + (register-reference reusable-alias))) + (lambda () false))) \ No newline at end of file diff --git a/v7/src/compiler/back/linear.scm b/v7/src/compiler/back/linear.scm index 5b6aacc68..024908a4d 100644 --- a/v7/src/compiler/back/linear.scm +++ b/v7/src/compiler/back/linear.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$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 $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/linear.scm,v 4.9 1990/01/18 22:42:06 cph Exp $ -Copyright (c) 1987, 1988 Massachusetts Institute of Technology +Copyright (c) 1987, 1988, 1990 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -36,69 +36,153 @@ MIT in each case. |# (declare (usual-integrations)) -(define (bblock-linearize-bits bblock queue-continuations!) +(define (bblock-linearize-lap bblock queue-continuations!) (define (linearize-bblock bblock) + (LAP ,@(linearize-bblock-1 bblock) + ,@(linearize-next bblock))) + + (define (linearize-bblock-1 bblock) (node-mark! bblock) (queue-continuations! bblock) (if (and (not (bblock-label bblock)) - (node-previous>1? bblock)) + (let loop ((bblock bblock)) + (or (node-previous>1? bblock) + (and (node-previous=1? bblock) + (let ((previous (node-previous-first bblock))) + (and (sblock? previous) + (null? (bblock-instructions previous)) + (loop previous))))))) (bblock-label! bblock)) (let ((kernel (lambda () - (LAP ,@(bblock-instructions bblock) - ,@(if (sblock? bblock) - (let ((next (snode-next bblock))) - (if next - (linearize-sblock-next next (bblock-label next)) - (let ((bblock (sblock-continuation bblock))) - (if (and bblock (not (node-marked? bblock))) - (linearize-bblock bblock) - (LAP))))) - (linearize-pblock bblock - (pnode-consequent bblock) - (pnode-alternative bblock))))))) + (bblock-instructions bblock)))) (if (bblock-label bblock) (LAP ,(lap:make-label-statement (bblock-label bblock)) ,@(kernel)) (kernel)))) + (define (linearize-next bblock) + (if (sblock? bblock) + (let ((next (find-next (snode-next bblock)))) + (if next + (linearize-sblock-next next (bblock-label next)) + (let ((bblock (sblock-continuation bblock))) + (if (and bblock (not (node-marked? bblock))) + (linearize-bblock bblock) + (LAP))))) + (linearize-pblock + bblock + (find-next (pnode-consequent bblock)) + (find-next (pnode-alternative bblock))))) + (define (linearize-sblock-next bblock label) (if (node-marked? bblock) (LAP ,(lap:make-unconditional-branch label)) (linearize-bblock bblock))) (define (linearize-pblock pblock cn an) - (let ((heed-preference - (lambda (finish) - (if (eq? 'CONSEQUENT (pnode/preferred-branch pblock)) - (finish (pblock-alternative-lap-generator pblock) an cn) - (finish (pblock-consequent-lap-generator pblock) cn an))))) - (if (node-marked? cn) - (if (node-marked? an) - (heed-preference - (lambda (generator cn an) - (LAP ,@(generator (bblock-label cn)) - ,(lap:make-unconditional-branch (bblock-label an))))) - (LAP ,@((pblock-consequent-lap-generator pblock) - (bblock-label cn)) - ,@(linearize-bblock an))) - (if (node-marked? an) - (LAP ,@((pblock-alternative-lap-generator pblock) - (bblock-label an)) - ,@(linearize-bblock cn)) - (heed-preference - (lambda (generator cn an) - (let ((clabel (bblock-label! cn)) - (alternative (linearize-bblock an))) - (LAP ,@(generator clabel) - ,@alternative - ,@(if (node-marked? cn) - (LAP) - (linearize-bblock cn)))))))))) + (if (node-marked? cn) + (if (node-marked? an) + (heed-preference pblock cn an + (lambda (generator cn an) + (LAP ,@(generator (bblock-label cn)) + ,(lap:make-unconditional-branch (bblock-label an))))) + (LAP ,@((pblock-consequent-lap-generator pblock) + (bblock-label cn)) + ,@(linearize-bblock an))) + (if (node-marked? an) + (LAP ,@((pblock-alternative-lap-generator pblock) + (bblock-label an)) + ,@(linearize-bblock cn)) + (linearize-pblock-1 pblock cn an)))) + + (define (linearize-pblock-1 pblock cn an) + (let ((finish + (lambda (generator cn an) + (let ((clabel (bblock-label! cn)) + (alternative (linearize-bblock an))) + (LAP ,@(generator clabel) + ,@alternative + ,@(if (node-marked? cn) + (LAP) + (linearize-bblock cn))))))) + (let ((consequent-first + (lambda () + (finish (pblock-alternative-lap-generator pblock) an cn))) + (alternative-first + (lambda () + (finish (pblock-consequent-lap-generator pblock) cn an))) + (unspecial + (lambda () + (heed-preference pblock cn an finish))) + (diamond + (lambda () + (let ((jlabel (generate-label))) + (heed-preference pblock cn an + (lambda (generator cn an) + (let ((clabel (bblock-label! cn))) + (let ((consequent (linearize-bblock-1 cn)) + (alternative (linearize-bblock-1 an))) + (LAP ,@(generator clabel) + ,@alternative + ,(lap:make-unconditional-branch jlabel) + ,@consequent + ,(lap:make-label-statement jlabel) + ,@(linearize-next cn)))))))))) + (cond ((sblock? cn) + (let ((cnn (find-next (snode-next cn)))) + (cond ((eq? cnn an) + (consequent-first)) + ((sblock? an) + (let ((ann (find-next (snode-next an)))) + (cond ((eq? ann cn) + (alternative-first)) + ((not cnn) + (if ann + (consequent-first) + (if (null? (bblock-continuations cn)) + (if (null? (bblock-continuations an)) + (unspecial) + (consequent-first)) + (if (null? (bblock-continuations an)) + (alternative-first) + (unspecial))))) + ((not ann) + (alternative-first)) + ((eq? cnn ann) + (diamond)) + (else + (unspecial))))) + ((not cnn) + (consequent-first)) + (else + (unspecial))))) + ((and (sblock? an) + (let ((ann (find-next (snode-next an)))) + (or (not ann) + (eq? ann cn)))) + (alternative-first)) + (else + (unspecial)))))) + + (define (heed-preference pblock cn an finish) + (if (eq? 'CONSEQUENT (pnode/preferred-branch pblock)) + (finish (pblock-alternative-lap-generator pblock) an cn) + (finish (pblock-consequent-lap-generator pblock) cn an))) + + (define (find-next bblock) + (let loop ((bblock bblock) (previous false)) + (cond ((not bblock) + previous) + ((and (sblock? bblock) + (null? (bblock-instructions bblock))) + (loop (snode-next bblock) bblock)) + (else + bblock)))) (linearize-bblock bblock)) -(define linearize-bits - (make-linearizer bblock-linearize-bits +(define linearize-lap + (make-linearizer bblock-linearize-lap (lambda () (LAP)) (lambda (x y) (LAP ,@x ,@y)) identity-procedure)) \ No newline at end of file diff --git a/v7/src/compiler/back/regmap.scm b/v7/src/compiler/back/regmap.scm index 36eba50eb..56018da71 100644 --- a/v7/src/compiler/back/regmap.scm +++ b/v7/src/compiler/back/regmap.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/regmap.scm,v 4.8 1989/07/25 12:41:41 arthur Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/regmap.scm,v 4.9 1990/01/18 22:42:10 cph Exp $ -Copyright (c) 1988 Massachusetts Institute of Technology +Copyright (c) 1988, 1990 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -40,16 +40,16 @@ MIT in each case. |# The register allocator provides a mechanism for allocating and deallocating machine registers. It manages the available machine -registers as a cache, by maintaining a "map" which records two kinds -of information: (1) a list of the machine registers which are not in -use; and (2) a mapping which is the association between the allocated -machine registers and the "pseudo registers" which they represent. +registers as a cache, by maintaining a "map" that records two kinds of +information: (1) a list of the machine registers that are not in use; +and (2) a mapping that is the association between the allocated +machine registers and the "pseudo registers" that they represent. -An "alias" is a machine register which also holds the contents of a +An "alias" is a machine register that also holds the contents of a pseudo register. Usually an alias is used for a short period of time, as a store-in cache, and then eventually the contents of the alias is written back out to the home it is associated with. Because of the -lifetime analysis, it is possible to identify those registers which +lifetime analysis, it is possible to identify those registers that will no longer be referenced; these are deleted from the map when they die, and thus do not need to be saved. @@ -72,7 +72,7 @@ and stop at `number-of-machine-registers' (exclusive). All others are pseudo registers. Because they are integers, we can use `eqv?' to compare register numbers. -`available-machine-registers' should be a list of the registers which +`available-machine-registers' should be a list of the registers that the allocator is allowed to allocate, in the preferred order of allocation. @@ -82,11 +82,9 @@ registers into some interesting sorting order. |# (define (register-type? register type) - ;; This predicate is true iff `register' has the given `type'. - ;; `register' must be a machine register. If `type' is #f, this predicate - ;; returns #f iff `register' is not a word register. - (or (and (not type) (word-register? register)) - (eq? (register-type register) type))) + (if type + (eq? type (register-type register)) + (register-value-class=word? register))) (define ((register-type-predicate type) register) (register-type? register type)) @@ -379,13 +377,13 @@ registers into some interesting sorting order. (lambda (entry) (and (not (map-entry-home entry)) (reallocate-alias entry)))) - ;; Then look for a register which contains the same thing as + ;; Then look for a register that contains the same thing as ;; another register. (map-entries:search map (lambda (entry) (and (not (null? (cdr (map-entry-aliases entry)))) (reallocate-alias entry)))) - ;; Look for a non-temporary which has been saved into its home. + ;; Look for a non-temporary that has been saved into its home. (map-entries:search map (lambda (entry) (and (map-entry-home entry) @@ -577,7 +575,7 @@ for REGISTER. If no such register exists, returns #F." ;;; These operations generate the instructions to coerce one map into ;;; another. They are used when joining two branches of a control -;;; flow graph which have different maps (e.g. in a loop.) +;;; flow graph that have different maps (e.g. in a loop.) (package (coerce-map-instructions clear-map-instructions) diff --git a/v7/src/compiler/back/syntax.scm b/v7/src/compiler/back/syntax.scm index 6adaf5f10..395f13d73 100644 --- a/v7/src/compiler/back/syntax.scm +++ b/v7/src/compiler/back/syntax.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$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 $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/syntax.scm,v 1.25 1990/01/18 22:42:14 cph Rel $ -Copyright (c) 1988, 1989 Massachusetts Institute of Technology +Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -67,16 +67,11 @@ MIT in each case. |# (define (lap:syntax-instruction instruction) (if (memq (car instruction) '(EQUATE SCHEME-OBJECT ENTRY-POINT LABEL BLOCK-OFFSET)) - (directive->instruction-sequence instruction) + (list instruction) (let ((match-result (instruction-lookup instruction))) (if (not match-result) - (error "LAP:SYNTAX-INSTRUCTION: illegal instruction syntax" - instruction)) - (let ((directives (match-result))) - (if (null? directives) - (error "LAP:SYNTAX-INSTRUCTION: instruction generation error" - instruction)) - (instruction->instruction-sequence directives))))) + (error "illegal instruction syntax" instruction)) + (match-result)))) (define (instruction-lookup instruction) (pattern-lookup diff --git a/v7/src/compiler/base/crsend.scm b/v7/src/compiler/base/crsend.scm index 84a1b8b3d..674e34df1 100644 --- a/v7/src/compiler/base/crsend.scm +++ b/v7/src/compiler/base/crsend.scm @@ -1,9 +1,9 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/crsend.scm,v 1.2 1989/08/21 19:32:18 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/crsend.scm,v 1.3 1990/01/18 22:42:38 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 +Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -39,21 +39,13 @@ MIT in each case. |# (declare (usual-integrations)) -(define-macro (last-reference name) - (let ((x (generate-uninterned-symbol))) - `(IF COMPILER:PRESERVE-DATA-STRUCTURES? - ,name - (LET ((,x ,name)) - (SET! ,name) - ,x)))) - (define (cross-compile-bin-file-end input-string #!optional output-string) (compiler-pathnames input-string (and (not (default-object? output-string)) output-string) (make-pathname false false false false "bits.x" 'NEWEST) (lambda (input-pathname output-pathname) output-pathname ;ignore - (cross-compile-scode-end (compiler-fasload input-pathname))))) + (cross-compile-scode-end (fasload input-pathname))))) (define (compiler-pathnames input-string output-string default transform) (let* ((core @@ -85,11 +77,28 @@ MIT in each case. |# (for-each kernel input-string) (kernel input-string)))) +(define compiler:batch-mode? + false) + (define (cross-compile-scode-end cross-compilation) - (in-compiler - (lambda () - (cross-link-end cross-compilation) - *expression*))) + (let ((compile-by-procedures? (vector-ref cross-compilation 0)) + (expression (cross-link-end (vector-ref cross-compilation 1))) + (others (map cross-link-end (vector-ref cross-compilation 2)))) + (if (null? others) + expression + (scode/make-comment + (make-dbg-info-vector + (let ((all-blocks + (list->vector + (cons + (compiled-code-address->block expression) + others)))) + (if compile-by-procedures? + (list 'COMPILED-BY-PROCEDURES + all-blocks + (list->vector others)) + all-blocks))) + expression)))) (define-structure (cc-vector (constructor cc-vector/make) (conc-name cc-vector/)) @@ -100,71 +109,31 @@ MIT in each case. |# (ic-procedure-headers false read-only true)) (define (cross-link-end cc-vector) - (set! *code-vector* (cc-vector/code-vector cc-vector)) - (set! *entry-label* (cc-vector/entry-label cc-vector)) - (set! *entry-points* (cc-vector/entry-points cc-vector)) - (set! *label-bindings* (cc-vector/label-bindings cc-vector)) - (set! *ic-procedure-headers* (cc-vector/ic-procedure-headers cc-vector)) - (phase/link)) - -(define (phase/link) - (compiler-phase "Linkification" - (lambda () - ;; This has sections locked against GC to prevent relocation - ;; while computing addresses. - (let ((bindings - (map (lambda (label) - (cons - label - (with-absolutely-no-interrupts - (lambda () - ((ucode-primitive &make-object) - type-code:compiled-entry - (make-non-pointer-object - (+ (cdr (or (assq label *label-bindings*) - (error "Missing entry point" label))) - (object-datum *code-vector*)))))))) - *entry-points*))) - (let ((label->expression - (lambda (label) - (cdr (or (assq label bindings) - (error "Label not defined as entry point" label)))))) - (set! *expression* (label->expression *entry-label*)) - (for-each (lambda (entry) - (set-lambda-body! (car entry) - (label->expression (cdr entry)))) - *ic-procedure-headers*))) - (set! *code-vector*) - (set! *entry-points*) - (set! *label-bindings*) - (set! *entry-label*) - (set! *ic-procedure-headers*)))) - -;;;; Compiler emulation - -(define type-code:compiled-entry (ucode-type COMPILED-ENTRY)) -(define compiler:batch-mode? false) - -(define *expression*) -(define *code-vector*) -(define *entry-label*) -(define *entry-points*) -(define *label-bindings*) -(define *ic-procedure-headers*) - -(define (in-compiler thunk) - (fluid-let ((*expression*) - (*code-vector*) - (*entry-label*) - (*entry-points*) - (*label-bindings*) - (*ic-procedure-headers*)) - (thunk))) - -(define (compiler-phase name thunk) - (newline) - (display name) - (thunk)) - -(define (compiler-fasload file) - (fasload file)) \ No newline at end of file + (let ((bindings + (let ((code-vector (cc-vector/code-vector cc-vector)) + (label-bindings (cc-vector/label-bindings cc-vector))) + (map (lambda (label) + (cons + label + (with-absolutely-no-interrupts + (lambda () + ((ucode-primitive &make-object) + type-code:compiled-entry + (make-non-pointer-object + (+ (cdr (or (assq label label-bindings) + (error "Missing entry point" label))) + (object-datum code-vector)))))))) + (cc-vector/entry-points cc-vector))))) + (let ((label->expression + (lambda (label) + (cdr (or (assq label bindings) + (error "Label not defined as entry point" label)))))) + (let ((expression (label->expression (cc-vector/entry-label cc-vector)))) + (for-each (lambda (entry) + (set-lambda-body! (car entry) + (label->expression (cdr entry)))) + (cc-vector/ic-procedure-headers cc-vector)) + expression)))) + +(define type-code:compiled-entry + (microcode-type 'COMPILED-ENTRY)) \ No newline at end of file diff --git a/v7/src/compiler/base/crstop.scm b/v7/src/compiler/base/crstop.scm index c6c2fd412..dba1705a3 100644 --- a/v7/src/compiler/base/crstop.scm +++ b/v7/src/compiler/base/crstop.scm @@ -1,9 +1,9 @@ #| -*-Scheme-*- -$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 $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/crstop.scm,v 1.6 1990/01/18 22:42:42 cph Rel $ $MC68020-Header: toplev.scm,v 4.16 89/04/26 05:09:52 GMT cph Exp $ -Copyright (c) 1988, 1989 Massachusetts Institute of Technology +Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -62,10 +62,17 @@ MIT in each case. |# input-default)))) input-default (lambda (input-pathname output-pathname) - (cross-compile-scode (compiler-fasload input-pathname) - (and compiler:generate-rtl-files? - (pathname-new-type output-pathname "brtl.x")) - (pathname-new-type output-pathname "binf.x")))))) + (maybe-open-file compiler:generate-rtl-files? + (pathname-new-type output-pathname "rtl") + (lambda (rtl-output-port) + (maybe-open-file compiler:generate-lap-files? + (pathname-new-type output-pathname "lap") + (lambda (lap-output-port) + (cross-compile-scode (compiler-fasload input-pathname) + (pathname-new-type output-pathname + "binf.x") + rtl-output-port + lap-output-port))))))))) (define (cross-compile-bin-file-end input-string #!optional output-string) (compiler-pathnames @@ -82,46 +89,52 @@ MIT in each case. |# (cross-link-end cross-compilation) *result*))) -;; This should be merged with compile-scode +;;; This should be merged with compile-scode (define (cross-compile-scode scode #!optional - rtl-output-pathname info-output-pathname + rtl-output-port + lap-output-port wrapper) - - (if (default-object? rtl-output-pathname) - (set! rtl-output-pathname false)) - (if (default-object? info-output-pathname) - (set! info-output-pathname false)) - - (fluid-let ((*info-output-filename* - (if (pathname? info-output-pathname) - (pathname->string info-output-pathname) - *info-output-filename*)) - (*rtl-output-pathname* - (if (pathname? rtl-output-pathname) - rtl-output-pathname - *rtl-output-pathname*))) - ((if (default-object? wrapper) - in-compiler - wrapper) - (lambda () - (set! *input-scode* scode) - (phase/fg-generation) - (phase/fg-optimization) - (phase/rtl-generation) - (phase/rtl-optimization) - (if rtl-output-pathname - (phase/rtl-file-output rtl-output-pathname)) - (phase/bit-generation) - (phase/bit-linearization) - (phase/assemble) - (if info-output-pathname - (phase/info-generation-2 info-output-pathname)) - ;; Here is were this procedure differs from compile-scode - (phase/cross-link) - *result*)))) + (let ((info-output-pathname + (if (default-object? info-output-pathname) + false + info-output-pathname)) + (rtl-output-port + (if (default-object? rtl-output-port) false rtl-output-port)) + (lap-output-port + (if (default-object? lap-output-port) false lap-output-port)) + (wrapper + (if (default-object? wrapper) in-compiler wrapper))) + (fluid-let ((compiler:compile-by-procedures? false) + (*info-output-filename* + (if (pathname? info-output-pathname) + (pathname->string info-output-pathname) + *info-output-filename*)) + (*rtl-output-port* rtl-output-port) + (*lap-output-port* lap-output-port)) + ((if (default-object? wrapper) + in-compiler + wrapper) + (lambda () + (set! *input-scode* scode) + (phase/fg-generation) + (phase/fg-optimization) + (phase/rtl-generation) + (phase/rtl-optimization) + (if rtl-output-port + (phase/rtl-file-output rtl-output-port)) + (phase/lap-generation) + (phase/lap-linearization) + (if lap-output-port + (phase/lap-file-output lap-output-port)) + (phase/assemble) + (if info-output-pathname + (phase/info-generation-2 info-output-pathname)) + ;; Here is were this procedure differs from compile-scode + (phase/cross-link) + *result*))))) (define-structure (cc-vector (constructor cc-vector/make) (conc-name cc-vector/)) diff --git a/v7/src/compiler/base/debug.scm b/v7/src/compiler/base/debug.scm index 7b5bcad0d..105255d0b 100644 --- a/v7/src/compiler/base/debug.scm +++ b/v7/src/compiler/base/debug.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$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 $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/debug.scm,v 4.12 1990/01/18 22:42:45 cph Exp $ -Copyright (c) 1988, 1989 Massachusetts Institute of Technology +Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -82,32 +82,12 @@ MIT in each case. |# (else (error "debug/where -- what?" object)))) -(define (compiler:write-rtl-file input-path #!optional output-path) - (let ((input-path - (let ((input-path (->pathname input-path))) - (if (pathname-type input-path) - input-path - (pathname-new-type input-path "brtl"))))) - (let ((output-path - (let ((default (pathname-new-type input-path "rtl"))) - (if (default-object? output-path) - default - (merge-pathnames (->pathname output-path) default))))) - (write-instructions +(define (write-rtl-instructions rtl port) + (write-instructions + (lambda () + (with-output-to-port port (lambda () - (with-output-to-file output-path - (lambda () - (let ((rtl (fasload input-path))) - (if (vector? rtl) - (for-each (lambda (block) - (write-char #\page) - (newline) - (write-string "Disassembly for object ") - (write (car block)) - (for-each show-rtl-instruction (cdr block)) - (newline)) - (vector->list rtl)) - (for-each show-rtl-instruction rtl)))))))))) + (for-each show-rtl-instruction rtl)))))) (define (dump-rtl filename) (write-instructions @@ -117,11 +97,13 @@ MIT in each case. |# (for-each show-rtl-instruction (linearize-rtl *rtl-graphs*))))))) (define (show-rtl rtl) + (newline) (pp-instructions (lambda () (for-each show-rtl-instruction rtl)))) (define (show-bblock-rtl bblock) + (newline) (pp-instructions (lambda () (bblock-walk-forward (->tagged-vector bblock) @@ -129,12 +111,12 @@ MIT in each case. |# (show-rtl-instruction (rinst-rtl rinst))))))) (define (write-instructions thunk) - (fluid-let ((*show-instruction* write-line) + (fluid-let ((*show-instruction* write) (*unparser-radix* 16)) (thunk))) (define (pp-instructions thunk) - (fluid-let ((*show-instruction* pp) + (fluid-let ((*show-instruction* pretty-print) (*pp-primitives-by-name* false) (*unparser-radix* 16)) (thunk))) @@ -146,7 +128,8 @@ MIT in each case. |# '(LABEL CONTINUATION-ENTRY CONTINUATION-HEADER IC-PROCEDURE-HEADER OPEN-PROCEDURE-HEADER PROCEDURE-HEADER CLOSURE-HEADER)) (newline)) - (*show-instruction* rtl)) + (*show-instruction* rtl) + (newline)) (define procedure-queue) (define procedures-located) diff --git a/v7/src/compiler/base/macros.scm b/v7/src/compiler/base/macros.scm index 48eaa8785..1a36be969 100644 --- a/v7/src/compiler/base/macros.scm +++ b/v7/src/compiler/base/macros.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/macros.scm,v 4.9 1988/12/15 17:23:48 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/macros.scm,v 4.10 1990/01/18 22:42:49 cph Rel $ -Copyright (c) 1988 Massachusetts Institute of Technology +Copyright (c) 1988, 1990 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -65,7 +65,7 @@ MIT in each case. |# (PACKAGE ,transform/package))) (syntax-table-define lap-generator-syntax-table 'DEFINE-RULE transform/define-rule)) - + (define compiler-syntax-table (make-syntax-table syntax-table/system-internal)) @@ -122,8 +122,7 @@ MIT in each case. |# (VECTOR-REF ,class ,n)) (DEFINE-INTEGRABLE (,(symbol-append 'SET- ref-name '!) ,class ,slot) - (VECTOR-SET! ,class ,n ,slot) - ',unspecific))))) + (VECTOR-SET! ,class ,n ,slot)))))) (rest (loop (cdr slots) (1+ n)))) (if (pair? (car slots)) (map* rest make-defs (car slots)) @@ -210,8 +209,9 @@ MIT in each case. |# (define transform/define-rtl-statement) (define transform/define-rtl-predicate) (let ((rtl-common - (lambda (type prefix components wrap-constructor) + (lambda (type prefix components wrap-constructor types) `(BEGIN + (SET! ,types (CONS ',type ,types)) (DEFINE-INTEGRABLE (,(symbol-append prefix 'MAKE- type) ,@components) ,(wrap-constructor `(LIST ',type ,@components))) @@ -234,17 +234,21 @@ MIT in each case. |# (* set-index 2)))))))))) (set! transform/define-rtl-expression (macro (type prefix . components) - (rtl-common type prefix components identity-procedure))) + (rtl-common type prefix components + identity-procedure + 'RTL:EXPRESSION-TYPES))) (set! transform/define-rtl-statement (macro (type prefix . components) (rtl-common type prefix components - (lambda (expression) `(STATEMENT->SRTL ,expression))))) + (lambda (expression) `(STATEMENT->SRTL ,expression)) + 'RTL:STATEMENT-TYPES))) (set! transform/define-rtl-predicate (macro (type prefix . components) (rtl-common type prefix components - (lambda (expression) `(PREDICATE->PRTL ,expression)))))) + (lambda (expression) `(PREDICATE->PRTL ,expression)) + 'RTL:PREDICATE-TYPES)))) (define transform/define-rule (macro (type pattern . body) @@ -253,46 +257,26 @@ MIT in each case. |# `(,(case type ((STATEMENT) 'ADD-STATEMENT-RULE!) ((PREDICATE) 'ADD-STATEMENT-RULE!) - (else (error "Unknown rule type" type))) + ((REWRITING) 'ADD-REWRITING-RULE!) + (else type)) ',pattern ,(rule-result-expression variables qualifier `(BEGIN ,@actions))))))) ;;;; Lap instruction sequences. -;; The effect of unquote and unquote-splicing is the same since -;; syntax-instruction actually returns a bit-level instruction sequence. -;; Kept separate for clarity and because it does not have to be like that. - (define transform/lap (macro some-instructions - (define (handle current remaining) - (let ((processed - (cond ((eq? (car current) 'UNQUOTE) - (cadr current)) - ((eq? (car current) 'UNQUOTE-SPLICING) - (cadr current)) - (else `(INST ,current))))) - (if (null? remaining) - processed - `(APPEND-INSTRUCTION-SEQUENCES! - ,processed - ,(handle (car remaining) (cdr remaining)))))) - (if (null? some-instructions) - `EMPTY-INSTRUCTION-SEQUENCE - (handle (car some-instructions) (cdr some-instructions))))) + (list 'QUASIQUOTE some-instructions))) (define transform/inst (macro (the-instruction) - `(LAP:SYNTAX-INSTRUCTION - ,(list 'QUASIQUOTE the-instruction)))) - -;; This is a NOP for now. + (list 'QUASIQUOTE the-instruction))) (define transform/inst-ea (macro (ea) (list 'QUASIQUOTE ea))) - + (define transform/define-enumeration (macro (name elements) (let ((enumeration (symbol-append name 'S))) diff --git a/v7/src/compiler/base/switch.scm b/v7/src/compiler/base/switch.scm index a8b57ce60..0bab6e221 100644 --- a/v7/src/compiler/base/switch.scm +++ b/v7/src/compiler/base/switch.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/switch.scm,v 4.12 1989/09/05 22:33:50 arthur Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/switch.scm,v 4.13 1990/01/18 22:42:54 cph Exp $ -Copyright (c) 1988, 1989 Massachusetts Institute of Technology +Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -39,7 +39,7 @@ MIT in each case. |# ;;; Binary switches (define compiler:enable-integration-declarations? true) -(define compiler:enable-expansion-declarations? true) +(define compiler:enable-expansion-declarations? false) (define compiler:compile-by-procedures? true) (define compiler:show-time-reports? false) (define compiler:show-procedures? true) @@ -48,12 +48,13 @@ MIT in each case. |# (define compiler:preserve-data-structures? false) (define compiler:code-compression? true) (define compiler:cache-free-variables? true) -(define compiler:implicit-self-static? false) +(define compiler:implicit-self-static? true) (define compiler:optimize-environments? true) (define compiler:analyze-side-effects? true) (define compiler:cse? true) (define compiler:open-code-primitives? true) (define compiler:generate-rtl-files? false) +(define compiler:generate-lap-files? false) (define compiler:generate-range-checks? false) (define compiler:generate-type-checks? false) (define compiler:open-code-flonum-checks? false) diff --git a/v7/src/compiler/base/toplev.scm b/v7/src/compiler/base/toplev.scm index 6c399266a..e3ccbd5c7 100644 --- a/v7/src/compiler/base/toplev.scm +++ b/v7/src/compiler/base/toplev.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/toplev.scm,v 4.24 1989/12/02 05:03:24 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/toplev.scm,v 4.25 1990/01/18 22:42:58 cph Exp $ -Copyright (c) 1988, 1989 Massachusetts Institute of Technology +Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -59,12 +59,23 @@ MIT in each case. |# (and (not (default-object? output-string)) output-string) (make-pathname false false false false "bin" 'NEWEST) (lambda (input-pathname output-pathname) - (compile-scode (compiler-fasload input-pathname) - (and compiler:generate-rtl-files? - (pathname-new-type output-pathname "brtl")) - (pathname-new-type output-pathname "binf")))) + (maybe-open-file compiler:generate-rtl-files? + (pathname-new-type output-pathname "rtl") + (lambda (rtl-output-port) + (maybe-open-file compiler:generate-lap-files? + (pathname-new-type output-pathname "lap") + (lambda (lap-output-port) + (compile-scode (compiler-fasload input-pathname) + (pathname-new-type output-pathname "binf") + rtl-output-port + lap-output-port))))))) unspecific) +(define (maybe-open-file open? pathname receiver) + (if open? + (call-with-output-file pathname receiver) + (receiver false))) + (define (compiler-pathnames input-string output-string default transform) (let* ((core (lambda (input-string) @@ -116,7 +127,7 @@ MIT in each case. |# ;;;; Alternate Entry Points (define (compile-procedure procedure) - (scode-eval (compile-scode (procedure-lambda procedure) false false) + (scode-eval (compile-scode (procedure-lambda procedure)) (procedure-environment procedure))) (define (compiler:batch-compile input #!optional output) @@ -153,6 +164,49 @@ MIT in each case. |# (define compiler:abort-handled? false) (define compiler:abort-continuation) +;;; Example of `lap->code' usage: + +#| +(define bar + ;; defines bar to be a procedure that adds 1 to its argument + ;; with no type or range checks. + (scode-eval + (lap->code + 'start + `((pea (@pcr proc)) + (or b (& ,(* (microcode-type 'compiled-entry) 4)) (@a 7)) + (mov l (@a+ 7) (@ao 6 8)) + (and b (& #x3) (@a 7)) + (rts) + (dc uw #x0202) + (block-offset proc) + (label proc) + (mov l (@a+ 7) (d 0)) + (addq l (& 1) (d 0)) + (mov l (d 0) (@ao 6 8)) + (and b (& #x3) (@a 7)) + (rts))) + '())) +|# + +(define (lap->code label lap) + (in-compiler + (lambda () + (set! *lap* lap) + (set! *entry-label* label) + (set! *current-label-number* 0) + (set! *next-constant* 0) + (set! *interned-constants* '()) + (set! *interned-variables* '()) + (set! *interned-assignments* '()) + (set! *interned-uuo-links* '()) + (set! *block-label* (generate-label)) + (set! *external-labels* '()) + (set! *ic-procedure-headers* '()) + (phase/assemble) + (phase/link) + *result*))) + (define (compile-recursively scode procedure-result?) ;; Used by the compiler when it wants to compile subexpressions as ;; separate code-blocks. @@ -177,8 +231,9 @@ MIT in each case. |# (compiler:package-optimization-level 'NONE) (*procedure-result?* procedure-result?)) (compile-scode scode - (and *rtl-output-pathname* true) (and *info-output-filename* true) + *rtl-output-port* + *lap-output-port* bind-compiler-variables))))) (if procedure-result? (let ((do-it @@ -213,14 +268,14 @@ MIT in each case. |# (define *recursive-compilation-count*) (define *recursive-compilation-number*) (define *recursive-compilation-results*) -(define *recursive-compilation-rtl-blocks*) (define *procedure-result?*) (define *remote-links*) (define *process-time*) (define *real-time*) (define *info-output-filename* false) -(define *rtl-output-pathname* false) +(define *rtl-output-port* false) +(define *lap-output-port* false) ;; First set: input to compilation ;; Last used: phase/canonicalize-scode @@ -240,7 +295,7 @@ MIT in each case. |# (define *root-procedure*) ;; First set: phase/rtl-generation -;; Last used: phase/bit-linearization +;; Last used: phase/lap-linearization (define *rtl-expression*) (define *rtl-procedures*) (define *rtl-continuations*) @@ -254,19 +309,19 @@ MIT in each case. |# (define *entry-label*) (define *block-label*) -;; First set: phase/bit-generation +;; First set: phase/lap-generation ;; Last used: phase/info-generation-2 (define *external-labels*) -;; First set: phase/bit-generation +;; First set: phase/lap-generation ;; Last used: phase/link (define *subprocedure-linking-info*) -;; First set: phase/bit-linearization +;; First set: phase/lap-linearization ;; Last used: phase/assemble -(define *bits*) +(define *lap*) -;; First set: phase/bit-linearization +;; First set: phase/lap-linearization ;; Last used: phase/info-generation-2 (define *dbg-expression*) (define *dbg-procedures*) @@ -287,25 +342,30 @@ MIT in each case. |# (lambda () (let ((value (let ((expression (thunk))) - (let ((others (recursive-compilation-results))) - (if (null? others) - expression - (scode/make-comment - (make-dbg-info-vector - (let* ((others - (map (lambda (other) (vector-ref other 2)) - others)) - (all-blocks - (list->vector - (cons - (compiled-code-address->block expression) - others)))) - (if compiler:compile-by-procedures? - (list 'COMPILED-BY-PROCEDURES - all-blocks - (list->vector others)) - all-blocks))) - expression)))))) + (let ((others + (map (lambda (other) (vector-ref other 2)) + (recursive-compilation-results)))) + (cond ((not (compiled-code-address? expression)) + (vector compiler:compile-by-procedures? + expression + others)) + ((null? others) + expression) + (else + (scode/make-comment + (make-dbg-info-vector + (let ((all-blocks + (list->vector + (cons + (compiled-code-address->block + expression) + others)))) + (if compiler:compile-by-procedures? + (list 'COMPILED-BY-PROCEDURES + all-blocks + (list->vector others)) + all-blocks))) + expression))))))) (compiler-time-report "Total compilation time" *process-time* *real-time*) @@ -317,7 +377,6 @@ MIT in each case. |# (fluid-let ((*recursive-compilation-number* 0) (*recursive-compilation-count* 1) (*recursive-compilation-results* '()) - (*recursive-compilation-rtl-blocks* '()) (*procedure-result?* false) (*remote-links* '()) (*process-time* 0) @@ -333,7 +392,7 @@ MIT in each case. |# (*dbg-expression*) (*dbg-procedures*) (*dbg-continuations*) - (*bits*) + (*lap*) (*next-constant*) (*interned-constants*) (*interned-variables*) @@ -374,7 +433,6 @@ MIT in each case. |# (set! *recursive-compilation-number* 0) (set! *recursive-compilation-count* 1) (set! *recursive-compilation-results* '()) - (set! *recursive-compilation-rtl-blocks* '()) (set! *procedure-result?* false) (set! *remote-links* '()) (set! *process-time* 0) @@ -387,7 +445,7 @@ MIT in each case. |# (set! *dbg-expression*) (set! *dbg-procedures*) (set! *dbg-continuations*) - (set! *bits*) + (set! *lap*) (set! *next-constant*) (set! *interned-constants*) (set! *interned-variables*) @@ -424,27 +482,26 @@ MIT in each case. |# (define (compile-scode scode #!optional - rtl-output-pathname info-output-pathname + rtl-output-port + lap-output-port wrapper) - (let ((rtl-output-pathname - (if (default-object? rtl-output-pathname) - false - rtl-output-pathname)) - (info-output-pathname + (let ((info-output-pathname (if (default-object? info-output-pathname) false info-output-pathname)) + (rtl-output-port + (if (default-object? rtl-output-port) false rtl-output-port)) + (lap-output-port + (if (default-object? lap-output-port) false lap-output-port)) (wrapper (if (default-object? wrapper) in-compiler wrapper))) (fluid-let ((*info-output-filename* (if (pathname? info-output-pathname) (pathname->string info-output-pathname) *info-output-filename*)) - (*rtl-output-pathname* - (if (pathname? rtl-output-pathname) - rtl-output-pathname - *rtl-output-pathname*))) + (*rtl-output-port* rtl-output-port) + (*lap-output-port* lap-output-port)) (wrapper (lambda () (set! *input-scode* scode) @@ -457,10 +514,12 @@ MIT in each case. |# (phase/info-generation-1 info-output-pathname)) |# (phase/rtl-optimization) - (if rtl-output-pathname - (phase/rtl-file-output rtl-output-pathname)) - (phase/bit-generation) - (phase/bit-linearization) + (if rtl-output-port + (phase/rtl-file-output rtl-output-port)) + (phase/lap-generation) + (phase/lap-linearization) + (if lap-output-port + (phase/lap-file-output lap-output-port)) (phase/assemble) (if info-output-pathname (phase/info-generation-2 info-output-pathname)) @@ -774,15 +833,19 @@ MIT in each case. |# (write-string " max, ") (write (apply min n-registers)) (write-string " min, ") - (write (/ (apply + n-registers) (length n-registers))) + (write + (exact->inexact (/ (apply + n-registers) (length n-registers)))) (write-string " mean")))))) (define (phase/rtl-optimization) (compiler-superphase "RTL Optimization" (lambda () + (phase/rtl-dataflow-analysis) + (phase/rtl-rewriting rtl-rewriting:pre-cse) (if compiler:cse? (phase/common-subexpression-elimination)) (phase/invertible-expression-elimination) + (phase/rtl-rewriting rtl-rewriting:post-cse) (phase/common-suffix-merging) (phase/lifetime-analysis) (if compiler:code-compression? @@ -790,6 +853,16 @@ MIT in each case. |# (phase/linearization-analysis) (phase/register-allocation) (phase/rtl-optimization-cleanup)))) + +(define (phase/rtl-dataflow-analysis) + (compiler-subphase "RTL Dataflow Analysis" + (lambda () + (rtl-dataflow-analysis *rtl-graphs*)))) + +(define (phase/rtl-rewriting rtl-rewriting) + (compiler-subphase "RTL Rewriting" + (lambda () + (rtl-rewriting *rtl-graphs*)))) (define (phase/common-subexpression-elimination) (compiler-subphase "Common Subexpression Elimination" @@ -800,7 +873,7 @@ MIT in each case. |# (compiler-subphase "Invertible Expression Elimination" (lambda () (invertible-expression-elimination *rtl-graphs*)))) - + (define (phase/common-suffix-merging) (compiler-subphase "Common Suffix Merging" (lambda () @@ -835,31 +908,26 @@ MIT in each case. |# (set-rgraph-register-crosses-call?! rgraph false) (set-rgraph-register-n-deaths! rgraph false) (set-rgraph-register-live-length! rgraph false) - (set-rgraph-register-n-refs! rgraph false)) + (set-rgraph-register-n-refs! rgraph false) + (set-rgraph-register-known-values! rgraph false)) *rtl-graphs*))) -(define (phase/rtl-file-output pathname) +(define (phase/rtl-file-output port) (compiler-phase "RTL File Output" (lambda () - (let ((rtl - (linearize-rtl *rtl-root* - *rtl-procedures* - *rtl-continuations*))) - (if (eq? pathname true) - ;; recursive compilation - (begin - (set! *recursive-compilation-rtl-blocks* - (cons (cons *recursive-compilation-number* rtl) - *recursive-compilation-rtl-blocks*)) - unspecific) - (fasdump (if (null? *recursive-compilation-rtl-blocks*) - rtl - (list->vector - (cons (cons 0 rtl) - *recursive-compilation-rtl-blocks*))) - pathname)))))) + (write-string "RTL for object " port) + (write *recursive-compilation-number* port) + (newline port) + (write-rtl-instructions (linearize-rtl *rtl-root* + *rtl-procedures* + *rtl-continuations*) + port) + (if (not (zero? *recursive-compilation-number*)) + (begin + (write-char #\page port) + (newline port)))))) -(define (phase/bit-generation) +(define (phase/lap-generation) (compiler-phase "LAP Generation" (lambda () (set! *next-constant* 0) @@ -870,7 +938,7 @@ MIT in each case. |# (set! *block-label* (generate-label)) (set! *external-labels* '()) (if *procedure-result?* - (generate-bits *rtl-graphs* '() + (generate-lap *rtl-graphs* '() (lambda (prefix environment-label free-ref-label n-sections) (node-insert-snode! (rtl-procedure/entry-node *rtl-root*) (make-sblock prefix)) @@ -880,23 +948,22 @@ MIT in each case. |# (vector environment-label free-ref-label n-sections)) unspecific)) (begin - (let ((prefix (generate-bits *rtl-graphs* *remote-links* false))) + (let ((prefix (generate-lap *rtl-graphs* *remote-links* false))) (node-insert-snode! (rtl-expr/entry-node *rtl-root*) (make-sblock prefix))) (set! *entry-label* (rtl-expr/label *rtl-root*)) unspecific))))) -(define (phase/bit-linearization) +(define (phase/lap-linearization) (compiler-phase "LAP Linearization" (lambda () - (set! *bits* - (append-instruction-sequences! - (if *procedure-result?* - (LAP (ENTRY-POINT ,*entry-label*)) - (lap:make-entry-point *entry-label* *block-label*)) - (linearize-bits *rtl-root* - *rtl-procedures* - *rtl-continuations*))) + (set! *lap* + (LAP ,@(if *procedure-result?* + (LAP (ENTRY-POINT ,*entry-label*)) + (lap:make-entry-point *entry-label* *block-label*)) + ,@(linearize-lap *rtl-root* + *rtl-procedures* + *rtl-continuations*))) (with-values (lambda () (info-generation-phase-2 *rtl-expression* @@ -917,10 +984,37 @@ MIT in each case. |# (set! *rtl-root*) unspecific))))) +(define (phase/lap-file-output port) + (compiler-phase "LAP File Output" + (lambda () + (fluid-let ((*unparser-radix* 16) + (*unparse-uninterned-symbols-by-name?* true)) + (with-output-to-port port + (lambda () + (write-string "LAP for object ") + (write *recursive-compilation-number*) + (newline) + (newline) + (for-each (lambda (instruction) + (if (and (pair? instruction) + (eq? (car instruction) 'LABEL)) + (begin + (write (cadr instruction)) + (write-char #\:)) + (begin + (write-char #\tab) + (write instruction))) + (newline)) + *lap*) + (if (not (zero? *recursive-compilation-number*)) + (begin + (write-char #\page) + (newline))))))))) + (define (phase/assemble) (compiler-phase "Assembly" (lambda () - (assemble *block-label* (last-reference *bits*) + (with-values (lambda () (assemble *block-label* (last-reference *lap*))) (lambda (count code-vector labels bindings linkage-info) linkage-info ;ignored (set! *code-vector* code-vector) diff --git a/v7/src/compiler/fgopt/subfre.scm b/v7/src/compiler/fgopt/subfre.scm index 4f0af9e33..2424ed458 100644 --- a/v7/src/compiler/fgopt/subfre.scm +++ b/v7/src/compiler/fgopt/subfre.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$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 $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/subfre.scm,v 1.4 1990/01/18 22:44:38 cph Exp $ -Copyright (c) 1988, 1989 Massachusetts Institute of Technology +Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -37,38 +37,102 @@ MIT in each case. |# (declare (usual-integrations)) (define (compute-subproblem-free-variables parallels) - (for-each (lambda (parallel) - (for-each (lambda (subproblem) - (set-subproblem-free-variables! subproblem 'UNKNOWN)) - (parallel-subproblems parallel))) - parallels) - (for-each (lambda (parallel) - (for-each walk-subproblem (parallel-subproblems parallel))) - parallels)) + (with-analysis-state + (lambda () + (for-each (lambda (parallel) + (for-each (lambda (subproblem) + (set-subproblem-free-variables! subproblem 'UNKNOWN)) + (parallel-subproblems parallel))) + parallels) + (for-each (lambda (parallel) + (for-each walk-subproblem (parallel-subproblems parallel))) + parallels)))) (define (new-subproblem/compute-free-variables! subproblem) - (walk-subproblem subproblem)) + (with-analysis-state (lambda () (walk-subproblem subproblem)))) (define (walk-subproblem subproblem) (let ((free (subproblem-free-variables subproblem))) - (if (eq? free 'UNKNOWN) - (let ((free - (let ((free (walk-rvalue (subproblem-rvalue subproblem)))) - (if (subproblem-canonical? subproblem) - (eq-set-union - free - (walk-node (subproblem-entry-node subproblem))) - free)))) - (set-subproblem-free-variables! subproblem free) - free) - free))) + (case free + ((UNKNOWN) + (set-subproblem-free-variables! subproblem 'BEING-COMPUTED) + (let ((free + (let ((free (walk-rvalue (subproblem-rvalue subproblem)))) + (if (subproblem-canonical? subproblem) + (eq-set-union + free + (walk-node (subproblem-entry-node subproblem))) + free)))) + (set-subproblem-free-variables! subproblem free) + free)) + ((BEING-COMPUTED) + (error "loop in subproblem free-variable analysis" subproblem)) + (else + free)))) -(define (walk-next next free) - (if next - (eq-set-union (walk-node next) free) - free)) +(define (walk-operator rvalue) + (enumeration-case rvalue-type (tagged-vector/index rvalue) + ((REFERENCE) (walk-lvalue (reference-lvalue rvalue) walk-operator)) + ((PROCEDURE) + (if (procedure-continuation? rvalue) + (walk-next (continuation/entry-node rvalue) '()) + (map-union (lambda (procedure) + (list-transform-negative + (block-free-variables (procedure-block procedure)) + lvalue-integrated?)) + (eq-set-union (list rvalue) + (procedure-callees rvalue))))) + (else '()))) + +(define (walk-rvalue rvalue) + (enumeration-case rvalue-type (tagged-vector/index rvalue) + ((REFERENCE) (walk-lvalue (reference-lvalue rvalue) walk-rvalue)) + ((PROCEDURE) + (if (procedure-continuation? rvalue) + (walk-next (continuation/entry-node rvalue) '()) + (list-transform-negative + (block-free-variables (procedure-block rvalue)) + lvalue-integrated?))) + (else '()))) + +(define (walk-lvalue lvalue walk-rvalue) + (let ((value (lvalue-known-value lvalue))) + (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))))) + +(define *nodes*) + +(define free-variables-tag + "free-variables-tag") + +(define (with-analysis-state thunk) + (fluid-let ((*nodes* '())) + (let ((value (with-new-node-marks thunk))) + (for-each (lambda (node) (cfg-node-remove! node free-variables-tag)) + *nodes*) + value))) (define (walk-node node) + (if (node-marked? node) + (let ((free (cfg-node-get node free-variables-tag))) + (if (eq? free 'BEING-COMPUTED) + (error "loop in node free-variable analysis" node)) + free) + (begin + (node-mark! node) + (set! *nodes* (cons node *nodes*)) + (cfg-node-put! node free-variables-tag 'BEING-COMPUTED) + (let ((free (walk-node-no-memoize node))) + (cfg-node-put! node free-variables-tag free) + free)))) + +(define (walk-node-no-memoize node) (cfg-node-case (tagged-vector/tag node) ((PARALLEL) (walk-next (snode-next node) @@ -106,46 +170,17 @@ MIT in each case. |# (walk-rvalue (true-test-rvalue node))))) ((FG-NOOP) (walk-next (snode-next node) '())))) - -(define (map-union procedure items) - (let loop ((items items) (set '())) - (if (null? items) - set - (loop (cdr items) - (eq-set-union (procedure (car items)) set))))) - -(define (walk-operator rvalue) - (enumeration-case rvalue-type (tagged-vector/index rvalue) - ((REFERENCE) (walk-lvalue (reference-lvalue rvalue) walk-operator)) - ((PROCEDURE) - (if (procedure-continuation? rvalue) - (walk-next (continuation/entry-node rvalue) '()) - (map-union (lambda (procedure) - (list-transform-negative - (block-free-variables (procedure-block procedure)) - lvalue-integrated?)) - (eq-set-union (list rvalue) - (procedure-callees rvalue))))) - (else '()))) -(define (walk-rvalue rvalue) - (enumeration-case rvalue-type (tagged-vector/index rvalue) - ((REFERENCE) (walk-lvalue (reference-lvalue rvalue) walk-rvalue)) - ((PROCEDURE) - (if (procedure-continuation? rvalue) - (walk-next (continuation/entry-node rvalue) '()) - (list-transform-negative - (block-free-variables (procedure-block rvalue)) - lvalue-integrated?))) - (else '()))) +(define (walk-next next free) + (if next + (eq-set-union (walk-node next) free) + free)) -(define (walk-lvalue lvalue walk-rvalue) - (let ((value (lvalue-known-value lvalue))) - (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 +(define (map-union procedure items) + (if (null? items) + '() + (let loop ((items (cdr items)) (set (procedure (car items)))) + (if (null? items) + set + (loop (cdr items) + (eq-set-union (procedure (car items)) set)))))) \ 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 c49909086..863d74348 100644 --- a/v7/src/compiler/machines/bobcat/compiler.pkg +++ b/v7/src/compiler/machines/bobcat/compiler.pkg @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$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 $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/compiler.pkg,v 1.26 1990/01/18 22:43:21 cph Exp $ -Copyright (c) 1988, 1989 Massachusetts Institute of Technology +Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -84,6 +84,7 @@ MIT in each case. |# compiler:default-top-level-declarations compiler:enable-expansion-declarations? compiler:enable-integration-declarations? + compiler:generate-lap-files? compiler:generate-range-checks? compiler:generate-rtl-files? compiler:generate-type-checks? @@ -173,13 +174,14 @@ MIT in each case. |# *rtl-procedures* *rtl-graphs*) (import (runtime compiler-info) - make-dbg-info-vector)) + make-dbg-info-vector) + (import (runtime unparser) + *unparse-uninterned-symbols-by-name?*)) (define-package (compiler debug) (files "base/debug") (parent (compiler)) (export () - compiler:write-rtl-file debug/find-continuation debug/find-entry-node debug/find-procedure @@ -189,7 +191,8 @@ MIT in each case. |# show-bblock-rtl show-fg show-fg-node - show-rtl) + show-rtl + write-rtl-instructions) (import (runtime pretty-printer) *pp-primitives-by-name*)) @@ -466,10 +469,6 @@ MIT in each case. |# (files "rtlgen/opncod") (parent (compiler rtl-generator)) (export (compiler rtl-generator) combination/inline) - (export (compiler fg-optimizer simplicity-analysis) - combination/inline/simple?) - (export (compiler fg-optimizer subproblem-ordering parameter-analysis) - combination/inline/simple?) (export (compiler top-level) open-coding-analysis)) (define-package (compiler rtl-generator find-block) @@ -529,6 +528,19 @@ MIT in each case. |# (parent (compiler rtl-optimizer)) (export (compiler top-level) merge-common-suffixes!)) +(define-package (compiler rtl-optimizer rtl-dataflow-analysis) + (files "rtlopt/rdflow") + (parent (compiler rtl-optimizer)) + (export (compiler top-level) rtl-dataflow-analysis)) + +(define-package (compiler rtl-optimizer rtl-rewriting) + (files "rtlopt/rerite") + (parent (compiler rtl-optimizer)) + (export (compiler top-level) + rtl-rewriting:post-cse + rtl-rewriting:pre-cse) + (export (compiler lap-syntaxer) add-rewriting-rule!)) + (define-package (compiler rtl-optimizer lifetime-analysis) (files "rtlopt/rlife") (parent (compiler rtl-optimizer)) @@ -536,7 +548,7 @@ MIT in each case. |# (export (compiler rtl-optimizer code-compression) mark-set-registers!)) (define-package (compiler rtl-optimizer code-compression) - (files "rtlopt/rdeath") + (files "rtlopt/rcompr") (parent (compiler rtl-optimizer)) (export (compiler top-level) code-compression)) @@ -555,6 +567,7 @@ MIT in each case. |# "machines/bobcat/rules2" ; " " " "machines/bobcat/rules3" ; " " " "machines/bobcat/rules4" ; " " " + "machines/bobcat/rulrew" ;code rewriting rules "back/syntax" ;Generic syntax phase "back/syerly" ;Early binding version "machines/bobcat/coerce" ;Coercions: integer -> bit string @@ -582,7 +595,7 @@ MIT in each case. |# *interned-uuo-links* *interned-variables* *next-constant* - generate-bits) + generate-lap) (import (scode-optimizer expansion) scode->scode-expander)) @@ -596,10 +609,10 @@ MIT in each case. |# (files "back/linear") (parent (compiler lap-syntaxer)) (export (compiler lap-syntaxer) - linearize-bits - bblock-linearize-bits) + linearize-lap + bblock-linearize-lap) (export (compiler top-level) - linearize-bits)) + linearize-lap)) (define-package (compiler assembler) (files "machines/bobcat/assmd" ;Machine dependent diff --git a/v7/src/compiler/machines/bobcat/compiler.sf b/v7/src/compiler/machines/bobcat/compiler.sf index c620afec7..222a79938 100644 --- a/v7/src/compiler/machines/bobcat/compiler.sf +++ b/v7/src/compiler/machines/bobcat/compiler.sf @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/compiler.sf,v 1.11 1989/08/28 18:33:37 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/compiler.sf,v 1.12 1990/01/18 22:43:26 cph Rel $ -Copyright (c) 1988, 1989 Massachusetts Institute of Technology +Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -105,6 +105,6 @@ MIT in each case. |# ((access syntax-files! (->environment '(COMPILER)))) ;; Rebuild the package constructors and cref. -(cref/generate-constructors "comp") +(cref/generate-all "comp") (sf "comp.con" "comp.bcon") (sf "comp.ldr" "comp.bldr") \ No newline at end of file diff --git a/v7/src/compiler/machines/bobcat/decls.scm b/v7/src/compiler/machines/bobcat/decls.scm index 23df8b128..2a77bf34d 100644 --- a/v7/src/compiler/machines/bobcat/decls.scm +++ b/v7/src/compiler/machines/bobcat/decls.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$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 $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/decls.scm,v 4.25 1990/01/18 22:43:31 cph Exp $ -Copyright (c) 1988, 1989 Massachusetts Institute of Technology +Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -341,7 +341,7 @@ MIT in each case. |# "lapgn2" "lapgn3" "linear" "regmap" "symtab" "syntax") (filename/append "machines/bobcat" - "dassm1" "insmac" "machin" "rgspcm") + "dassm1" "insmac" "machin" "rgspcm" "rulrew") (filename/append "fggen" "declar" "fggen" "canon") (filename/append "fgopt" @@ -357,9 +357,9 @@ MIT in each case. |# "fndblk" "fndvar" "opncod" "rgcomb" "rgproc" "rgretn" "rgrval" "rgstmt" "rtlgen") (filename/append "rtlopt" - "ralloc" "rcse1" "rcse2" "rcseep" "rcseht" - "rcserq" "rcsesr" "rdeath" "rdebug" "rinvex" - "rlife" "rtlcsm")) + "ralloc" "rcompr" "rcse1" "rcse2" "rcseep" + "rcseht" "rcserq" "rcsesr" "rdebug" "rdflow" + "rerite" "rinvex" "rlife" "rtlcsm")) compiler-syntax-table) (file-dependency/syntax/join (filename/append "machines/bobcat" @@ -394,23 +394,22 @@ MIT in each case. |# (filename/append "machines/bobcat" "machin")) (rtl-base (filename/append "rtlbase" - "regset" "rgraph" "rtlcfg" "rtlexp" "rtlobj" - "rtlreg" "rtlty1" "rtlty2" "valclass")) + "regset" "rgraph" "rtlcfg" "rtlobj" + "rtlreg" "rtlty1" "rtlty2")) (cse-base (filename/append "rtlopt" "rcse1" "rcse2" "rcseep" "rcseht" "rcserq" "rcsesr")) (instruction-base - (append (filename/append "back" "insseq") - (filename/append "machines/bobcat" "assmd" "machin"))) + (filename/append "machines/bobcat" "assmd" "machin")) (lapgen-base - (append (filename/append "back" "lapgn2" "lapgn3" "regmap") + (append (filename/append "back" "lapgn3" "regmap") (filename/append "machines/bobcat" "lapgen"))) (assembler-base - (append (filename/append "back" "bitutl" "symtab") + (append (filename/append "back" "symtab") (filename/append "machines/bobcat" "insutl"))) (lapgen-body (append - (filename/append "back" "lapgn1" "syntax") + (filename/append "back" "lapgn1" "lapgn2" "syntax") (filename/append "machines/bobcat" "rules1" "rules2" "rules3" "rules4"))) (assembler-body @@ -473,8 +472,8 @@ MIT in each case. |# (define-integration-dependencies "rtlbase" "rtlcon" "base" "cfg3" "utils") (define-integration-dependencies "rtlbase" "rtlcon" "machines/bobcat" "machin") - (define-integration-dependencies "rtlbase" "rtlexp" "base" "utils") - (define-integration-dependencies "rtlbase" "rtlexp" "rtlbase" "rtlreg") + (define-integration-dependencies "rtlbase" "rtlexp" "rtlbase" + "rtlreg" "rtlty1") (define-integration-dependencies "rtlbase" "rtline" "base" "cfg1" "cfg2") (define-integration-dependencies "rtlbase" "rtline" "rtlbase" "rtlcfg" "rtlty2") @@ -489,8 +488,6 @@ MIT in each case. |# (define-integration-dependencies "rtlbase" "rtlty2" "machines/bobcat" "machin") (define-integration-dependencies "rtlbase" "rtlty2" "rtlbase" "rtlty1") - (define-integration-dependencies "rtlbase" "valclass" "rtlbase" - "rtlty1" "rtlty2" "rtlreg") (file-dependency/integration/join (append @@ -514,8 +511,9 @@ MIT in each case. |# (file-dependency/integration/join (append cse-base - (filename/append "rtlopt" "ralloc" "rdeath" "rdebug" "rinvex" - "rlife" "rtlcsm")) + (filename/append "rtlopt" "ralloc" "rcompr" "rdebug" "rdflow" + "rerite" "rinvex" "rlife" "rtlcsm") + (filename/append "machines/bobcat" "rulrew")) (append bobcat-base rtl-base)) (file-dependency/integration/join cse-base cse-base) diff --git a/v7/src/compiler/machines/bobcat/lapgen.scm b/v7/src/compiler/machines/bobcat/lapgen.scm index e83067c69..93e319b51 100644 --- a/v7/src/compiler/machines/bobcat/lapgen.scm +++ b/v7/src/compiler/machines/bobcat/lapgen.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/lapgen.scm,v 4.25 1989/12/11 06:16:46 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/lapgen.scm,v 4.26 1990/01/18 22:43:36 cph Exp $ -Copyright (c) 1988, 1989 Massachusetts Institute of Technology +Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -36,7 +36,7 @@ MIT in each case. |# (declare (usual-integrations)) -;;;; Basic machine instructions +;;;; Register-Allocator Interface (define (reference->register-transfer source target) (if (or (and (effective-address/data-register? source) @@ -44,7 +44,7 @@ MIT in each case. |# (and (effective-address/address-register? source) (= (+ 8 (lap:ea-operand-1 source)) target))) (LAP) - (memory->machine-register source target))) + (LAP ,(memory->machine-register source target)))) (define (register->register-transfer source target) (LAP ,(machine->machine-register source target))) @@ -55,6 +55,54 @@ MIT in each case. |# (define (register->home-transfer source target) (LAP ,(machine->pseudo-register source target))) +(define (pseudo-register-home register) + (offset-reference regnum:regs-pointer (pseudo-register-offset register))) + +(define (sort-machine-registers registers) + registers) + +(define available-machine-registers + (list d0 d1 d2 d3 d4 d5 d6 + a0 a1 a2 a3 + fp0 fp1 fp2 fp3 fp4 fp5 fp6 fp7)) + +(define (register-types-compatible? type1 type2) + (boolean=? (eq? type1 'FLOAT) (eq? type2 'FLOAT))) + +(define (register-type register) + (cond ((machine-register? register) + (vector-ref + '#(DATA DATA DATA DATA DATA DATA DATA DATA + ADDRESS ADDRESS ADDRESS ADDRESS ADDRESS ADDRESS ADDRESS ADDRESS + FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT) + register)) + ((register-value-class=word? register) + (if (register-value-class=address? register) + 'ADDRESS + 'DATA)) + ((register-value-class=float? register) + 'FLOAT) + (else + (error "unable to determine register type" register)))) + +(define register-reference + (let ((references (make-vector number-of-machine-registers))) + (let loop ((i 0) (j 8)) + (if (< i 8) + (begin + (vector-set! references i (INST-EA (D ,i))) + (vector-set! references j (INST-EA (A ,i))) + (loop (1+ i) (1+ j))))) + (subvector-move-right! '#(FP0 FP1 FP2 FP3 FP4 FP5 FP6 FP7) 0 8 + references 16) + (lambda (register) + (vector-ref references register)))) + +(define mask-reference + (register-reference 7)) + +;;;; Basic Machine Instructions + (define-integrable (pseudo->machine-register source target) (memory->machine-register (pseudo-register-home source) target)) @@ -66,9 +114,13 @@ MIT in each case. |# (+ (+ (* 16 4) (* 40 8)) (* 3 (register-renumber register)))) -(define-integrable (pseudo-register-home register) - (offset-reference regnum:regs-pointer - (pseudo-register-offset register))) +(define (pseudo-float? register) + (and (pseudo-register? register) + (value-class=float? (pseudo-register-value-class register)))) + +(define (pseudo-word? register) + (and (pseudo-register? register) + (value-class=word? (pseudo-register-value-class register)))) (define (machine->machine-register source target) (if (not (register-types-compatible? source target)) @@ -90,26 +142,17 @@ MIT in each case. |# (INST (FMOVE D ,source ,(register-reference target))) (INST (MOV L ,source ,(register-reference target))))) -(package (offset-reference byte-offset-reference) +(define (offset-reference register offset) + (byte-offset-reference register (* 4 offset))) -(define ((make-offset-reference grain-size) register offset) +(define (byte-offset-reference register offset) (if (zero? offset) (if (< register 8) (INST-EA (@D ,register)) (INST-EA (@A ,(- register 8)))) (if (< register 8) - (INST-EA (@DO ,register ,(* grain-size offset))) - (INST-EA (@AO ,(- register 8) ,(* grain-size offset)))))) - -(define-export offset-reference - (make-offset-reference - (quotient scheme-object-width addressing-granularity))) - -(define-export byte-offset-reference - (make-offset-reference - (quotient 8 addressing-granularity))) - -) + (INST-EA (@DO ,register ,offset)) + (INST-EA (@AO ,(- register 8) ,offset))))) (define (load-dnl n d) (cond ((zero? n) @@ -156,18 +199,22 @@ MIT in each case. |# target)) (define (load-non-pointer type datum target) - (cond ((not (zero? type)) - (INST (MOV UL - (& ,(make-non-pointer-literal type datum)) - ,target))) - ((and (zero? datum) + (load-machine-constant (make-non-pointer-literal type datum) target)) + +(define (load-machine-constant n target) + (cond ((and (zero? n) (effective-address/data&alterable? target)) (INST (CLR L ,target))) - ((and (<= -128 datum 127) + ((and (<= -128 n 127) (effective-address/data-register? target)) - (INST (MOVEQ (& ,datum) ,target))) + (INST (MOVEQ (& ,n) ,target))) (else - (INST (MOV UL (& ,datum) ,target))))) + (INST (MOV UL (& ,n) ,target))))) + +(define (memory-set-type type target) + (if (= 8 scheme-type-width) + (INST (MOV B (& ,type) ,target)) + (INST (OR B (& ,(* type-scale-factor type)) ,target)))) (define (test-byte n effective-address) ;; This is used to test actual bytes. @@ -189,13 +236,6 @@ MIT in each case. |# (INST (CMPI L (& ,(make-non-pointer-literal type datum)) ,effective-address)))) - -(define make-non-pointer-literal - (let ((type-scale-factor (expt 2 scheme-datum-width))) - (lambda (type datum) - (if (negative? datum) - (error "Non-pointer datum must be nonnegative" datum)) - (+ (* type type-scale-factor) datum)))) (define (set-standard-branches! cc) (set-current-branches! @@ -203,7 +243,7 @@ MIT in each case. |# (LAP (B ,cc (@PCR ,label)))) (lambda (label) (LAP (B ,(invert-cc cc) (@PCR ,label)))))) - + (define (invert-cc cc) (cdr (or (assq cc '((T . F) (F . T) @@ -264,6 +304,12 @@ MIT in each case. |# (register-alias target 'ADDRESS) (allocate-alias-register! target 'DATA)))) +(define (standard-move-to-target! source type target) + (register-reference (move-to-alias-register! source type target))) + +(define (standard-move-to-temporary! source type) + (register-reference (move-to-temporary-register! source type))) + (define-integrable (preferred-data-register-reference register) (register-reference (preferred-data-register register))) @@ -281,7 +327,7 @@ MIT in each case. |# (load-alias-register! register 'ADDRESS))) (define (offset->indirect-reference! offset) - (indirect-reference! (rtl:register-number (rtl:offset-register offset)) + (indirect-reference! (rtl:register-number (rtl:offset-base offset)) (rtl:offset-number offset))) (define (indirect-reference! register offset) @@ -291,7 +337,7 @@ MIT in each case. |# (byte-offset-reference (allocate-indirection-register! register) offset)) (define-integrable (allocate-indirection-register! register) - (guarantee-alias-register! register 'ADDRESS)) + (load-alias-register! register 'ADDRESS)) (define (code-object-label-initialize code-object) code-object @@ -311,37 +357,19 @@ MIT in each case. |# (LAP) (LAP ,(instruction-gen) ,@(loop (-1+ n))))))) - -;;;; Expression-Generic Operations - -(define (expression->machine-register! expression register) - (let ((target (register-reference register))) - (let ((result - (case (car expression) - ((REGISTER) - (load-machine-register! (rtl:register-number expression) - register)) - ((OFFSET) - (LAP (MOV L ,(offset->indirect-reference! expression) ,target))) - ((CONSTANT) - (LAP ,(load-constant (rtl:constant-value expression) target))) - ((UNASSIGNED) - (LAP ,(load-non-pointer type-code:unassigned 0 target))) - (else - (error "Unknown expression type" (car expression)))))) - (delete-machine-register! register) - result))) - -(define (memory-set-type type target) - (if (= 8 scheme-type-width) - (INST (MOV B (& ,type) ,target)) - (INST (OR B (& ,(* type-scale-factor type)) ,target)))) (define (standard-target-expression? target) - (or (rtl:offset? target) + (or (and (rtl:offset? target) + (rtl:register? (rtl:offset-base target))) (rtl:free-push? target) (rtl:stack-push? target))) +(define (standard-target-expression->ea target) + (cond ((rtl:offset? target) (offset->indirect-reference! target)) + ((rtl:free-push? target) (INST-EA (@A+ 5))) + ((rtl:stack-push? target) (INST-EA (@-A 7))) + (else (error "STANDARD-TARGET->EA: Not a standard target" target)))) + (define (rtl:free-push? expression) (and (rtl:post-increment? expression) (interpreter-free-pointer? (rtl:post-increment-register expression)) @@ -351,19 +379,14 @@ MIT in each case. |# (and (rtl:pre-increment? expression) (interpreter-stack-pointer? (rtl:pre-increment-register expression)) (= -1 (rtl:pre-increment-number expression)))) - -(define (standard-target-expression->ea target) - (cond ((rtl:offset? target) (offset->indirect-reference! target)) - ((rtl:free-push? target) (INST-EA (@A+ 5))) - ((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))) + (operate-on-target + (register-reference (move-to-alias-register! source type target)))) (lambda (target) (LAP ,(if (eq? type 'FLOAT) @@ -371,7 +394,8 @@ MIT in each case. |# (if (effective-address/float-register? source) (INST (FMOVE ,source ,target)) (INST (FMOVE D ,source ,target)))) - (INST (MOV L ,(standard-register-reference source type true) + (INST (MOV L + ,(standard-register-reference source type true) ,target))) ,@(operate-on-target target))))) @@ -408,7 +432,8 @@ MIT in each case. |# (define (machine-operation-target? target) (or (rtl:register? target) - (rtl:offset? target))) + (and (rtl:offset? target) + (rtl:register? (rtl:offset-base target))))) (define (two-arg-register-operation operate commutative? @@ -443,7 +468,7 @@ MIT in each case. |# (reuse-pseudo-register-alias source2 target-type (lambda (alias2) (let ((source1 (source-reference source1))) - (delete-machine-register! alias2) + (delete-register! alias2) (delete-dead-registers!) (add-pseudo-register-alias! target alias2) (operate (register-reference alias2) source1))) @@ -757,22 +782,21 @@ MIT in each case. |# ;; `Source' must be a data register or non-volatile memory reference. ;; `Target' must be a data register reference. ;; Guarantees that the condition codes are set for a zero-compare. - (if (= scheme-type-width 8) - (cond ((equal? source target) - (LAP (RO L L (& ,scheme-type-width) ,target))) - (use-68020-instructions? - (LAP (BFEXTU ,source (& 0) (& ,scheme-type-width) ,target))) - (else - (LAP (MOVE L ,source ,target) - (RO L L (& ,scheme-type-width) ,target)))) - (if use-68020-instructions? - (LAP (BFEXTU ,source (& 0) (& ,scheme-type-width) ,target)) - (LAP ,@(if (equal? source target) - (LAP) - (LAP (MOVE L ,source ,target))) - (RO L L (& ,scheme-type-width) ,target) - (AND B (& ,scheme-type-mask) ,target))))) - + (cond (use-68020-instructions? + (LAP (BFEXTU ,source (& 0) (& ,scheme-type-width) ,target))) + ((memq (lap:ea-keyword source) '(@D @A @AO @DO @AOX W L)) + (LAP (CLR L ,target) + (MOVE B ,source ,target) + ,@(if (= scheme-type-width 8) + (LAP) + (LAP (LS R B (& ,(- 8 scheme-type-width)) ,target))))) + (else + (LAP ,@(if (equal? source target) + (LAP) + (LAP (MOVE L ,source ,target))) + (RO L L (& ,scheme-type-width) ,target) + (AND L (& ,scheme-type-mask) ,target))))) + ;;;; CHAR->ASCII rules (define (coerce->any/byte-reference register) diff --git a/v7/src/compiler/machines/bobcat/machin.scm b/v7/src/compiler/machines/bobcat/machin.scm index 609328260..2eb121748 100644 --- a/v7/src/compiler/machines/bobcat/machin.scm +++ b/v7/src/compiler/machines/bobcat/machin.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/machin.scm,v 4.19 1989/12/05 20:52:40 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/machin.scm,v 4.20 1990/01/18 22:43:44 cph Exp $ -Copyright (c) 1988, 1989 Massachusetts Institute of Technology +Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -36,10 +36,7 @@ MIT in each case. |# (declare (usual-integrations)) -(define compiler:open-code-floating-point-arithmetic? true) - -;;; Size of words. Some of the stuff in "assmd.scm" might want to -;;; come here. +;;;; Architecture Parameters (define-integrable endianness 'BIG) (define-integrable addressing-granularity 8) @@ -55,68 +52,26 @@ MIT in each case. |# (define-integrable flonum-size 2) (define-integrable float-alignment 32) -;; It is currently required that both packed characters and objects be -;; integrable numbers of address units. Furthermore, the number of -;; address units per object must be an integral multiple of the number -;; of address units per character. This will cause problems on a -;; machine that is word addressed, in which case we will have to -;; rethink the character addressing strategy. +;;; It is currently required that both packed characters and objects +;;; be integrable numbers of address units. Furthermore, the number +;;; of address units per object must be an integral multiple of the +;;; number of address units per character. This will cause problems +;;; on a machine that is word addressed: we will have to rethink the +;;; character addressing strategy. -(define address-units-per-object +(define-integrable address-units-per-object (quotient scheme-object-width addressing-granularity)) (define-integrable address-units-per-packed-char 1) -(define-integrable signed-fixnum/upper-limit - (expt 2 (-1+ scheme-datum-width))) - -(define-integrable signed-fixnum/lower-limit - (- signed-fixnum/upper-limit)) - -(define-integrable unsigned-fixnum/upper-limit - (* 2 signed-fixnum/upper-limit)) +(define-integrable signed-fixnum/upper-limit (expt 2 (-1+ scheme-datum-width))) +(define-integrable signed-fixnum/lower-limit (- signed-fixnum/upper-limit)) +(define-integrable unsigned-fixnum/upper-limit (* 2 signed-fixnum/upper-limit)) (define-integrable (stack->memory-offset offset) offset) (define-integrable ic-block-first-parameter-offset 2) (define-integrable closure-block-first-offset 2) -(define (rtl:machine-register? rtl-register) - (case rtl-register - ((STACK-POINTER) (interpreter-stack-pointer)) - ((DYNAMIC-LINK) (interpreter-dynamic-link)) - ((INTERPRETER-CALL-RESULT:ACCESS) (interpreter-register:access)) - ((INTERPRETER-CALL-RESULT:CACHE-REFERENCE) - (interpreter-register:cache-reference)) - ((INTERPRETER-CALL-RESULT:CACHE-UNASSIGNED?) - (interpreter-register:cache-unassigned?)) - ((INTERPRETER-CALL-RESULT:LOOKUP) (interpreter-register:lookup)) - ((INTERPRETER-CALL-RESULT:UNASSIGNED?) (interpreter-register:unassigned?)) - ((INTERPRETER-CALL-RESULT:UNBOUND?) (interpreter-register:unbound?)) - (else false))) - -(define (rtl:interpreter-register? rtl-register) - (case rtl-register - ((MEMORY-TOP) 0) - ((STACK-GUARD) 1) - ((VALUE) 2) - ((ENVIRONMENT) 3) - ((TEMPORARY) 4) - (else false))) - -(define (rtl:interpreter-register->offset locative) - (or (rtl:interpreter-register? locative) - (error "Unknown register type" locative))) - -(define (rtl:constant-cost constant) - ;; Magic numbers. Ask RMS where they came from. - (if (and (object-type? 0 constant) - (zero? (object-datum constant))) - 0 - 3)) - -(define compiler:primitives-with-no-open-coding - '(DIVIDE-FIXNUM GC-FIXNUM &/)) - (define-integrable d0 0) (define-integrable d1 1) (define-integrable d2 2) @@ -141,6 +96,7 @@ MIT in each case. |# (define-integrable fp5 21) (define-integrable fp6 22) (define-integrable fp7 23) + (define-integrable number-of-machine-registers 24) (define-integrable number-of-temporary-registers 256) @@ -148,109 +104,140 @@ MIT in each case. |# (define-integrable regnum:free-pointer a5) (define-integrable regnum:regs-pointer a6) (define-integrable regnum:stack-pointer a7) -(define-integrable (sort-machine-registers registers) registers) - -(define available-machine-registers - (list d0 d1 d2 d3 d4 d5 d6 - a0 a1 a2 a3 - fp0 fp1 fp2 fp3 fp4 fp5 fp6 fp7)) - -(define initial-non-object-registers - (list d7 a4 a5 a6 a7)) - -(define (float-register? register) - (if (not (machine-register? register)) - (error "Not a machine-register" register)) - (eq? (register-type register) 'FLOAT)) - -(define (word-register? register) - (if (machine-register? register) - (memq (register-type register) '(DATA ADDRESS)))) - -(define-integrable (register-types-compatible? type1 type2) - (eq? (eq? type1 'FLOAT) (eq? type2 'FLOAT))) - -(define register-type - (let ((types (make-vector number-of-machine-registers))) - (let loop ((i 0) (j 8) (k 16)) - (if (< i 8) - (begin (vector-set! types i 'DATA) - (vector-set! types j 'ADDRESS) - (vector-set! types k 'FLOAT) - (loop (1+ i) (1+ j) (1+ k))))) - (lambda (register) - (vector-ref types register)))) - -(define register-reference - (let ((references (make-vector number-of-machine-registers))) - (let loop ((i 0) (j 8)) - (if (< i 8) - (begin (vector-set! references i (INST-EA (D ,i))) - (vector-set! references j (INST-EA (A ,i))) - (loop (1+ i) (1+ j))))) - (let loop ((i 16) (names '(FP0 FP1 FP2 FP3 FP4 FP5 FP6 FP7))) - (if (not (null? names)) - (begin (vector-set! references i (car names)) - (loop (1+ i) (cdr names))))) - (lambda (register) - (vector-ref references register)))) - -(define mask-reference (INST-EA (D 7))) +(define-integrable (machine-register-known-value register) register false) + +(define (machine-register-value-class register) + (cond ((or (<= 0 register 6) (<= 8 register 11)) value-class=object) + ((= 7 register) value-class=immediate) + ((<= 12 register 15) value-class=address) + ((<= 16 register 23) value-class=float) + (else (error "illegal machine register" register)))) -(define-integrable (interpreter-register:access) +;;;; RTL Generator Interface + +(define (interpreter-register:access) (rtl:make-machine-register d0)) -(define-integrable (interpreter-register:cache-reference) +(define (interpreter-register:cache-reference) (rtl:make-machine-register d0)) -(define-integrable (interpreter-register:cache-unassigned?) +(define (interpreter-register:cache-unassigned?) (rtl:make-machine-register d0)) -(define-integrable (interpreter-register:lookup) +(define (interpreter-register:lookup) (rtl:make-machine-register d0)) -(define-integrable (interpreter-register:unassigned?) +(define (interpreter-register:unassigned?) (rtl:make-machine-register d0)) -(define-integrable (interpreter-register:unbound?) +(define (interpreter-register:unbound?) (rtl:make-machine-register d0)) -(define-integrable (interpreter-value-register) +(define (interpreter-value-register) (rtl:make-offset (interpreter-regs-pointer) 2)) (define (interpreter-value-register? expression) (and (rtl:offset? expression) - (interpreter-regs-pointer? (rtl:offset-register expression)) + (interpreter-regs-pointer? (rtl:offset-base expression)) (= 2 (rtl:offset-number expression)))) -(define-integrable (interpreter-environment-register) +(define (interpreter-environment-register) (rtl:make-offset (interpreter-regs-pointer) 3)) (define (interpreter-environment-register? expression) (and (rtl:offset? expression) - (interpreter-regs-pointer? (rtl:offset-register expression)) + (interpreter-regs-pointer? (rtl:offset-base expression)) (= 3 (rtl:offset-number expression)))) -(define-integrable (interpreter-free-pointer) +(define (interpreter-free-pointer) (rtl:make-machine-register regnum:free-pointer)) -(define-integrable (interpreter-free-pointer? register) - (= (rtl:register-number register) regnum:free-pointer)) +(define (interpreter-free-pointer? expression) + (and (rtl:register? expression) + (= (rtl:register-number expression) regnum:free-pointer))) -(define-integrable (interpreter-regs-pointer) +(define (interpreter-regs-pointer) (rtl:make-machine-register regnum:regs-pointer)) -(define-integrable (interpreter-regs-pointer? register) - (= (rtl:register-number register) regnum:regs-pointer)) +(define (interpreter-regs-pointer? expression) + (and (rtl:register? expression) + (= (rtl:register-number expression) regnum:regs-pointer))) -(define-integrable (interpreter-stack-pointer) +(define (interpreter-stack-pointer) (rtl:make-machine-register regnum:stack-pointer)) -(define-integrable (interpreter-stack-pointer? register) - (= (rtl:register-number register) regnum:stack-pointer)) +(define (interpreter-stack-pointer? expression) + (and (rtl:register? expression) + (= (rtl:register-number expression) regnum:stack-pointer))) -(define-integrable (interpreter-dynamic-link) +(define (interpreter-dynamic-link) (rtl:make-machine-register regnum:dynamic-link)) -(define-integrable (interpreter-dynamic-link? register) - (= (rtl:register-number register) regnum:dynamic-link)) \ No newline at end of file +(define (interpreter-dynamic-link? expression) + (and (rtl:register? expression) + (= (rtl:register-number expression) regnum:dynamic-link))) + +(define (rtl:machine-register? rtl-register) + (case rtl-register + ((STACK-POINTER) (interpreter-stack-pointer)) + ((DYNAMIC-LINK) (interpreter-dynamic-link)) + ((INTERPRETER-CALL-RESULT:ACCESS) (interpreter-register:access)) + ((INTERPRETER-CALL-RESULT:CACHE-REFERENCE) + (interpreter-register:cache-reference)) + ((INTERPRETER-CALL-RESULT:CACHE-UNASSIGNED?) + (interpreter-register:cache-unassigned?)) + ((INTERPRETER-CALL-RESULT:LOOKUP) (interpreter-register:lookup)) + ((INTERPRETER-CALL-RESULT:UNASSIGNED?) (interpreter-register:unassigned?)) + ((INTERPRETER-CALL-RESULT:UNBOUND?) (interpreter-register:unbound?)) + (else false))) + +(define (rtl:interpreter-register? rtl-register) + (case rtl-register + ((MEMORY-TOP) 0) + ((STACK-GUARD) 1) + ((VALUE) 2) + ((ENVIRONMENT) 3) + ((TEMPORARY) 4) + (else false))) + +(define (rtl:interpreter-register->offset locative) + (or (rtl:interpreter-register? locative) + (error "Unknown register type" locative))) + +(define (rtl:constant-cost expression) + ;; Magic numbers. + (let ((if-integer + (lambda (value) + (if (and (not (negative? value)) (< value #x3F)) 2 3)))) + (let ((if-synthesized-constant + (lambda (type datum) + (if-integer (make-non-pointer-literal type datum))))) + (case (rtl:expression-type expression) + ((CONSTANT) + (let ((value (rtl:constant-value expression))) + (if (non-pointer-object? value) + (if-synthesized-constant (object-type value) + (careful-object-datum value)) + 3))) + ((MACHINE-CONSTANT) + (if-integer (rtl:machine-constant-value expression))) + ((ENTRY:PROCEDURE + ENTRY:CONTINUATION + ASSIGNMENT-CACHE + VARIABLE-CACHE + OFFSET-ADDRESS) + 3) + ((CONS-POINTER) + (and (rtl:machine-constant? (rtl:cons-pointer-type expression)) + (rtl:machine-constant? (rtl:cons-pointer-datum expression)) + (if-synthesized-constant + (rtl:machine-constant-value (rtl:cons-pointer-type expression)) + (rtl:machine-constant-value + (rtl:cons-pointer-datum expression))))) + (else false))))) + +(define compiler:open-code-floating-point-arithmetic? + true) + +(define compiler:primitives-with-no-open-coding + '(DIVIDE-FIXNUM GC-FIXNUM &/)) \ No newline at end of file diff --git a/v7/src/compiler/machines/bobcat/make.scm-68040 b/v7/src/compiler/machines/bobcat/make.scm-68040 index 08071e6a8..8c3c7d5fa 100644 --- a/v7/src/compiler/machines/bobcat/make.scm-68040 +++ b/v7/src/compiler/machines/bobcat/make.scm-68040 @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 4.63 1989/12/11 07:15:11 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 4.64 1990/01/18 22:43:49 cph Exp $ -Copyright (c) 1988, 1989 Massachusetts Institute of Technology +Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -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 63 '())) \ No newline at end of file +(add-system! (make-system "Liar (Motorola MC68020)" 4 64 '())) \ 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 778cc9e11..30add54c7 100644 --- a/v7/src/compiler/machines/bobcat/rules1.scm +++ b/v7/src/compiler/machines/bobcat/rules1.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules1.scm,v 4.31 1989/12/11 06:16:54 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules1.scm,v 4.32 1990/01/18 22:43:54 cph Exp $ -Copyright (c) 1988, 1989 Massachusetts Institute of Technology +Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -36,47 +36,8 @@ MIT in each case. |# (declare (usual-integrations)) -;;;; Transfers to Registers +;;;; Register Assignments -(define-rule statement - (ASSIGN (REGISTER (? target)) (REGISTER (? source))) - (QUALIFIER (machine-register? target)) - (LAP (MOV L - ,(standard-register-reference source false true) - ,(register-reference target)))) - -(define-rule statement - (ASSIGN (REGISTER 15) (OFFSET-ADDRESS (REGISTER (? source)) (? offset))) - (QUALIFIER (pseudo-register? source)) - (LAP (LEA ,(indirect-reference! source offset) (A 7)))) - -(define-rule statement - (ASSIGN (REGISTER 15) (OFFSET-ADDRESS (REGISTER 15) (? n))) - (increment-machine-register 15 n)) - -(define-rule statement - (ASSIGN (REGISTER 12) (OFFSET-ADDRESS (REGISTER 15) (? offset))) - (LAP (LEA (@AO 7 ,(* 4 offset)) (A 4)))) - -(define-rule statement - (ASSIGN (REGISTER 12) (OFFSET-ADDRESS (REGISTER (? source)) (? offset))) - (QUALIFIER (pseudo-register? source)) - (LAP (LEA ,(indirect-reference! source offset) (A 4)))) - -(define-rule statement - (ASSIGN (REGISTER 12) (OBJECT->ADDRESS (REGISTER (? source)))) - (QUALIFIER (pseudo-register? source)) - (let ((temp (move-to-temporary-register! source 'DATA))) - (LAP (AND L ,mask-reference ,temp) - (MOV L ,temp (A 4))))) - -(define-rule statement - (ASSIGN (REGISTER 12) (OBJECT->ADDRESS (POST-INCREMENT (REGISTER 15) 1))) - (let ((temp (reference-temporary-register! 'DATA))) - (LAP (MOV L (@A+ 7) ,temp) - (AND L ,mask-reference ,temp) - (MOV L ,temp (A 4))))) - ;;; All assignments to pseudo registers are required to delete the ;;; dead registers BEFORE performing the assignment. However, it is ;;; necessary to derive the effective address of the source @@ -84,248 +45,261 @@ MIT in each case. |# ;;; source expression containing dead registers might refer to aliases ;;; which have been reused. +(define-rule statement + (ASSIGN (REGISTER (? target)) (REGISTER (? source))) + (assign-register->register target source)) + (define-rule statement (ASSIGN (REGISTER (? target)) (OFFSET-ADDRESS (REGISTER (? source)) (? n))) - (QUALIFIER (pseudo-word? target)) (load-static-link target source n false)) (define-rule statement + ;; This is an intermediate rule -- not intended to produce code. (ASSIGN (REGISTER (? target)) - (CONS-POINTER (CONSTANT (? type)) + (CONS-POINTER (MACHINE-CONSTANT (? type)) (OFFSET-ADDRESS (REGISTER (? source)) (? n)))) - (QUALIFIER (pseudo-word? target)) (load-static-link target source n (lambda (target) (LAP (OR UL (& ,(make-non-pointer-literal type 0)) ,target))))) (define (load-static-link target source n suffix) - (let ((non-reusable + (if (and (zero? n) (not suffix)) + (assign-register->register target source) + (let ((non-reusable + (if (not suffix) + (lambda () + (let ((source (allocate-indirection-register! source))) + (delete-dead-registers!) + (let ((target (allocate-alias-register! target 'ADDRESS))) + (if (eqv? source target) + (increment-machine-register target n) + (LAP (LEA ,(offset-reference source n) + ,(register-reference target))))))) + (lambda () + (let ((source (indirect-reference! source n))) + (delete-dead-registers!) + (let ((temp (reference-temporary-register! 'ADDRESS))) + (let ((target (reference-target-alias! target 'DATA))) + (LAP (LEA ,source ,temp) + (MOV L ,temp ,target) + ,@(suffix target))))))))) + (if (machine-register? source) + (non-reusable) + (reuse-pseudo-register-alias! source 'DATA + (lambda (reusable-alias) + (delete-dead-registers!) + (add-pseudo-register-alias! target reusable-alias) + (LAP ,@(increment-machine-register reusable-alias n) + ,@(if suffix + (suffix (register-reference reusable-alias)) + (LAP)))) + non-reusable))))) + +(define (assign-register->register target source) + (standard-move-to-target! source (register-type target) target) + (LAP)) + +(define-rule statement + (ASSIGN (REGISTER (? target)) (OBJECT->TYPE (REGISTER (? source)))) + ;; See if we can reuse a source alias, because `object->type' can + ;; sometimes do a slightly better job when the source and target are + ;; the same register. + (let ((no-reuse (lambda () - (let ((source (indirect-reference! source n))) + (let ((source (standard-register-reference source 'DATA false))) (delete-dead-registers!) - (if suffix - (let ((temp (reference-temporary-register! 'ADDRESS))) - (let ((target (reference-target-alias! target 'DATA))) - (LAP (LEA ,source ,temp) - (MOV L ,temp ,target) - ,@(suffix target)))) - (LAP (LEA ,source - ,(reference-target-alias! target 'ADDRESS)))))))) - (if (machine-register? source) - (non-reusable) + (object->type source (reference-target-alias! target 'DATA)))))) + (if (machine-register? target) + (no-reuse) (reuse-pseudo-register-alias! source 'DATA - (lambda (reusable-alias) + (lambda (source) (delete-dead-registers!) - (add-pseudo-register-alias! target reusable-alias) - (LAP ,@(increment-machine-register reusable-alias n) - ,@(if suffix - (suffix (register-reference reusable-alias)) - (LAP)))) - non-reusable)))) + (add-pseudo-register-alias! target source) + (let ((source (register-reference source))) + (object->type source source))) + no-reuse)))) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (CONS-POINTER (REGISTER (? type)) (REGISTER (? datum)))) + (let ((temp (standard-move-to-temporary! type 'DATA))) + (LAP (RO R L (& ,scheme-type-width) ,temp) + (OR L ,temp ,(standard-move-to-target! datum 'DATA target))))) (define-rule statement - (ASSIGN (REGISTER (? target)) (CONSTANT (? source))) - (QUALIFIER (pseudo-register? target)) - (LAP ,(load-constant source (standard-target-reference target)))) + (ASSIGN (REGISTER (? target)) + (CONS-POINTER (MACHINE-CONSTANT (? type)) (REGISTER (? datum)))) + (LAP (OR UL + (& ,(make-non-pointer-literal type 0)) + ,(standard-move-to-target! datum 'DATA target)))) (define-rule statement - (ASSIGN (REGISTER (? target)) (VARIABLE-CACHE (? name))) - (QUALIFIER (pseudo-register? target)) - (delete-dead-registers!) - (LAP (MOV L - (@PCR ,(free-reference-label name)) - ,(reference-target-alias! target 'ADDRESS)))) + (ASSIGN (REGISTER (? target)) (OBJECT->DATUM (REGISTER (? source)))) + (object->datum (standard-move-to-target! source 'DATA target))) (define-rule statement - (ASSIGN (REGISTER (? target)) (ASSIGNMENT-CACHE (? name))) - (QUALIFIER (pseudo-register? target)) - (delete-dead-registers!) - (LAP (MOV L - (@PCR ,(free-assignment-label name)) - ,(reference-target-alias! target 'ADDRESS)))) + (ASSIGN (REGISTER (? target)) (OBJECT->ADDRESS (REGISTER (? source)))) + (object->address (standard-move-to-target! source 'DATA target))) (define-rule statement - (ASSIGN (REGISTER (? target)) (REGISTER (? source))) - (QUALIFIER (pseudo-word? target)) - (move-to-alias-register! source 'DATA target) - (LAP)) + (ASSIGN (REGISTER (? target)) + (ADDRESS->FIXNUM (OBJECT->ADDRESS (REGISTER (? source))))) + (address->fixnum (standard-move-to-target! source 'DATA target))) (define-rule statement - (ASSIGN (REGISTER (? target)) (REGISTER (? source))) - (QUALIFIER (pseudo-float? target)) - (move-to-alias-register! source 'FLOAT target) - (LAP)) - -(define (convert-object/constant->register target constant conversion) - (delete-dead-registers!) - (let ((target (reference-target-alias! target 'DATA))) - (if (non-pointer-object? constant) - (LAP ,(load-non-pointer 0 (careful-object-datum constant) target)) - (LAP ,(load-constant constant target) - ,@(conversion target))))) + (ASSIGN (REGISTER (? target)) (OBJECT->FIXNUM (REGISTER (? source)))) + (object->fixnum (standard-move-to-target! source 'DATA target))) (define-rule statement - (ASSIGN (REGISTER (? target)) (OBJECT->DATUM (CONSTANT (? constant)))) - (QUALIFIER (pseudo-register? target)) - (convert-object/constant->register target constant object->datum)) + (ASSIGN (REGISTER (? target)) (ADDRESS->FIXNUM (REGISTER (? source)))) + (address->fixnum (standard-move-to-target! source 'DATA target))) (define-rule statement - (ASSIGN (REGISTER (? target)) (OBJECT->ADDRESS (CONSTANT (? constant)))) - (QUALIFIER (pseudo-register? target)) - (convert-object/constant->register target constant object->address)) + (ASSIGN (REGISTER (? target)) (FIXNUM->OBJECT (REGISTER (? source)))) + (fixnum->object (standard-move-to-target! source 'DATA target))) (define-rule statement - (ASSIGN (REGISTER (? target)) - (ADDRESS->FIXNUM (OBJECT->ADDRESS (CONSTANT (? constant))))) - (QUALIFIER (pseudo-register? target)) - (convert-object/constant->register target constant address->fixnum)) + (ASSIGN (REGISTER (? target)) (FIXNUM->ADDRESS (REGISTER (? source)))) + (fixnum->address (standard-move-to-target! source 'DATA target))) + +;;;; Loading Constants (define-rule statement - (ASSIGN (REGISTER (? target)) (OBJECT->TYPE (REGISTER (? source)))) - (QUALIFIER (pseudo-register? target) (pseudo-register? source)) - ;; See if we can reuse a source alias, because `object->type' can - ;; sometimes do a slightly better job when the source and target are - ;; the same register. - (reuse-pseudo-register-alias! source 'DATA - (lambda (source) - (delete-dead-registers!) - (add-pseudo-register-alias! target source) - (let ((source (register-reference source))) - (object->type source source))) - (lambda () - (let ((source (standard-register-reference source 'DATA false))) - (delete-dead-registers!) - (object->type source (reference-target-alias! target 'DATA)))))) + (ASSIGN (REGISTER (? target)) (CONSTANT (? source))) + (LAP ,(load-constant source (standard-target-reference target)))) -(define-integrable (convert-object/register->register target source conversion) - ;; `conversion' often expands into multiple references to `target'. - (let ((target (move-to-alias-register! source 'DATA target))) - (conversion target))) +(define-rule statement + (ASSIGN (REGISTER (? target)) (MACHINE-CONSTANT (? n))) + (LAP ,(load-machine-constant n (standard-target-reference target)))) (define-rule statement - (ASSIGN (REGISTER (? target)) (OBJECT->DATUM (REGISTER (? source)))) - (QUALIFIER (pseudo-register? target)) - (convert-object/register->register target source object->datum)) + (ASSIGN (REGISTER (? target)) + (CONS-POINTER (MACHINE-CONSTANT (? type)) + (MACHINE-CONSTANT (? datum)))) + (LAP ,(load-non-pointer type datum (standard-target-reference target)))) (define-rule statement - (ASSIGN (REGISTER (? target)) (OBJECT->ADDRESS (REGISTER (? source)))) - (QUALIFIER (pseudo-register? target)) - (convert-object/register->register target source object->address)) + (ASSIGN (REGISTER (? target)) (ENTRY:PROCEDURE (? label))) + (load-pc-relative-address + target + (rtl-procedure/external-label (label->object label)))) (define-rule statement - (ASSIGN (REGISTER (? target)) - (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!) - (let ((target (reference-target-alias! target 'DATA))) - (LAP (MOV L ,source ,target) - ,@(conversion target))))) + (ASSIGN (REGISTER (? target)) (ENTRY:CONTINUATION (? label))) + (load-pc-relative-address target label)) + +(define (load-pc-relative-address target label) + (delete-dead-registers!) + (LAP (LEA (@PCR ,label) ,(reference-target-alias! target 'ADDRESS)))) (define-rule statement + ;; This is an intermediate rule -- not intended to produce code. (ASSIGN (REGISTER (? target)) - (OBJECT->DATUM (OFFSET (REGISTER (? address)) (? offset)))) - (QUALIFIER (pseudo-register? target)) - (convert-object/offset->register target address offset object->datum)) + (CONS-POINTER (MACHINE-CONSTANT (? type)) + (ENTRY:PROCEDURE (? label)))) + (load-pc-relative-address-with-type + target + type + (rtl-procedure/external-label (label->object label)))) (define-rule statement + ;; This is an intermediate rule -- not intended to produce code. (ASSIGN (REGISTER (? target)) - (OBJECT->ADDRESS (OFFSET (REGISTER (? address)) (? offset)))) - (QUALIFIER (pseudo-register? target)) - (convert-object/offset->register target address offset object->address)) + (CONS-POINTER (MACHINE-CONSTANT (? type)) + (ENTRY:CONTINUATION (? label)))) + (load-pc-relative-address-with-type target type label)) + +(define (load-pc-relative-address-with-type target type label) + (delete-dead-registers!) + (let ((temp (reference-temporary-register! 'ADDRESS)) + (target (reference-target-alias! target 'DATA))) + (LAP (LEA (@PCR ,label) ,temp) + (MOV L ,temp ,target) + (OR UL (& ,(make-non-pointer-literal type 0)) ,target)))) (define-rule statement - (ASSIGN (REGISTER (? target)) - (ADDRESS->FIXNUM (OBJECT->ADDRESS (OFFSET (REGISTER (? address)) - (? offset))))) - (QUALIFIER (pseudo-register? target)) - (convert-object/offset->register target address offset address->fixnum)) + (ASSIGN (REGISTER (? target)) (VARIABLE-CACHE (? name))) + (load-pc-relative target (free-reference-label name))) (define-rule statement - (ASSIGN (REGISTER (? target)) (OFFSET (REGISTER (? address)) (? offset))) - (QUALIFIER (pseudo-register? target)) - (let ((source (indirect-reference! address offset))) - (LAP (MOV L ,source ,(standard-target-reference target))))) + (ASSIGN (REGISTER (? target)) (ASSIGNMENT-CACHE (? name))) + (load-pc-relative target (free-assignment-label name))) + +(define (load-pc-relative target label) + (delete-dead-registers!) + (LAP (MOV L (@PCR ,label) ,(reference-target-alias! target 'ADDRESS)))) (define-rule statement - (ASSIGN (REGISTER (? target)) (POST-INCREMENT (REGISTER 15) 1)) - (QUALIFIER (pseudo-register? target)) - (LAP (MOV L (@A+ 7) ,(standard-target-reference target)))) + (ASSIGN (REGISTER (? target)) (OBJECT->DATUM (CONSTANT (? constant)))) + (convert-object/constant->register target constant object->datum)) (define-rule statement - (ASSIGN (REGISTER (? target)) - (CONS-POINTER (CONSTANT (? type)) (REGISTER (? datum)))) - (QUALIFIER (and (pseudo-register? target) (machine-register? datum))) - (let ((target (reference-target-alias! target 'DATA))) - (LAP (MOV L ,(register-reference datum) ,target) - (OR UL (& ,(make-non-pointer-literal type 0)) ,target)))) + (ASSIGN (REGISTER (? target)) (OBJECT->ADDRESS (CONSTANT (? constant)))) + (convert-object/constant->register target constant object->address)) (define-rule statement (ASSIGN (REGISTER (? target)) - (CONS-POINTER (CONSTANT (? type)) (REGISTER (? datum)))) - (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)) - (LAP ,(load-non-pointer (ucode-type unassigned) - 0 - (standard-target-reference target)))) + (ADDRESS->FIXNUM (OBJECT->ADDRESS (CONSTANT (? constant))))) + (convert-object/constant->register target constant address->fixnum)) + +(define (convert-object/constant->register target constant conversion) + (delete-dead-registers!) + (let ((target (reference-target-alias! target 'DATA))) + (if (non-pointer-object? constant) + (LAP ,(load-non-pointer 0 (careful-object-datum constant) target)) + (LAP ,(load-constant constant target) + ,@(conversion target))))) (define-rule statement - (ASSIGN (REGISTER (? target)) - (CONS-POINTER (CONSTANT (? type)) (CONSTANT (? datum)))) - (QUALIFIER (pseudo-register? target)) - (LAP ,(load-non-pointer type datum (standard-target-reference target)))) + (ASSIGN (REGISTER (? target)) (OBJECT->FIXNUM (CONSTANT (? constant)))) + (delete-dead-registers!) + (load-fixnum-constant constant (reference-target-alias! target 'DATA))) + +;;;; Transfers from Memory (define-rule statement (ASSIGN (REGISTER (? target)) - (CONS-POINTER (CONSTANT (? type)) (ENTRY:PROCEDURE (? label)))) - (QUALIFIER (pseudo-register? target)) - (let ((temp (reference-temporary-register! 'ADDRESS))) + (OBJECT->TYPE (OFFSET (REGISTER (? address)) (? offset)))) + (let ((source (indirect-reference! address offset))) (delete-dead-registers!) - (let ((target (reference-target-alias! target 'DATA))) - (LAP (LEA (@PCR ,(rtl-procedure/external-label (label->object label))) - ,temp) - (MOV L ,temp ,target) - (OR UL (& ,(make-non-pointer-literal type 0)) ,target))))) + (object->type source (reference-target-alias! target 'DATA)))) (define-rule statement - (ASSIGN (REGISTER (? target)) (OBJECT->FIXNUM (CONSTANT (? constant)))) - (QUALIFIER (pseudo-register? target)) - (delete-dead-registers!) - (load-fixnum-constant constant (reference-target-alias! target 'DATA))) + (ASSIGN (REGISTER (? target)) + (OBJECT->DATUM (OFFSET (REGISTER (? address)) (? offset)))) + (convert-object/offset->register target address offset object->datum)) (define-rule statement - (ASSIGN (REGISTER (? target)) (OBJECT->FIXNUM (REGISTER (? source)))) - (QUALIFIER (pseudo-register? target)) - (convert-object/register->register target source object->fixnum)) + (ASSIGN (REGISTER (? target)) + (OBJECT->ADDRESS (OFFSET (REGISTER (? address)) (? offset)))) + (convert-object/offset->register target address offset object->address)) (define-rule statement - (ASSIGN (REGISTER (? target)) (ADDRESS->FIXNUM (REGISTER (? source)))) - (QUALIFIER (pseudo-register? target)) - (convert-object/register->register target source address->fixnum)) + (ASSIGN (REGISTER (? target)) + (ADDRESS->FIXNUM + (OBJECT->ADDRESS (OFFSET (REGISTER (? address)) (? offset))))) + (convert-object/offset->register target address offset address->fixnum)) (define-rule statement (ASSIGN (REGISTER (? target)) (OBJECT->FIXNUM (OFFSET (REGISTER (? address)) (? offset)))) - (QUALIFIER (pseudo-register? target)) - (convert-object/offset->register target address offset object->fixnum)) + (convert-object/offset->register target address offset object->fixnum)) + +(define (convert-object/offset->register target address offset conversion) + (let ((source (indirect-reference! address offset))) + (delete-dead-registers!) + (let ((target (reference-target-alias! target 'DATA))) + (LAP (MOV L ,source ,target) + ,@(conversion target))))) (define-rule statement - (ASSIGN (REGISTER (? target)) (FIXNUM->OBJECT (REGISTER (? source)))) - (QUALIFIER (pseudo-register? target)) - (convert-object/register->register target source fixnum->object)) + (ASSIGN (REGISTER (? target)) (OFFSET (REGISTER (? address)) (? offset))) + (let ((source (indirect-reference! address offset))) + (LAP (MOV L ,source ,(standard-target-reference target))))) (define-rule statement - (ASSIGN (REGISTER (? target)) (FIXNUM->ADDRESS (REGISTER (? source)))) - (QUALIFIER (pseudo-register? target)) - (convert-object/register->register target source fixnum->address)) + (ASSIGN (REGISTER (? target)) (POST-INCREMENT (REGISTER 15) 1)) + (LAP (MOV L (@A+ 7) ,(standard-target-reference target)))) ;;;; Transfers to Memory @@ -336,14 +310,13 @@ MIT in each case. |# (define-rule statement (ASSIGN (OFFSET (REGISTER (? a)) (? n)) - (UNASSIGNED)) - (LAP ,(load-non-pointer (ucode-type unassigned) - 0 - (indirect-reference! a n)))) + (CONS-POINTER (MACHINE-CONSTANT (? type)) + (MACHINE-CONSTANT (? datum)))) + (LAP ,(load-non-pointer type datum (indirect-reference! a n)))) (define-rule statement - (ASSIGN (OFFSET (REGISTER (? a)) (? n)) - (REGISTER (? r))) + (ASSIGN (OFFSET (REGISTER (? a)) (? n)) (REGISTER (? r))) + (QUALIFIER (register-value-class=word? r)) (LAP (MOV L ,(standard-register-reference r false true) ,(indirect-reference! a n)))) @@ -355,14 +328,14 @@ MIT in each case. |# (define-rule statement (ASSIGN (OFFSET (REGISTER (? address)) (? offset)) - (CONS-POINTER (CONSTANT (? type)) (REGISTER (? datum)))) + (CONS-POINTER (MACHINE-CONSTANT (? type)) (REGISTER (? datum)))) (let ((target (indirect-reference! address offset))) (LAP (MOV L ,(standard-register-reference datum 'DATA true) ,target) ,(memory-set-type type target)))) (define-rule statement (ASSIGN (OFFSET (REGISTER (? address)) (? offset)) - (CONS-POINTER (CONSTANT (? type)) + (CONS-POINTER (MACHINE-CONSTANT (? type)) (OFFSET-ADDRESS (REGISTER (? source)) (? n)))) (let ((temp (reference-temporary-register! 'ADDRESS)) (target (indirect-reference! address offset))) @@ -372,7 +345,8 @@ MIT in each case. |# (define-rule statement (ASSIGN (OFFSET (REGISTER (? address)) (? offset)) - (CONS-POINTER (CONSTANT (? type)) (ENTRY:PROCEDURE (? label)))) + (CONS-POINTER (MACHINE-CONSTANT (? type)) + (ENTRY:PROCEDURE (? label)))) (let ((temp (reference-temporary-register! 'ADDRESS)) (target (indirect-reference! address offset))) (LAP (LEA (@PCR ,(rtl-procedure/external-label (label->object label))) @@ -392,7 +366,7 @@ MIT in each case. |# (ASSIGN (OFFSET (REGISTER (? a)) (? n)) (FIXNUM->OBJECT (REGISTER (? source)))) (let ((target (indirect-reference! a n))) - (let ((temporary (move-to-temporary-register! source 'DATA))) + (let ((temporary (standard-move-to-temporary! source 'DATA))) (LAP ,@(fixnum->object temporary) (MOV L ,temporary ,target))))) @@ -404,27 +378,15 @@ MIT in each case. |# (define-rule statement (ASSIGN (POST-INCREMENT (REGISTER 13) 1) - (CONS-POINTER (CONSTANT (? type)) (CONSTANT (? datum)))) + (CONS-POINTER (MACHINE-CONSTANT (? type)) + (MACHINE-CONSTANT (? datum)))) (LAP ,(load-non-pointer type datum (INST-EA (@A+ 5))))) -(define-rule statement - (ASSIGN (POST-INCREMENT (REGISTER 13) 1) (UNASSIGNED)) - (LAP ,(load-non-pointer (ucode-type unassigned) 0 (INST-EA (@A+ 5))))) - (define-rule statement (ASSIGN (POST-INCREMENT (REGISTER 13) 1) (REGISTER (? r))) - (QUALIFIER (pseudo-word? r)) + (QUALIFIER (register-value-class=word? r)) (LAP (MOV L ,(standard-register-reference r false true) (@A+ 5)))) -#| -;; This seems like a fossil. Removed by Jinx. - -(define-rule statement - (ASSIGN (POST-INCREMENT (REGISTER 13) 1) (REGISTER (? r))) - (QUALIFIER (pseudo-float? r)) - (LAP (FMOVE D ,(machine-register-reference r 'FLOAT) (@A+ 5)))) -|# - (define-rule statement (ASSIGN (POST-INCREMENT (REGISTER 13) 1) (OFFSET (REGISTER (? r)) (? n))) (LAP (MOV L ,(indirect-reference! r n) (@A+ 5)))) @@ -432,7 +394,7 @@ MIT in each case. |# (define-rule statement (ASSIGN (POST-INCREMENT (REGISTER 13) 1) (FIXNUM->OBJECT (REGISTER (? r)))) - (let ((temporary (move-to-temporary-register! r 'DATA))) + (let ((temporary (standard-move-to-temporary! r 'DATA))) (LAP ,@(fixnum->object temporary) (MOV L ,temporary (@A+ 5))))) @@ -443,44 +405,44 @@ MIT in each case. |# ;;;; Pushes -(define-rule statement - (ASSIGN (PRE-INCREMENT (REGISTER 15) -1) (CONSTANT (? object))) - (LAP ,(load-constant object (INST-EA (@-A 7))))) - -(define-rule statement - (ASSIGN (PRE-INCREMENT (REGISTER 15) -1) (UNASSIGNED)) - (LAP ,(load-non-pointer (ucode-type unassigned) 0 (INST-EA (@-A 7))))) - (define-rule statement (ASSIGN (PRE-INCREMENT (REGISTER 15) -1) (REGISTER (? r))) + (QUALIFIER (register-value-class=word? r)) (LAP (MOV L ,(standard-register-reference r false true) (@-A 7)))) +(define-rule statement + (ASSIGN (PRE-INCREMENT (REGISTER 15) -1) (CONSTANT (? object))) + (LAP ,(load-constant object (INST-EA (@-A 7))))) + (define-rule statement (ASSIGN (PRE-INCREMENT (REGISTER 15) -1) - (CONS-POINTER (CONSTANT (? type)) (REGISTER (? datum)))) + (CONS-POINTER (MACHINE-CONSTANT (? type)) (REGISTER (? datum)))) (LAP (MOV L ,(standard-register-reference datum 'DATA true) (@-A 7)) ,(memory-set-type type (INST-EA (@A 7))))) (define-rule statement (ASSIGN (PRE-INCREMENT (REGISTER 15) -1) - (CONS-POINTER (CONSTANT (? type)) (ENTRY:PROCEDURE (? label)))) - (LAP (PEA (@PCR ,(rtl-procedure/external-label (label->object label)))) - ,(memory-set-type type (INST-EA (@A 7))))) + (CONS-POINTER (MACHINE-CONSTANT (? type)) + (MACHINE-CONSTANT (? datum)))) + (LAP ,(load-non-pointer type datum (INST-EA (@-A 7))))) (define-rule statement (ASSIGN (PRE-INCREMENT (REGISTER 15) -1) - (CONS-POINTER (CONSTANT (? type)) (ENTRY:CONTINUATION (? label)))) - (LAP (PEA (@PCR ,label)) + (CONS-POINTER (MACHINE-CONSTANT (? type)) + (ENTRY:PROCEDURE (? label)))) + (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) (ENTRY:CONTINUATION (? label))) + (ASSIGN (PRE-INCREMENT (REGISTER 15) -1) + (CONS-POINTER (MACHINE-CONSTANT (? type)) + (ENTRY:CONTINUATION (? label)))) (LAP (PEA (@PCR ,label)) - ,(memory-set-type (ucode-type compiled-entry) (INST-EA (@A 7))))) + ,(memory-set-type type (INST-EA (@A 7))))) (define-rule statement (ASSIGN (PRE-INCREMENT (REGISTER 15) -1) - (CONS-POINTER (CONSTANT (? type)) + (CONS-POINTER (MACHINE-CONSTANT (? type)) (OFFSET-ADDRESS (REGISTER (? r)) (? n)))) (LAP (PEA ,(indirect-reference! r n)) ,(memory-set-type type (INST-EA (@A 7))))) @@ -492,7 +454,7 @@ MIT in each case. |# (define-rule statement (ASSIGN (PRE-INCREMENT (REGISTER 15) -1) (FIXNUM->OBJECT (REGISTER (? r)))) - (let ((temporary (move-to-temporary-register! r 'DATA))) + (let ((temporary (standard-move-to-temporary! r 'DATA))) (LAP ,@(fixnum->object temporary) (MOV L ,temporary (@-A 7))))) @@ -501,8 +463,7 @@ MIT in each case. |# (define-rule statement (ASSIGN (? target) (FIXNUM-1-ARG (? operator) (REGISTER (? source)) (? overflow?))) - (QUALIFIER (and (machine-operation-target? target) - (pseudo-register? source))) + (QUALIFIER (machine-operation-target? target)) overflow? ; ignored (reuse-and-load-machine-target! 'DATA target @@ -515,9 +476,7 @@ MIT in each case. |# (REGISTER (? source1)) (REGISTER (? source2)) (? overflow?))) - (QUALIFIER (and (machine-operation-target? target) - (pseudo-register? source1) - (pseudo-register? source2))) + (QUALIFIER (machine-operation-target? target)) overflow? ; ignored (two-arg-register-operation (fixnum-2-args/operate operator) (fixnum-2-args/commutative? operator) @@ -537,8 +496,7 @@ MIT in each case. |# (REGISTER (? source)) (OBJECT->FIXNUM (CONSTANT (? constant))) (? overflow?))) - (QUALIFIER (and (machine-operation-target? target) - (pseudo-register? source))) + (QUALIFIER (machine-operation-target? target)) overflow? ; ignored (fixnum-2-args/register*constant operator target source constant)) @@ -548,8 +506,7 @@ MIT in each case. |# (OBJECT->FIXNUM (CONSTANT (? constant))) (REGISTER (? source)) (? overflow?))) - (QUALIFIER (and (machine-operation-target? target) - (pseudo-register? source))) + (QUALIFIER (machine-operation-target? target)) overflow? ; ignored (if (fixnum-2-args/commutative? operator) (fixnum-2-args/register*constant operator target source constant) @@ -587,8 +544,7 @@ MIT in each case. |# (OBJECT->FIXNUM (CONSTANT 4)) (OBJECT->FIXNUM (REGISTER (? source))) (? overflow?))) - (QUALIFIER (and (machine-operation-target? target) - (pseudo-register? source))) + (QUALIFIER (machine-operation-target? target)) overflow? ; ignored (convert-index->fixnum/register target source)) @@ -598,8 +554,7 @@ MIT in each case. |# (OBJECT->FIXNUM (REGISTER (? source))) (OBJECT->FIXNUM (CONSTANT 4)) (? overflow?))) - (QUALIFIER (and (machine-operation-target? target) - (pseudo-register? source))) + (QUALIFIER (machine-operation-target? target)) overflow? ; ignored (convert-index->fixnum/register target source)) @@ -646,30 +601,27 @@ MIT in each case. |# (define-rule statement (ASSIGN (REGISTER (? target)) (FLOAT->OBJECT (REGISTER (? source)))) - (QUALIFIER (pseudo-float? source)) - (let ((target (reference-target-alias! target 'DATA))) - (LAP (MOV L (A 5) ,target) - (OR L (& ,(make-non-pointer-literal (ucode-type flonum) 0)) ,target) - ,(load-non-pointer (ucode-type manifest-nm-vector) - flonum-size - (INST-EA (@A+ 5))) - (FMOVE D - ,(machine-register-reference source 'FLOAT) - (@A+ 5))))) + (let ((source (reference-alias-register! source 'FLOAT))) + (delete-dead-registers!) + (let ((target (reference-target-alias! target 'DATA))) + (LAP (MOV L (A 5) ,target) + (OR L (& ,(make-non-pointer-literal (ucode-type flonum) 0)) ,target) + ,(load-non-pointer (ucode-type manifest-nm-vector) + flonum-size + (INST-EA (@A+ 5))) + (FMOVE D ,source (@A+ 5)))))) (define-rule statement (ASSIGN (REGISTER (? target)) (@ADDRESS->FLOAT (REGISTER (? source)))) - (QUALIFIER (pseudo-float? target)) - (LAP (FMOVE D - ,(indirect-reference! source 1) - ,(reference-target-alias! target 'FLOAT)))) + (let ((source (indirect-reference! source 1))) + (delete-dead-registers!) + (LAP (FMOVE D ,source ,(reference-target-alias! target 'FLOAT))))) (define-rule statement (ASSIGN (? target) (FLONUM-1-ARG (? operator) (REGISTER (? source)) (? overflow?))) - (QUALIFIER (and (machine-operation-target? target) - (pseudo-float? source))) + (QUALIFIER (machine-operation-target? target)) overflow? ; ignored (let ((operate-on-target (lambda (target) @@ -687,9 +639,7 @@ MIT in each case. |# (REGISTER (? source1)) (REGISTER (? source2)) (? overflow?))) - (QUALIFIER (and (machine-operation-target? target) - (pseudo-float? source1) - (pseudo-float? source2))) + (QUALIFIER (machine-operation-target? target)) overflow? ; ignored (let ((source-reference (lambda (source) (standard-register-reference source 'FLOAT false)))) @@ -713,7 +663,6 @@ MIT in each case. |# (define-rule statement (ASSIGN (REGISTER (? target)) (CHAR->ASCII (OFFSET (REGISTER (? address)) (? offset)))) - (QUALIFIER (pseudo-register? target)) (load-char-into-register 0 (indirect-char/ascii-reference! address offset) target)) @@ -721,24 +670,21 @@ MIT in each case. |# (define-rule statement (ASSIGN (REGISTER (? target)) (CHAR->ASCII (REGISTER (? source)))) - (QUALIFIER (pseudo-register? target)) (load-char-into-register 0 - (machine-register-reference source 'DATA) + (reference-alias-register! source 'DATA) target)) (define-rule statement (ASSIGN (REGISTER (? target)) (BYTE-OFFSET (REGISTER (? address)) (? offset))) - (QUALIFIER (pseudo-register? target)) (load-char-into-register 0 (indirect-byte-reference! address offset) target)) (define-rule statement (ASSIGN (REGISTER (? target)) - (CONS-POINTER (CONSTANT (? type)) + (CONS-POINTER (MACHINE-CONSTANT (? type)) (BYTE-OFFSET (REGISTER (? address)) (? offset)))) - (QUALIFIER (pseudo-register? target)) (load-char-into-register type (indirect-byte-reference! address offset) target)) diff --git a/v7/src/compiler/machines/bobcat/rules2.scm b/v7/src/compiler/machines/bobcat/rules2.scm index 00ce44c71..f8e8487f1 100644 --- a/v7/src/compiler/machines/bobcat/rules2.scm +++ b/v7/src/compiler/machines/bobcat/rules2.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules2.scm,v 4.11 1989/12/11 06:16:59 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules2.scm,v 4.12 1990/01/18 22:44:04 cph Rel $ -Copyright (c) 1988, 1989 Massachusetts Institute of Technology +Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -37,7 +37,8 @@ MIT in each case. |# (declare (usual-integrations)) (define (predicate/memory-operand? expression) - (or (rtl:offset? expression) + (or (and (rtl:offset? expression) + (rtl:register? (rtl:offset-base expression))) (and (rtl:post-increment? expression) (interpreter-stack-pointer? (rtl:post-increment-register expression))))) @@ -94,45 +95,13 @@ MIT in each case. |# (LAP (MOV L ,memory-1 ,temp) (CMP L ,memory-2 ,temp)))) -(define-rule predicate - (TRUE-TEST (REGISTER (? register))) - (set-standard-branches! 'NE) - (LAP ,(test-non-pointer (ucode-type false) - 0 - (standard-register-reference register false true)))) - -(define-rule predicate - (TRUE-TEST (? memory)) - (QUALIFIER (predicate/memory-operand? memory)) - (set-standard-branches! 'NE) - (LAP ,(test-non-pointer (ucode-type false) - 0 - (predicate/memory-operand-reference memory)))) - -(define-rule predicate - (UNASSIGNED-TEST (REGISTER (? register))) - (set-standard-branches! 'EQ) - (LAP ,(test-non-pointer (ucode-type unassigned) - 0 - (standard-register-reference register false true)))) - -(define-rule predicate - (UNASSIGNED-TEST (? memory)) - (QUALIFIER (predicate/memory-operand? memory)) - (set-standard-branches! 'EQ) - (LAP ,(test-non-pointer (ucode-type unassigned) - 0 - (predicate/memory-operand-reference memory)))) - (define-rule predicate (TYPE-TEST (REGISTER (? register)) (? type)) - (QUALIFIER (pseudo-register? register)) (set-standard-branches! 'EQ) (LAP ,(test-byte type (reference-alias-register! register 'DATA)))) (define-rule predicate (TYPE-TEST (OBJECT->TYPE (REGISTER (? register))) (? type)) - (QUALIFIER (pseudo-register? register)) (set-standard-branches! 'EQ) (if (and (zero? type) use-68020-instructions?) (LAP (BFTST ,(standard-register-reference register 'DATA false) @@ -176,22 +145,18 @@ MIT in each case. |# (define-rule predicate (EQ-TEST (REGISTER (? register-1)) (REGISTER (? register-2))) - (QUALIFIER (and (pseudo-register? register-1) - (pseudo-register? register-2))) (compare/register*register register-1 register-2 'EQ)) (define-rule predicate (EQ-TEST (REGISTER (? register)) (? memory)) - (QUALIFIER (and (predicate/memory-operand? memory) - (pseudo-register? register))) + (QUALIFIER (predicate/memory-operand? memory)) (compare/register*memory register (predicate/memory-operand-reference memory) 'EQ)) (define-rule predicate (EQ-TEST (? memory) (REGISTER (? register))) - (QUALIFIER (and (predicate/memory-operand? memory) - (pseudo-register? register))) + (QUALIFIER (predicate/memory-operand? memory)) (compare/register*memory register (predicate/memory-operand-reference memory) 'EQ)) @@ -204,6 +169,14 @@ MIT in each case. |# (predicate/memory-operand-reference memory-2) 'EQ)) +(define-rule predicate + (EQ-TEST (CONSTANT (? constant)) (REGISTER (? register))) + (eq-test/constant*register constant register)) + +(define-rule predicate + (EQ-TEST (REGISTER (? register)) (CONSTANT (? constant))) + (eq-test/constant*register constant register)) + (define (eq-test/constant*register constant register) (if (non-pointer-object? constant) (begin @@ -214,37 +187,64 @@ MIT in each case. |# (compare/register*memory register (INST-EA (@PCR ,(constant->label constant))) 'EQ))) + +(define-rule predicate + (EQ-TEST (CONSTANT (? constant)) (? memory)) + (QUALIFIER (predicate/memory-operand? memory)) + (eq-test/constant*memory constant memory)) + +(define-rule predicate + (EQ-TEST (? memory) (CONSTANT (? constant))) + (QUALIFIER (predicate/memory-operand? memory)) + (eq-test/constant*memory constant memory)) (define (eq-test/constant*memory constant memory) - (if (non-pointer-object? constant) - (begin - (set-standard-branches! 'EQ) - (LAP ,(test-non-pointer-constant constant memory))) - (compare/memory*memory memory - (INST-EA (@PCR ,(constant->label constant))) - 'EQ))) + (let ((memory (predicate/memory-operand-reference memory))) + (if (non-pointer-object? constant) + (begin + (set-standard-branches! 'EQ) + (LAP ,(test-non-pointer-constant constant memory))) + (compare/memory*memory memory + (INST-EA (@PCR ,(constant->label constant))) + 'EQ)))) (define-rule predicate - (EQ-TEST (CONSTANT (? constant)) (REGISTER (? register))) - (QUALIFIER (pseudo-register? register)) - (eq-test/constant*register constant register)) + (EQ-TEST (CONS-POINTER (MACHINE-CONSTANT (? type)) + (MACHINE-CONSTANT (? datum))) + (REGISTER (? register))) + (eq-test/synthesized-constant*register type datum register)) (define-rule predicate - (EQ-TEST (REGISTER (? register)) (CONSTANT (? constant))) - (QUALIFIER (pseudo-register? register)) - (eq-test/constant*register constant register)) + (EQ-TEST (REGISTER (? register)) + (CONS-POINTER (MACHINE-CONSTANT (? type)) + (MACHINE-CONSTANT (? datum)))) + (eq-test/synthesized-constant*register type datum register)) + +(define (eq-test/synthesized-constant*register type datum register) + (set-standard-branches! 'EQ) + (LAP ,(test-non-pointer type + datum + (standard-register-reference register 'DATA true)))) (define-rule predicate - (EQ-TEST (CONSTANT (? constant)) (? memory)) + (EQ-TEST (CONS-POINTER (MACHINE-CONSTANT (? type)) + (MACHINE-CONSTANT (? datum))) + (? memory)) (QUALIFIER (predicate/memory-operand? memory)) - (eq-test/constant*memory constant - (predicate/memory-operand-reference memory))) + (eq-test/synthesized-constant*memory type datum memory)) (define-rule predicate - (EQ-TEST (? memory) (CONSTANT (? constant))) + (EQ-TEST (? memory) + (CONS-POINTER (MACHINE-CONSTANT (? type)) + (MACHINE-CONSTANT (? datum)))) (QUALIFIER (predicate/memory-operand? memory)) - (eq-test/constant*memory constant - (predicate/memory-operand-reference memory))) + (eq-test/synthesized-constant*memory type datum memory)) + +(define (eq-test/synthesized-constant*memory type datum memory) + (set-standard-branches! 'EQ) + (LAP ,(test-non-pointer type + datum + (predicate/memory-operand-reference memory)))) ;;;; Fixnum/Flonum Predicates @@ -255,44 +255,38 @@ MIT in each case. |# (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 true))) + (LAP ,(test-fixnum (standard-register-reference register 'DATA true)))) (define-rule predicate (FIXNUM-PRED-1-ARG (? predicate) (OBJECT->FIXNUM (REGISTER (? register)))) - (QUALIFIER (pseudo-register? register)) (set-standard-branches! (fixnum-predicate->cc predicate)) - (object->fixnum (move-to-temporary-register! register 'DATA))) + (object->fixnum (standard-move-to-temporary! register 'DATA))) (define-rule predicate (FIXNUM-PRED-1-ARG (? predicate) (? memory)) (QUALIFIER (predicate/memory-operand? memory)) (set-standard-branches! (fixnum-predicate->cc predicate)) - (test-fixnum (predicate/memory-operand-reference memory))) + (LAP ,(test-fixnum (predicate/memory-operand-reference memory)))) (define-rule predicate (FIXNUM-PRED-2-ARGS (? predicate) (REGISTER (? register-1)) (REGISTER (? register-2))) - (QUALIFIER (and (pseudo-register? register-1) - (pseudo-register? register-2))) (compare/register*register register-1 register-2 (fixnum-predicate->cc predicate))) (define-rule predicate (FIXNUM-PRED-2-ARGS (? predicate) (REGISTER (? register)) (? memory)) - (QUALIFIER (and (predicate/memory-operand? memory) - (pseudo-register? register))) + (QUALIFIER (predicate/memory-operand? memory)) (compare/register*memory register (predicate/memory-operand-reference memory) (fixnum-predicate->cc predicate))) (define-rule predicate (FIXNUM-PRED-2-ARGS (? predicate) (? memory) (REGISTER (? register))) - (QUALIFIER (and (predicate/memory-operand? memory) - (pseudo-register? register))) + (QUALIFIER (predicate/memory-operand? memory)) (compare/register*memory register (predicate/memory-operand-reference memory) @@ -306,19 +300,10 @@ MIT in each case. |# (predicate/memory-operand-reference memory-2) (fixnum-predicate->cc predicate))) -(define (fixnum-predicate/register*constant register constant cc) - (set-standard-branches! cc) - (guarantee-signed-fixnum constant) - (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))))) - (define-rule predicate (FIXNUM-PRED-2-ARGS (? predicate) (REGISTER (? register)) (OBJECT->FIXNUM (CONSTANT (? constant)))) - (QUALIFIER (pseudo-register? register)) (fixnum-predicate/register*constant register constant (fixnum-predicate->cc predicate))) @@ -327,16 +312,18 @@ MIT in each case. |# (FIXNUM-PRED-2-ARGS (? predicate) (OBJECT->FIXNUM (CONSTANT (? constant))) (REGISTER (? register))) - (QUALIFIER (pseudo-register? register)) (fixnum-predicate/register*constant register constant (invert-cc-noncommutative (fixnum-predicate->cc predicate)))) -(define (fixnum-predicate/memory*constant memory constant cc) +(define (fixnum-predicate/register*constant register constant cc) (set-standard-branches! cc) (guarantee-signed-fixnum constant) - (LAP (CMPI L (& ,(* constant fixnum-1)) ,memory))) + (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))))) (define-rule predicate (FIXNUM-PRED-2-ARGS (? predicate) @@ -357,9 +344,14 @@ MIT in each case. |# constant (invert-cc-noncommutative (fixnum-predicate->cc predicate)))) +(define (fixnum-predicate/memory*constant memory constant cc) + (set-standard-branches! cc) + (guarantee-signed-fixnum constant) + (LAP (CMPI L (& ,(* constant fixnum-1)) ,memory))) + (define-rule predicate (FLONUM-PRED-1-ARG (? predicate) (REGISTER (? register))) - (QUALIFIER (pseudo-float? register)) + (QUALIFIER (register-value-class=float? register)) (set-flonum-branches! (flonum-predicate->cc predicate)) (LAP (FTST ,(standard-register-reference register 'FLOAT false)))) @@ -367,7 +359,8 @@ MIT in each case. |# (FLONUM-PRED-2-ARGS (? predicate) (REGISTER (? register1)) (REGISTER (? register2))) - (QUALIFIER (and (pseudo-float? register1) (pseudo-float? register2))) + (QUALIFIER (and (register-value-class=float? register1) + (register-value-class=float? register2))) (set-flonum-branches! (flonum-predicate->cc predicate)) (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 79d4de2bb..3f39ea401 100644 --- a/v7/src/compiler/machines/bobcat/rules3.scm +++ b/v7/src/compiler/machines/bobcat/rules3.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules3.scm,v 4.22 1989/12/11 06:17:02 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules3.scm,v 4.23 1990/01/18 22:44:09 cph Exp $ -Copyright (c) 1988, 1989 Massachusetts Institute of Technology +Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -112,8 +112,10 @@ MIT in each case. |# (define-rule statement (INVOCATION:CACHE-REFERENCE (? frame-size) (? continuation) (? extension)) + (QUALIFIER (interpreter-call-argument? extension)) continuation - (let ((set-extension (expression->machine-register! extension d1))) + (let ((set-extension + (interpreter-call-argument->machine-register! extension d1))) (delete-dead-registers!) (LAP ,@set-extension ,@(clear-map!) @@ -124,8 +126,10 @@ MIT in each case. |# (define-rule statement (INVOCATION:LOOKUP (? frame-size) (? continuation) (? environment) (? name)) + (QUALIFIER (interpreter-call-argument? environment)) continuation - (let ((set-environment (expression->machine-register! environment d1))) + (let ((set-environment + (interpreter-call-argument->machine-register! environment d1))) (delete-dead-registers!) (LAP ,@set-environment ,@(clear-map!) @@ -222,7 +226,6 @@ MIT in each case. |# (INVOCATION-PREFIX:MOVE-FRAME-UP (? frame-size) (OFFSET-ADDRESS (REGISTER (? base)) (? offset))) - (QUALIFIER (pseudo-register? base)) (generate/move-frame-up frame-size (indirect-reference! base offset))) (define-rule statement @@ -248,8 +251,7 @@ MIT in each case. |# (INVOCATION-PREFIX:DYNAMIC-LINK (? frame-size) (OBJECT->ADDRESS (REGISTER (? source))) (REGISTER 12)) - (QUALIFIER (pseudo-register? source)) - (let ((dreg (move-to-temporary-register! source 'DATA)) + (let ((dreg (standard-move-to-temporary! source 'DATA)) (label (generate-label)) (temp (allocate-temporary-register! 'ADDRESS))) (let ((areg (register-reference temp))) @@ -265,8 +267,7 @@ MIT in each case. |# (INVOCATION-PREFIX:DYNAMIC-LINK (? frame-size) (REGISTER (? source)) (REGISTER 12)) - (QUALIFIER (pseudo-register? source)) - (let ((areg (move-to-temporary-register! source 'ADDRESS)) + (let ((areg (standard-move-to-temporary! source 'ADDRESS)) (label (generate-label))) (LAP (CMP L ,areg (A 4)) (B HS B (@PCR ,label)) @@ -433,16 +434,22 @@ MIT in each case. |# (define-rule statement (ASSIGN (REGISTER (? target)) - (CONS-POINTER (CONSTANT (? type)) + (CONS-CLOSURE (ENTRY:PROCEDURE (? procedure-label)) + (? min) (? max) (? size))) + (generate/cons-closure (reference-target-alias! target 'DATA) + false procedure-label min max size)) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (CONS-POINTER (MACHINE-CONSTANT (? type)) (CONS-CLOSURE (ENTRY:PROCEDURE (? procedure-label)) (? min) (? max) (? size)))) - (QUALIFIER (pseudo-register? target)) (generate/cons-closure (reference-target-alias! target 'DATA) type procedure-label min max size)) (define-rule statement (ASSIGN (? target) - (CONS-POINTER (CONSTANT (? type)) + (CONS-POINTER (MACHINE-CONSTANT (? type)) (CONS-CLOSURE (ENTRY:PROCEDURE (? procedure-label)) (? min) (? max) (? size)))) (QUALIFIER (standard-target-expression? target)) @@ -462,7 +469,9 @@ MIT in each case. |# (& ,(+ (* (make-procedure-code-word min max) #x10000) 8)) (@A+ 5)) (MOV L (A 5) ,target) - (OR UL (& ,(make-non-pointer-literal type 0)) ,target) + ,@(if type + (LAP (OR UL (& ,(make-non-pointer-literal type 0)) ,target)) + (LAP)) (MOV UW (& #x4eb9) (@A+ 5)) ; (JSR (L )) (MOV L ,temporary (@A+ 5)) (CLR W (@A+ 5)) diff --git a/v7/src/compiler/machines/bobcat/rules4.scm b/v7/src/compiler/machines/bobcat/rules4.scm index 61821e6a6..84c748b26 100644 --- a/v7/src/compiler/machines/bobcat/rules4.scm +++ b/v7/src/compiler/machines/bobcat/rules4.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules4.scm,v 4.9 1989/12/11 06:17:06 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules4.scm,v 4.10 1990/01/18 22:44:15 cph Exp $ -Copyright (c) 1988, 1989 Massachusetts Institute of Technology +Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -38,25 +38,61 @@ MIT in each case. |# ;;;; Interpreter Calls +(define (interpreter-call-argument? expression) + (or (rtl:register? expression) + (rtl:constant? expression) + (and (rtl:cons-pointer? expression) + (rtl:machine-constant? (rtl:cons-pointer-type expression)) + (rtl:machine-constant? (rtl:cons-pointer-datum expression))) + (and (rtl:offset? expression) + (rtl:register? (rtl:offset-base expression))))) + +(define (interpreter-call-argument->machine-register! expression register) + (let ((target (register-reference register))) + (let ((result + (case (car expression) + ((REGISTER) + (load-machine-register! (rtl:register-number expression) + register)) + ((CONSTANT) + (LAP ,(load-constant (rtl:constant-value expression) target))) + ((CONS-POINTER) + (LAP ,(load-non-pointer (rtl:machine-constant-value + (rtl:cons-pointer-type expression)) + (rtl:machine-constant-value + (rtl:cons-pointer-datum expression)) + target))) + ((OFFSET) + (LAP (MOV L ,(offset->indirect-reference! expression) ,target))) + (else + (error "Unknown expression type" (car expression)))))) + (delete-register! register) + result))) + (define-rule statement (INTERPRETER-CALL:ACCESS (? environment) (? name)) + (QUALIFIER (interpreter-call-argument? environment)) (lookup-call code:compiler-access environment name)) (define-rule statement (INTERPRETER-CALL:LOOKUP (? environment) (? name) (? safe?)) + (QUALIFIER (interpreter-call-argument? environment)) (lookup-call (if safe? code:compiler-safe-lookup code:compiler-lookup) environment name)) (define-rule statement (INTERPRETER-CALL:UNASSIGNED? (? environment) (? name)) + (QUALIFIER (interpreter-call-argument? environment)) (lookup-call code:compiler-unassigned? environment name)) (define-rule statement (INTERPRETER-CALL:UNBOUND? (? environment) (? name)) + (QUALIFIER (interpreter-call-argument? environment)) (lookup-call code:compiler-unbound? environment name)) (define (lookup-call code environment name) - (let ((set-environment (expression->machine-register! environment d2))) + (let ((set-environment + (interpreter-call-argument->machine-register! environment d2))) (let ((clear-map (clear-map!))) (LAP ,@set-environment ,@clear-map @@ -65,17 +101,20 @@ MIT in each case. |# (define-rule statement (INTERPRETER-CALL:DEFINE (? environment) (? name) (? value)) - (QUALIFIER (not (eq? 'CONS-POINTER (car value)))) - (assignment-call:default code:compiler-define environment name value)) + (QUALIFIER (and (interpreter-call-argument? environment) + (interpreter-call-argument? value))) + (assignment-call code:compiler-define environment name value)) (define-rule statement (INTERPRETER-CALL:SET! (? environment) (? name) (? value)) - (QUALIFIER (not (eq? 'CONS-POINTER (car value)))) - (assignment-call:default code:compiler-set! environment name value)) - -(define (assignment-call:default code environment name value) - (let ((set-environment (expression->machine-register! environment d2))) - (let ((set-value (expression->machine-register! value d4))) + (QUALIFIER (and (interpreter-call-argument? environment) + (interpreter-call-argument? value))) + (assignment-call code:compiler-set! environment name value)) + +(define (assignment-call code environment name value) + (let ((set-environment + (interpreter-call-argument->machine-register! environment d2))) + (let ((set-value (interpreter-call-argument->machine-register! value d4))) (let ((clear-map (clear-map!))) (LAP ,@set-environment ,@set-value @@ -83,59 +122,11 @@ MIT in each case. |# ,(load-constant name (INST-EA (D 3))) ,@(invoke-interface-jsr code)))))) -(define-rule statement - (INTERPRETER-CALL:DEFINE (? environment) (? name) - (CONS-POINTER (CONSTANT (? type)) - (REGISTER (? datum)))) - (assignment-call:cons-pointer code:compiler-define environment name type - datum)) - -(define-rule statement - (INTERPRETER-CALL:SET! (? environment) (? name) - (CONS-POINTER (CONSTANT (? type)) - (REGISTER (? datum)))) - (assignment-call:cons-pointer code:compiler-set! environment name type - datum)) - -(define (assignment-call:cons-pointer code environment name type datum) - (let ((set-environment (expression->machine-register! environment d2))) - (let ((datum (standard-register-reference datum false true))) - (let ((clear-map (clear-map!))) - (LAP ,@set-environment - (MOV L ,datum ,reg:temp) - ,(memory-set-type type reg:temp) - ,@clear-map - (MOV L ,reg:temp (D 4)) - ,(load-constant name (INST-EA (D 3))) - ,@(invoke-interface-jsr code)))))) - -(define-rule statement - (INTERPRETER-CALL:DEFINE (? environment) (? name) - (CONS-POINTER (CONSTANT (? type)) - (ENTRY:PROCEDURE (? label)))) - (assignment-call:cons-procedure code:compiler-define environment name type - label)) - -(define-rule statement - (INTERPRETER-CALL:SET! (? environment) (? name) - (CONS-POINTER (CONSTANT (? type)) - (ENTRY:PROCEDURE (? label)))) - (assignment-call:cons-procedure code:compiler-set! environment name type - label)) - -(define (assignment-call:cons-procedure code environment name type label) - (let ((set-environment (expression->machine-register! environment d2))) - (LAP ,@set-environment - ,@(clear-map!) - (PEA (@PCR ,(rtl-procedure/external-label (label->object label)))) - ,(memory-set-type type (INST-EA (@A 7))) - (MOV L (@A+ 7) (D 4)) - ,(load-constant name (INST-EA (D 3))) - ,@(invoke-interface-jsr code)))) - (define-rule statement (INTERPRETER-CALL:CACHE-REFERENCE (? extension) (? safe?)) - (let ((set-extension (expression->machine-register! extension d2))) + (QUALIFIER (interpreter-call-argument? extension)) + (let ((set-extension + (interpreter-call-argument->machine-register! extension d2))) (let ((clear-map (clear-map!))) (LAP ,@set-extension ,@clear-map @@ -145,45 +136,22 @@ MIT in each case. |# (define-rule statement (INTERPRETER-CALL:CACHE-ASSIGNMENT (? extension) (? value)) - (QUALIFIER (not (eq? 'CONS-POINTER (car value)))) - (let ((set-extension (expression->machine-register! extension d2))) - (let ((set-value (expression->machine-register! value d3))) + (QUALIFIER (and (interpreter-call-argument? extension) + (interpreter-call-argument? value))) + (let ((set-extension + (interpreter-call-argument->machine-register! extension d2))) + (let ((set-value (interpreter-call-argument->machine-register! value d3))) (let ((clear-map (clear-map!))) (LAP ,@set-extension ,@set-value ,@clear-map (JSR ,entry:compiler-assignment-trap)))))) -(define-rule statement - (INTERPRETER-CALL:CACHE-ASSIGNMENT (? extension) - (CONS-POINTER (CONSTANT (? type)) - (REGISTER (? datum)))) - (let ((set-extension (expression->machine-register! extension d2))) - (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) - ,@clear-map - (MOV L ,reg:temp (D 3)) - (JSR ,entry:compiler-assignment-trap)))))) - -(define-rule statement - (INTERPRETER-CALL:CACHE-ASSIGNMENT - (? extension) - (CONS-POINTER (CONSTANT (? type)) - (ENTRY:PROCEDURE (? label)))) - (let ((set-extension (expression->machine-register! extension d2))) - (LAP ,@set-extension - ,@(clear-map!) - (PEA (@PCR ,(rtl-procedure/external-label (label->object label)))) - ,(memory-set-type type (INST-EA (@A 7))) - (MOV L (@A+ 7) (D 3)) - (JSR ,entry:compiler-assignment-trap)))) - (define-rule statement (INTERPRETER-CALL:CACHE-UNASSIGNED? (? extension)) - (let ((set-extension (expression->machine-register! extension d2))) + (QUALIFIER (interpreter-call-argument? extension)) + (let ((set-extension + (interpreter-call-argument->machine-register! extension d2))) (let ((clear-map (clear-map!))) (LAP ,@set-extension ,@clear-map diff --git a/v7/src/compiler/rtlbase/rgraph.scm b/v7/src/compiler/rtlbase/rgraph.scm index 6c27c4267..a56af5f75 100644 --- a/v7/src/compiler/rtlbase/rgraph.scm +++ b/v7/src/compiler/rtlbase/rgraph.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$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 $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rgraph.scm,v 4.7 1990/01/18 22:45:00 cph Rel $ -Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology +Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -40,7 +40,6 @@ MIT in each case. |# (copier false) (constructor make-rgraph (n-registers))) n-registers - (non-object-registers (reverse initial-non-object-registers)) entry-edges bblocks register-bblock @@ -48,7 +47,8 @@ MIT in each case. |# register-n-deaths register-live-length register-crosses-call? - register-value-classes) + register-value-classes + register-known-values) (define (add-rgraph-bblock! rgraph bblock) (set-rgraph-bblocks! rgraph (cons bblock (rgraph-bblocks rgraph)))) @@ -56,53 +56,12 @@ MIT in each case. |# (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 - (cons register (rgraph-non-object-registers rgraph)))) - (define (add-rgraph-entry-edge! rgraph edge) (set-rgraph-entry-edges! rgraph (cons edge (rgraph-entry-edges rgraph)))) (define-integrable rgraph-register-renumber rgraph-register-bblock) (define-integrable set-rgraph-register-renumber! set-rgraph-register-bblock!) -;;; Pseudo-register value classes are kept on an association list between value -;;; classes and lists of pseudo-registers in the class. A register not found -;;; in any value class list is assumed to have class VALUE, the broadest and -;;; most common class. This minimizes the space used to store register value -;;; classifiations at the expense of reduced speed. It is illegal to change -;;; the value class of a pseudo-register unless its current class is VALUE -;;; (completely unspecified); this restriction is checked. - -(define (rgraph-register-value-class rgraph register) - (let loop ((classes (rgraph-register-value-classes rgraph))) - (if (null? classes) - 'VALUE - (let ((class-list (car classes))) - (if (memq register (cdr class-list)) - (car class-list) - (loop (cdr classes))))))) - -(define (set-rgraph-register-value-class! rgraph register value-class) - (let ((old-value-class (rgraph-register-value-class rgraph register))) - (if (eq? old-value-class 'VALUE) - (if (not (eq? value-class 'VALUE)) - (let loop ((classes (rgraph-register-value-classes rgraph))) - (if (null? classes) - (set-rgraph-register-value-classes! - rgraph - (cons (list value-class register) - (rgraph-register-value-classes rgraph))) - (let ((class-list (car classes))) - (if (eq? value-class (car class-list)) - (let ((register-list (cdr class-list))) - (if (not (memq register register-list)) - (set-cdr! class-list (cons register register-list)))) - (loop (cdr classes))))))) - (if (not (eq? old-value-class value-class)) - (error "Illegal register value class change" register value-class))))) - (define *rgraphs*) (define *current-rgraph*) diff --git a/v7/src/compiler/rtlbase/rtlcon.scm b/v7/src/compiler/rtlbase/rtlcon.scm index 563e9113e..a4b7e90d8 100644 --- a/v7/src/compiler/rtlbase/rtlcon.scm +++ b/v7/src/compiler/rtlbase/rtlcon.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlcon.scm,v 4.19 1989/12/05 20:52:20 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlcon.scm,v 4.20 1990/01/18 22:45:15 cph Exp $ -Copyright (c) 1988, 1989 Massachusetts Institute of Technology +Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -38,49 +38,37 @@ MIT in each case. |# ;;;; Statements -(define (%make-assign-classified locative expression) - (if (rtl:register? locative) - (let ((register (rtl:register-number locative))) - (if (pseudo-register? register) - (set-rgraph-register-value-class! - *current-rgraph* - register - (rtl->value-class expression))))) - (%make-assign locative expression)) - (define (rtl:make-assignment locative expression) + (locative-dereference-for-statement locative + (lambda (locative) + (let ((receiver + (lambda (expression) + (rtl:make-assignment-internal locative expression)))) + (if (rtl:pseudo-register-expression? locative) + (expression-simplify-for-pseudo-assignment expression receiver) + (expression-simplify-for-statement expression receiver)))))) + +(define (rtl:make-assignment-internal locative expression) + (cond ((and (or (rtl:register? locative) (rtl:offset? locative)) + (equal? locative expression)) + (make-null-cfg)) + ((or (rtl:register? locative) (rtl:register? expression)) + (%make-assign locative expression)) + (else + (let ((register (rtl:make-pseudo-register))) + (scfg*scfg->scfg! (%make-assign register expression) + (%make-assign locative register)))))) + +(define (rtl:make-pop locative) + (locative-dereference-for-statement locative + (lambda (locative) + (rtl:make-assignment-internal locative (stack-pop-address))))) + +(define (rtl:make-push expression) (expression-simplify-for-statement expression (lambda (expression) - (locative-dereference-for-statement locative - (lambda (locative) - (rtl:make-assignment-internal locative expression)))))) + (rtl:make-assignment-internal (stack-push-address) expression)))) -(define (rtl:make-assignment-internal locative expression) - (let ((assign-register - (lambda (locative) - (let ((register (rtl:register-number locative))) - (if (rtl:non-object-valued-expression? expression) - ;; We don't know for sure that this register is - ;; assigned only once. However, if it is assigned - ;; multiple times, then all of those assignments - ;; should be non-object valued expressions. This - ;; constraint is not enforced. - (add-rgraph-non-object-register! *current-rgraph* register)) - (%make-assign-classified locative expression))))) - (cond ((rtl:pseudo-register-expression? locative) - (assign-register locative)) - ((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) @@ -88,10 +76,11 @@ MIT in each case. |# (lambda (expression-2) (%make-eq-test expression-1 expression-2)))))) +(define (rtl:make-false-test expression) + (rtl:make-eq-test expression (rtl:make-constant false))) + (define (rtl:make-true-test expression) - (expression-simplify-for-predicate expression - (lambda (expression) - (%make-true-test expression)))) + (pcfg-invert (rtl:make-false-test expression))) (define (rtl:make-type-test expression type) (expression-simplify-for-predicate expression @@ -99,10 +88,11 @@ MIT in each case. |# (%make-type-test expression type)))) (define (rtl:make-unassigned-test expression) - (expression-simplify-for-predicate expression - (lambda (expression) - (%make-unassigned-test expression)))) - + (rtl:make-eq-test + expression + (rtl:make-cons-pointer (rtl:make-machine-constant (ucode-type unassigned)) + (rtl:make-machine-constant 0)))) + (define (rtl:make-fixnum-pred-1-arg predicate operand) (expression-simplify-for-predicate operand (lambda (operand) @@ -126,27 +116,15 @@ MIT in each case. |# (expression-simplify-for-predicate operand2 (lambda (operand2) (%make-flonum-pred-2-args predicate operand1 operand2)))))) - -(define (rtl:make-pop locative) - (locative-dereference-for-statement locative - (lambda (locative) - (rtl:make-assignment-internal locative (stack-pop-address))))) - -(define (rtl:make-push expression) - (expression-simplify-for-statement expression - (lambda (expression) - (rtl:make-assignment-internal (stack-push-address) expression)))) - -(define-integrable (rtl:make-address->environment address) - (rtl:make-cons-pointer (rtl:make-constant (ucode-type stack-environment)) - address)) (define (rtl:make-push-return continuation) - (rtl:make-push (rtl:make-entry:continuation continuation))) + (rtl:make-push + (rtl:make-cons-pointer (rtl:make-machine-constant type-code:compiled-entry) + (rtl:make-entry:continuation continuation)))) (define (rtl:make-push-link) (rtl:make-push - (rtl:make-address->environment (rtl:make-fetch register:dynamic-link)))) + (rtl:make-environment (rtl:make-fetch register:dynamic-link)))) (define (rtl:make-pop-link) (rtl:make-assignment register:dynamic-link @@ -159,6 +137,25 @@ MIT in each case. |# (define (rtl:make-link->stack-pointer) (rtl:make-assignment register:stack-pointer (rtl:make-fetch register:dynamic-link))) + +(define (rtl:make-constant value) + (if (unassigned-reference-trap? value) + (rtl:make-cons-pointer + (rtl:make-machine-constant type-code:unassigned) + (rtl:make-machine-constant 0)) + (%make-constant value))) + +(define make-non-pointer-literal + (let ((type-maximum (expt 2 scheme-type-width)) + (type-scale-factor (expt 2 scheme-datum-width))) + (lambda (type datum) + (if (not (and (exact-nonnegative-integer? type) + (< type type-maximum))) + (error "non-pointer type out of range" type)) + (if (not (and (exact-nonnegative-integer? datum) + (< datum type-scale-factor))) + (error "non-pointer datum out of range" datum)) + (+ (* type type-scale-factor) datum)))) ;;; Interpreter Calls @@ -219,42 +216,84 @@ MIT in each case. |# (package (locative-dereference-for-statement expression-simplify-for-statement - expression-simplify-for-predicate) + expression-simplify-for-predicate + expression-simplify-for-pseudo-assignment) -(define (make-offset register offset granularity) - (cond ((eq? granularity 'OBJECT) - (rtl:make-offset register offset)) - ((eq? granularity 'BYTE) - (rtl:make-byte-offset register offset)) - (else - (error "Unknown offset granularity" register offset granularity)))) - (define-export (locative-dereference-for-statement locative receiver) (locative-dereference locative scfg*scfg->scfg! receiver (lambda (register offset granularity) (receiver (make-offset register offset granularity))))) -(define (locative-dereference locative scfg-append! if-register if-memory) - (locative-dereference-1 locative scfg-append! locative-fetch - if-register if-memory)) +(define-export (expression-simplify-for-statement expression receiver) + (expression-simplify expression scfg*scfg->scfg! receiver)) + +(define-export (expression-simplify-for-predicate expression receiver) + (expression-simplify expression scfg*pcfg->pcfg! receiver)) + +(define-export (expression-simplify-for-pseudo-assignment expression receiver) + (let ((entry (assq (car expression) expression-methods))) + (if entry + (apply (cdr entry) receiver scfg*scfg->scfg! (cdr expression)) + (receiver expression)))) + +(define (expression-simplify expression scfg-append! receiver) + (if (rtl:register? expression) + (receiver expression) + (let ((entry (assq (car expression) expression-methods))) + (if entry + (apply (cdr entry) + (lambda (expression) + (if (rtl:register? expression) + (receiver expression) + (assign-to-temporary expression + scfg-append! + receiver))) + scfg-append! + (cdr expression)) + (assign-to-temporary expression scfg-append! receiver))))) + +(define (assign-to-temporary expression scfg-append! receiver) + (let ((pseudo (rtl:make-pseudo-register))) + (scfg-append! (rtl:make-assignment-internal pseudo expression) + (receiver pseudo)))) -(define (locative-dereference-1 locative scfg-append! locative-fetch - if-register if-memory) +(define (make-offset register offset granularity) + (case granularity + ((OBJECT) (rtl:make-offset register offset)) + ((BYTE) (rtl:make-byte-offset register offset)) + (else (error "unknown offset granularity" granularity)))) + +(define (locative-dereference locative scfg-append! if-register if-memory) (let ((dereference-fetch (lambda (locative offset granularity) - (locative-fetch (cadr locative) offset granularity scfg-append! - if-memory))) + (let ((if-address + (lambda (address) + (if-memory address offset granularity)))) + (let ((if-not-address + (lambda (register) + (assign-to-address-temporary register + scfg-append! + if-address)))) + (locative-dereference (cadr locative) scfg-append! + (lambda (expression) + (let ((register (rtl:register-number expression))) + (if (and (machine-register? register) + (register-value-class=address? register)) + (if-address expression) + (if-not-address expression)))) + (lambda (register offset granularity) + (assign-to-temporary + (make-offset register offset granularity) + scfg-append! + if-not-address))))))) (dereference-constant (lambda (locative offset granularity) (assign-to-temporary locative scfg-append! (lambda (register) (assign-to-address-temporary register scfg-append! (lambda (register) - (if-memory register offset granularity))))))) - (locative-error - (lambda (message) - (error (string-append "LOCATIVE-DEREFERENCE: " message) locative)))) + (if-memory register offset granularity)))))))) (cond ((symbol? locative) (let ((register (rtl:machine-register? locative))) (if register @@ -273,111 +312,39 @@ MIT in each case. |# (offset (rtl:locative-offset-offset locative)) (granularity (rtl:locative-offset-granularity locative))) (if (not (pair? base)) - (locative-error "offset base not pair")) + (error "offset base not pair" locative)) (case (car base) ((FETCH) (dereference-fetch base offset granularity)) ((CONSTANT) (dereference-constant base offset granularity)) (else - (locative-error "illegal offset base"))))) + (error "illegal offset base" locative))))) ((CONSTANT) (dereference-constant locative 0 'OBJECT)) (else - (locative-error "Unknown keyword")))) + (error "unknown keyword" locative)))) (else - (locative-error "Illegal locative"))))) - -(define (locative-fetch locative offset granularity scfg-append! receiver) - (let ((receiver - (lambda (register) - (guarantee-address register scfg-append! - (lambda (address) - (receiver address offset granularity)))))) - (locative-dereference locative scfg-append! - receiver - (lambda (register offset granularity) - (assign-to-temporary (make-offset register offset granularity) - scfg-append! - receiver))))) - -(define (locative-fetch-1 locative offset granularity scfg-append! receiver) - (locative-dereference locative scfg-append! - (lambda (register) - (receiver register offset granularity)) - (lambda (register offset* granularity*) - (receiver (make-offset register offset* granularity*) - offset - granularity)))) - -(define (guarantee-address expression scfg-append! receiver) - (if (rtl:non-object-valued-expression? expression) - (receiver expression) - (guarantee-register expression scfg-append! - (lambda (register) - (assign-to-address-temporary register scfg-append! receiver))))) - -(define (guarantee-register expression scfg-append! receiver) - (if (rtl:register? expression) - (receiver expression) - (assign-to-temporary expression scfg-append! receiver))) - -(define (generate-offset-address expression offset granularity scfg-append! - receiver) - (if (not (eq? granularity 'OBJECT)) - (error "Byte Offset Address not implemented" expression offset)) - (guarantee-address expression scfg-append! - (lambda (address) - (guarantee-register address scfg-append! - (lambda (register) - (receiver (rtl:make-offset-address register offset))))))) - -(define-export (expression-simplify-for-statement expression receiver) - (expression-simplify expression scfg*scfg->scfg! receiver)) - -(define-export (expression-simplify-for-predicate expression receiver) - (expression-simplify expression scfg*pcfg->pcfg! receiver)) - -(define (expression-simplify expression scfg-append! receiver) - (let ((receiver - (lambda (expression) - (if (rtl:trivial-expression? expression) - (receiver expression) - (assign-to-temporary expression scfg-append! receiver))))) - (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))) - (if (rtl:non-object-valued-expression? expression) - (add-rgraph-non-object-register! *current-rgraph* - (rtl:register-number pseudo))) - (scfg-append! (%make-assign-classified pseudo expression) - (receiver pseudo)))) + (error "illegal locative" locative))))) (define (assign-to-address-temporary expression scfg-append! receiver) (let ((pseudo (rtl:make-pseudo-register))) - (add-rgraph-non-object-register! *current-rgraph* - (rtl:register-number pseudo)) - (scfg-append! (%make-assign-classified - pseudo - (rtl:make-object->address expression)) - (receiver pseudo)))) - + (scfg-append! + (rtl:make-assignment-internal pseudo + (rtl:make-object->address expression)) + (receiver pseudo)))) + (define (define-expression-method name method) (let ((entry (assq name expression-methods))) (if entry (set-cdr! entry method) (set! expression-methods - (cons (cons name method) expression-methods))))) + (cons (cons name method) expression-methods)))) + name) (define expression-methods '()) - + (define-expression-method 'FETCH (lambda (receiver scfg-append! locative) (locative-dereference locative scfg-append! @@ -387,7 +354,7 @@ MIT in each case. |# (define (address-method generator) (lambda (receiver scfg-append! locative) - (locative-dereference-1 locative scfg-append! locative-fetch-1 + (locative-dereference locative scfg-append! (lambda (register) register (error "Can't take ADDRESS of a register" locative)) @@ -396,44 +363,56 @@ MIT in each case. |# (define-expression-method 'ADDRESS (address-method (lambda (receiver scfg-append!) - (lambda (expression offset granularity) + scfg-append! ;ignore + (lambda (address offset granularity) + (if (not (eq? granularity 'OBJECT)) + (error "can't take address of non-object offset" granularity)) (if (zero? offset) - (guarantee-address expression scfg-append! receiver) - (generate-offset-address expression - offset - granularity - scfg-append! - receiver)))))) + (receiver address) + (receiver (rtl:make-offset-address address offset))))))) (define-expression-method 'ENVIRONMENT (address-method (lambda (receiver scfg-append!) - (lambda (expression offset granularity) - (if (zero? offset) - (receiver - (if (rtl:non-object-valued-expression? expression) - (rtl:make-address->environment expression) - expression)) - (generate-offset-address expression offset granularity scfg-append! - (lambda (expression) - (assign-to-temporary expression scfg-append! - (lambda (register) - (receiver (rtl:make-address->environment register))))))))))) + (lambda (address offset granularity) + (if (not (eq? granularity 'OBJECT)) + (error "can't take address of non-object offset" granularity)) + (let ((receiver + (lambda (address) + (expression-simplify + (rtl:make-cons-pointer + (rtl:make-machine-constant (ucode-type stack-environment)) + address) + scfg-append! + receiver)))) + (if (zero? offset) + (receiver address) + (assign-to-temporary (rtl:make-offset-address address offset) + scfg-append! + receiver))))))) + +(define-expression-method 'CONS-POINTER + (lambda (receiver scfg-append! type datum) + (expression-simplify type scfg-append! + (lambda (type) + (expression-simplify datum scfg-append! + (lambda (datum) + (receiver (rtl:make-cons-pointer type datum)))))))) (define-expression-method 'CELL-CONS (lambda (receiver scfg-append! expression) (expression-simplify expression scfg-append! (lambda (expression) (let ((free (interpreter-free-pointer))) - (assign-to-temporary - (rtl:make-cons-pointer (rtl:make-constant type-code:cell) free) + (expression-simplify + (rtl:make-cons-pointer (rtl:make-machine-constant type-code:cell) + free) scfg-append! (lambda (temporary) - (let ((setup - (rtl:make-assignment-internal - (rtl:make-post-increment free 1) - expression))) - (scfg-append! setup (receiver temporary)))))))))) + (scfg-append! + (rtl:make-assignment-internal (rtl:make-post-increment free 1) + expression) + (receiver temporary))))))))) (define-expression-method 'TYPED-CONS:PAIR (lambda (receiver scfg-append! type car cdr) @@ -448,47 +427,42 @@ MIT in each case. |# (assign-to-temporary (rtl:make-cons-pointer type free) scfg-append! (lambda (temporary) - (let* ((set-car - (rtl:make-assignment-internal target car)) - (set-cdr - (rtl:make-assignment-internal target cdr))) - (scfg-append! - set-car - (scfg-append! set-cdr - (receiver temporary)))))))))))))))) + (scfg-append! + (rtl:make-assignment-internal target car) + (scfg-append! + (rtl:make-assignment-internal target cdr) + (receiver temporary))))))))))))))) (define-expression-method 'TYPED-CONS:VECTOR (lambda (receiver scfg-append! type . elements) - (let ((free (interpreter-free-pointer)) - (header - (rtl:make-cons-pointer - (rtl:make-constant (ucode-type manifest-vector)) - (rtl:make-constant (length elements))))) - (let ((target (rtl:make-post-increment free 1))) - (expression-simplify type scfg-append! - (lambda (type) - (let loop ((elements elements) (simplified-elements '())) - (if (null? elements) - (assign-to-temporary (rtl:make-cons-pointer type free) - scfg-append! - (lambda (temporary) - (let ((setup - (rtl:make-assignment-internal target header))) - (scfg-append! - setup - (let loop ((elements (reverse! simplified-elements))) - (if (null? elements) - (receiver temporary) - (let ((setup - (rtl:make-assignment-internal - target - (car elements)))) - (scfg-append! setup - (loop (cdr elements)))))))))) - (expression-simplify (car elements) scfg-append! - (lambda (element) - (loop (cdr elements) - (cons element simplified-elements)))))))))))) + (let* ((free (interpreter-free-pointer)) + (target (rtl:make-post-increment free 1))) + (expression-simplify type scfg-append! + (lambda (type) + (let loop ((elements* elements) (simplified-elements '())) + (if (null? elements*) + (assign-to-temporary (rtl:make-cons-pointer type free) + scfg-append! + (lambda (temporary) + (expression-simplify + (rtl:make-cons-pointer + (rtl:make-machine-constant (ucode-type manifest-vector)) + (rtl:make-machine-constant (length elements))) + scfg-append! + (lambda (header) + (scfg-append! + (rtl:make-assignment-internal target header) + (let loop ((elements (reverse! simplified-elements))) + (if (null? elements) + (receiver temporary) + (scfg-append! + (rtl:make-assignment-internal target + (car elements)) + (loop (cdr elements)))))))))) + (expression-simplify (car elements*) scfg-append! + (lambda (element) + (loop (cdr elements*) + (cons element simplified-elements))))))))))) (define-expression-method 'TYPED-CONS:PROCEDURE ;; A NOP for simplification @@ -509,12 +483,7 @@ MIT in each case. |# (object-selector rtl:make-char->ascii)) (define-expression-method 'OBJECT->DATUM - (lambda (receiver scfg-append! expression) - (expression-simplify expression scfg-append! - (lambda (expression) - (assign-to-temporary (rtl:make-object->datum expression) - scfg-append! - receiver))))) + (object-selector rtl:make-object->datum)) (define-expression-method 'OBJECT->ADDRESS (object-selector rtl:make-object->address)) @@ -529,23 +498,14 @@ MIT in each case. |# (object-selector rtl:make-address->fixnum)) (define-expression-method 'OBJECT->FIXNUM - (lambda (receiver scfg-append! expression) - (expression-simplify expression scfg-append! - (lambda (expression) - (if (rtl:non-object-valued-expression? expression) - (receiver expression) - (assign-to-temporary (rtl:make-object->fixnum expression) - scfg-append! - receiver)))))) + (object-selector rtl:make-object->fixnum)) + +(define-expression-method 'FLOAT->OBJECT + (object-selector rtl:make-float->object)) + +(define-expression-method '@ADDRESS->FLOAT + (object-selector rtl:make-@address->float)) -(define-expression-method 'CONS-POINTER - (lambda (receiver scfg-append! type datum) - (expression-simplify type scfg-append! - (lambda (type) - (expression-simplify datum scfg-append! - (lambda (datum) - (receiver (rtl:make-cons-pointer type datum)))))))) - (define-expression-method 'FIXNUM-2-ARGS (lambda (receiver scfg-append! operator operand1 operand2 overflow?) (expression-simplify operand1 scfg-append! @@ -553,7 +513,10 @@ MIT in each case. |# (expression-simplify operand2 scfg-append! (lambda (operand2) (receiver - (rtl:make-fixnum-2-args operator operand1 operand2 overflow?)))))))) + (rtl:make-fixnum-2-args operator + operand1 + operand2 + overflow?)))))))) (define-expression-method 'FIXNUM-1-ARG (lambda (receiver scfg-append! operator operand overflow?) @@ -561,21 +524,6 @@ MIT in each case. |# (lambda (operand) (receiver (rtl:make-fixnum-1-arg operator operand overflow?)))))) -(define-expression-method 'GENERIC-BINARY - (lambda (receiver scfg-append! operator operand1 operand2) - (expression-simplify operand1 scfg-append! - (lambda (operand1) - (expression-simplify operand2 scfg-append! - (lambda (operand2) - (receiver - (rtl:make-generic-binary operator operand1 operand2)))))))) - -(define-expression-method 'GENERIC-UNARY - (lambda (receiver scfg-append! operator operand) - (expression-simplify operand scfg-append! - (lambda (operand) - (receiver (rtl:make-generic-unary operator operand)))))) - (define-expression-method 'FLONUM-1-ARG (lambda (receiver scfg-append! operator operand overflow?) (expression-simplify operand scfg-append! @@ -597,17 +545,5 @@ MIT in each case. |# s-operand2 overflow?)))))))) -(define-expression-method 'FLOAT->OBJECT - (lambda (receiver scfg-append! expression) - (expression-simplify expression scfg-append! - (lambda (expression) - (receiver (rtl:make-float->object expression)))))) - -(define-expression-method '@ADDRESS->FLOAT - (lambda (receiver scfg-append! expression) - (expression-simplify expression scfg-append! - (lambda (expression) - (receiver (rtl:make-@address->float expression)))))) - ;;; end EXPRESSION-SIMPLIFY package ) \ No newline at end of file diff --git a/v7/src/compiler/rtlbase/rtlexp.scm b/v7/src/compiler/rtlbase/rtlexp.scm index 990c27d92..b0af89422 100644 --- a/v7/src/compiler/rtlbase/rtlexp.scm +++ b/v7/src/compiler/rtlbase/rtlexp.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlexp.scm,v 4.14 1989/12/05 23:55:00 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlexp.scm,v 4.15 1990/01/18 22:45:35 cph Exp $ -Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology +Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -36,7 +36,7 @@ MIT in each case. |# (declare (usual-integrations)) -(define-integrable (rtl:invocation? rtl) +(define (rtl:invocation? rtl) (memq (rtl:expression-type rtl) '(INVOCATION:APPLY INVOCATION:JUMP @@ -49,58 +49,42 @@ MIT in each case. |# INVOCATION:CACHE-REFERENCE INVOCATION:LOOKUP))) -(define-integrable (rtl:invocation-prefix? rtl) +(define (rtl:invocation-prefix? rtl) (memq (rtl:expression-type rtl) '(INVOCATION-PREFIX:DYNAMIC-LINK INVOCATION-PREFIX:MOVE-FRAME-UP))) -(define (rtl:trivial-expression? expression) +(define (rtl:expression-value-class expression) (case (rtl:expression-type expression) - ((ASSIGNMENT-CACHE - 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))))) + ((REGISTER) + (register-value-class (rtl:register-number expression))) + ((CONS-POINTER CONSTANT FIXNUM->OBJECT FLOAT->OBJECT GENERIC-BINARY + GENERIC-UNARY OFFSET POST-INCREMENT PRE-INCREMENT) + value-class=object) + ((ASSIGNMENT-CACHE FIXNUM->ADDRESS OBJECT->ADDRESS OFFSET-ADDRESS + VARIABLE-CACHE) + value-class=address) + ((MACHINE-CONSTANT) + value-class=immediate) + ((BYTE-OFFSET CHAR->ASCII) + value-class=ascii) + ((CONS-CLOSURE ENTRY:CONTINUATION ENTRY:PROCEDURE OBJECT->DATUM) + value-class=datum) + ((ADDRESS->FIXNUM FIXNUM-1-ARG FIXNUM-2-ARGS OBJECT->FIXNUM + OBJECT->UNSIGNED-FIXNUM) + value-class=fixnum) ((OBJECT->TYPE) - (rtl:constant? (rtl:object->type-expression expression))) + value-class=type) + ((@ADDRESS->FLOAT FLONUM-1-ARG FLONUM-2-ARGS) + value-class=float) (else - false))) + (error "unknown RTL expression type" expression)))) -(define (rtl:non-object-valued-expression? expression) - (if (rtl:register? expression) - (register-contains-non-object? (rtl:register-number expression)) - (memq (rtl:expression-type expression) - '(ASSIGNMENT-CACHE - CHAR->ASCII - CONS-CLOSURE - FIXNUM-1-ARG - FIXNUM-2-ARGS - FLONUM-1-ARG - FLONUM-2-ARGS - OBJECT->ADDRESS - OBJECT->DATUM - OBJECT->FIXNUM - OBJECT->ADDRESS - @ADDRESS->FLOAT - ADDRESS->FIXNUM - FIXNUM->ADDRESS - OBJECT->TYPE - OFFSET-ADDRESS - VARIABLE-CACHE)))) +(define (rtl:object-valued-expression? expression) + (value-class=object? (rtl:expression-value-class expression))) -(define-integrable (rtl:volatile-expression? expression) - (memq (rtl:expression-type expression) - '(POST-INCREMENT - PRE-INCREMENT))) +(define (rtl:volatile-expression? expression) + (memq (rtl:expression-type expression) '(POST-INCREMENT PRE-INCREMENT))) (define (rtl:machine-register-expression? expression) (and (rtl:register? expression) @@ -112,11 +96,27 @@ MIT in each case. |# (define (rtl:stack-reference-expression? expression) (and (rtl:offset? expression) - (interpreter-stack-pointer? (rtl:offset-register expression)))) + (interpreter-stack-pointer? (rtl:offset-base expression)))) + +(define (rtl:register-assignment? rtl) + (and (rtl:assign? rtl) + (rtl:register? (rtl:assign-address rtl)))) + +(define (rtl:expression-cost expression) + (if (rtl:register? expression) + 1 + (or (rtl:constant-cost expression) + (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))))))) (define (rtl:map-subexpressions expression procedure) (if (rtl:constant? expression) - (map identity-procedure expression) + expression (cons (car expression) (map (lambda (x) (if (pair? x) @@ -149,7 +149,7 @@ MIT in each case. |# (lambda (x) (or (not (pair? x)) (predicate x)))))) - + (define (rtl:reduce-subparts expression operator initial if-expression if-not) (let ((remap (if (rtl:constant? expression) @@ -164,9 +164,9 @@ MIT in each case. |# (loop (cdr parts) (operator accum (remap (car parts)))))))) -(define (rtl:match-subexpressions x y predicate) - (let ((type (rtl:expression-type x))) - (and (eq? type (rtl:expression-type y)) +(define (rtl:expression=? x y) + (let ((type (car x))) + (and (eq? type (car y)) (if (eq? type 'CONSTANT) (eqv? (cadr x) (cadr y)) (let loop ((x (cdr x)) (y (cdr y))) @@ -175,105 +175,136 @@ MIT in each case. |# ;; a subexpression or a non-expression. (or (null? x) (and (if (pair? (car x)) - (predicate (car x) (car y)) + (rtl:expression=? (car x) (car y)) (eqv? (car x) (car y))) (loop (cdr x) (cdr y))))))))) -(define (rtl:modify-subexpressions expression procedure) - (if (not (rtl:constant? expression)) - (let loop ((tail (cdr expression))) - (if (not (null? tail)) - (begin (if (pair? (car tail)) - (procedure (car tail) - (lambda (expression) - (set-car! tail expression)))) - (loop (cdr tail))))))) - -(define (rtl:expand-statement statement expander finish) - (let loop ((subexpressions (cdr statement)) (new-subexpressions '())) - (if (null? subexpressions) - (finish (reverse! new-subexpressions)) - (expander (car subexpressions) - (lambda (new-subexpression) - (loop (cdr subexpressions) - (cons new-subexpression new-subexpressions))))))) +(define (rtl:match-subexpressions x y predicate) + (let ((type (car x))) + (and (eq? type (car y)) + (if (eq? type 'CONSTANT) + (eqv? (cadr x) (cadr y)) + (let loop ((x (cdr x)) (y (cdr y))) + (or (null? x) + (and (if (pair? (car x)) + (predicate (car x) (car y)) + (eqv? (car x) (car y))) + (loop (cdr x) (cdr y))))))))) (define (rtl:refers-to-register? rtl register) - (let loop ((expression rtl)) - (cond ((not (pair? expression)) - false) + (let loop + ((expression + (if (rtl:register-assignment? rtl) (rtl:assign-expression rtl) rtl))) + (cond ((not (pair? expression)) false) ((rtl:register? expression) (= (rtl:register-number expression) register)) - ((rtl:contains-no-substitutable-registers? expression) - false) - (else - (there-exists? (cdr expression) loop))))) + ((rtl:contains-no-substitutable-registers? expression) false) + (else (there-exists? (cdr expression) loop))))) (define (rtl:subst-register rtl register substitute) - (let loop ((expression rtl)) - (cond ((not (pair? expression)) - expression) - ((rtl:register? expression) - (if (= (rtl:register-number expression) register) - substitute - expression)) - ((rtl:contains-no-substitutable-registers? expression) - expression) - (else - (cons (car expression) (map loop (cdr expression))))))) + (letrec + ((loop + (lambda (expression) + (cond ((not (pair? expression)) expression) + ((rtl:register? expression) + (if (= (rtl:register-number expression) register) + substitute + expression)) + ((rtl:contains-no-substitutable-registers? expression) + expression) + (else (cons (car expression) (map loop (cdr expression)))))))) + (if (rtl:register-assignment? rtl) + (list (rtl:expression-type rtl) + (rtl:assign-address rtl) + (loop (rtl:assign-expression rtl))) + (loop rtl)))) -(define-integrable (rtl:contains-no-substitutable-registers? expression) +(define (rtl:substitutable-registers rtl) + (if (rtl:register-assignment? rtl) + (rtl:substitutable-registers (rtl:assign-expression rtl)) + (let outer ((expression rtl) (registers '())) + (cond ((not (pair? expression)) registers) + ((rtl:register? expression) + (let ((register (rtl:register-number expression))) + (if (memq register registers) + registers + (cons register registers)))) + ((rtl:contains-no-substitutable-registers? expression) registers) + (else + (let inner + ((subexpressions (cdr expression)) (registers registers)) + (if (null? subexpressions) + registers + (inner (cdr subexpressions) + (outer (car subexpressions) registers))))))))) +(define (rtl:contains-no-substitutable-registers? expression) ;; True for all expressions that cannot possibly contain registers. ;; In addition, this is also true of expressions that do contain - ;; registers which are not candidates for substitution (e.g. + ;; registers but are not candidates for substitution (e.g. ;; `pre-increment'). - - ;; The expression type `offset' (and the related `offset-address' - ;; and `byte-offset') is such an expression, but only because it is - ;; assumed in some places that its base address is a register. If - ;; those places are changed to not make such an assumption, this can - ;; be changed to allow substitution there. - (memq (rtl:expression-type expression) '(ASSIGNMENT-CACHE - BYTE-OFFSET + CONS-CLOSURE CONSTANT ENTRY:CONTINUATION ENTRY:PROCEDURE - OFFSET - OFFSET-ADDRESS + MACHINE-CONSTANT POST-INCREMENT PRE-INCREMENT - UNASSIGNED VARIABLE-CACHE))) - + (define (rtl:constant-expression? expression) - (if (pair? expression) - (case (rtl:expression-type expression) - ((CONSTANT UNASSIGNED ASSIGNMENT-CACHE VARIABLE-CACHE - ENTRY:CONTINUATION ENTRY:PROCEDURE) - true) - ((CHAR->ASCII FIXNUM->OBJECT OBJECT->ADDRESS OBJECT->DATUM - OBJECT->FIXNUM OBJECT->TYPE) - (rtl:constant-expression? (cadr expression))) - ((CONS-POINTER) - (and (rtl:constant-expression? (rtl:cons-pointer-type expression)) - (rtl:constant-expression? (rtl:cons-pointer-datum expression)))) - ((FIXNUM-1-ARG) - (rtl:constant-expression? (rtl:fixnum-1-arg-operand expression))) - ((FIXNUM-2-ARGS) - (and (rtl:constant-expression? - (rtl:fixnum-2-args-operand-1 expression)) - (rtl:constant-expression? - (rtl:fixnum-2-args-operand-2 expression)))) - ((FLONUM-1-ARG) - (rtl:constant-expression? (rtl:flonum-1-arg-operand expression))) - ((FLONUM-2-ARGS) - (and (rtl:constant-expression? - (rtl:flonum-2-args-operand-1 expression)) - (rtl:constant-expression? - (rtl:flonum-2-args-operand-2 expression)))) - (else - false)) - true)) \ No newline at end of file + (case (rtl:expression-type expression) + ((ASSIGNMENT-CACHE + CONSTANT + ENTRY:CONTINUATION + ENTRY:PROCEDURE + MACHINE-CONSTANT + VARIABLE-CACHE) + true) + ((CHAR->ASCII + CONS-POINTER + FIXNUM-1-ARG + FIXNUM-2-ARGS + FIXNUM->ADDRESS + FIXNUM->OBJECT + FLONUM-1-ARG + FLONUM-2-ARGS + GENERIC-BINARY + GENERIC-UNARY + OBJECT->ADDRESS + OBJECT->DATUM + OBJECT->FIXNUM + OBJECT->TYPE + OBJECT->UNSIGNED-FIXNUM + OFFSET-ADDRESS) + (let loop ((subexpressions (cdr expression))) + (or (null? subexpressions) + (and (let ((expression (car subexpressions))) + (or (not (pair? expression)) + (rtl:constant-expression? expression))) + (loop (cdr subexpressions)))))) + (else + false))) + +(define (rtx-set/union* set sets) + (let loop ((set set) (sets sets) (accum '())) + (let ((set (rtx-set/union set accum))) + (if (null? sets) + set + (loop (car sets) (cdr sets) set))))) + +(define (rtx-set/union x y) + (if (null? y) + x + (let loop ((x x) (y y)) + (if (null? x) + y + (loop (cdr x) + (let ((x (car x))) + (if (there-exists? y + (lambda (y) + (rtl:expression=? x y))) + y + (cons x y)))))))) \ No newline at end of file diff --git a/v7/src/compiler/rtlbase/rtlreg.scm b/v7/src/compiler/rtlbase/rtlreg.scm index aac43b289..2ba9711e3 100644 --- a/v7/src/compiler/rtlbase/rtlreg.scm +++ b/v7/src/compiler/rtlbase/rtlreg.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlreg.scm,v 4.4 1988/08/29 23:03:03 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlreg.scm,v 4.5 1990/01/18 22:45:43 cph Rel $ -Copyright (c) 1987, 1988 Massachusetts Institute of Technology +Copyright (c) 1987, 1988, 1990 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -114,11 +114,24 @@ MIT in each case. |# (define (decrement-register-live-length! register) (set-register-live-length! register (-1+ (register-live-length register)))) -(define-integrable (register-crosses-call? register) +(define (register-crosses-call? register) (bit-string-ref (rgraph-register-crosses-call? *current-rgraph*) register)) -(define-integrable (register-crosses-call! register) +(define (register-crosses-call! register) (bit-string-set! (rgraph-register-crosses-call? *current-rgraph*) register)) -(define-integrable (register-contains-non-object? register) - (memq register (rgraph-non-object-registers *current-rgraph*))) \ No newline at end of file +(define (pseudo-register-value-class register) + (vector-ref (rgraph-register-value-classes *current-rgraph*) register)) + +(define (pseudo-register-known-value register) + (vector-ref (rgraph-register-known-values *current-rgraph*) register)) + +(define (register-value-class register) + (if (machine-register? register) + (machine-register-value-class register) + (pseudo-register-value-class register))) + +(define (register-known-value register) + (if (machine-register? register) + (machine-register-known-value register) + (pseudo-register-known-value register))) \ No newline at end of file diff --git a/v7/src/compiler/rtlbase/rtlty1.scm b/v7/src/compiler/rtlbase/rtlty1.scm index 459ecebd9..6c50ed491 100644 --- a/v7/src/compiler/rtlbase/rtlty1.scm +++ b/v7/src/compiler/rtlbase/rtlty1.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlty1.scm,v 4.15 1989/12/05 20:51:48 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlty1.scm,v 4.16 1990/01/18 22:45:49 cph Exp $ -Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology +Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -36,54 +36,92 @@ MIT in each case. |# (declare (usual-integrations)) -(define-rtl-expression char->ascii rtl: expression) -(define-rtl-expression byte-offset rtl: register number) +;;; These three lists will be filled in by the type definitions that +;;; follow. See those macros for details. +(define rtl:expression-types '()) +(define rtl:statement-types '()) +(define rtl:predicate-types '()) + (define-rtl-expression register % number) + +;;; Scheme object +(define-rtl-expression constant % value) + +;;; Memory references that return Scheme objects +(define-rtl-expression offset rtl: base number) +(define-rtl-expression pre-increment rtl: register number) +(define-rtl-expression post-increment rtl: register number) + +;;; Memory reference that returns ASCII integer +(define-rtl-expression byte-offset rtl: base number) + +;;; Generic arithmetic operations on Scheme number objects +;;; (define-rtl-expression generic-unary rtl: operator operand) +;;; (define-rtl-expression generic-binary rtl: operator operand-1 operand-2) + +;;; Code addresses +(define-rtl-expression entry:continuation rtl: continuation) +(define-rtl-expression entry:procedure rtl: procedure) + +;;; Allocating a closure object (returns its address) +(define-rtl-expression cons-closure rtl: procedure min max size) + +;;; Cache addresses +(define-rtl-expression assignment-cache rtl: name) +(define-rtl-expression variable-cache rtl: name) + +;;; Get the address of a Scheme object (define-rtl-expression object->address rtl: expression) + +;;; Convert between a datum and an address +;;; (define-rtl-expression datum->address rtl: expression) +;;; (define-rtl-expression address->datum rtl: expression) + +;;; Add a constant offset to an address +(define-rtl-expression offset-address rtl: base number) + +;;; A machine constant (an integer, usually unsigned) +(define-rtl-expression machine-constant rtl: value) + +;;; Destructuring Scheme objects (define-rtl-expression object->datum rtl: expression) (define-rtl-expression object->type rtl: expression) +(define-rtl-expression cons-pointer rtl: type datum) + +;;; Convert a character object to an ASCII machine integer +(define-rtl-expression char->ascii rtl: expression) + +;;; Conversion between fixnum objects and machine integers (define-rtl-expression object->fixnum rtl: expression) (define-rtl-expression object->unsigned-fixnum rtl: expression) (define-rtl-expression fixnum->object rtl: expression) + +;;; Conversion between machine integers and addresses (define-rtl-expression fixnum->address rtl: expression) (define-rtl-expression address->fixnum rtl: expression) -(define-rtl-expression float->object rtl: expression) -(define-rtl-expression @address->float rtl: expression) -(define-rtl-expression offset rtl: register number) -(define-rtl-expression pre-increment rtl: register number) -(define-rtl-expression post-increment rtl: register number) - -(define-rtl-expression cons-closure rtl: procedure min max size) -(define-rtl-expression cons-pointer rtl: type datum) -(define-rtl-expression constant % value) -(define-rtl-expression assignment-cache rtl: name) -(define-rtl-expression variable-cache rtl: name) -(define-rtl-expression entry:continuation rtl: continuation) -(define-rtl-expression entry:procedure rtl: procedure) -(define-rtl-expression offset-address rtl: register number) -(define-rtl-expression unassigned rtl:) +;;; Machine integer arithmetic operations (define-rtl-expression fixnum-1-arg rtl: operator operand overflow?) (define-rtl-expression fixnum-2-args rtl: operator operand-1 operand-2 overflow?) -(define-rtl-predicate fixnum-pred-1-arg % predicate operand) -(define-rtl-predicate fixnum-pred-2-args % predicate operand-1 operand-2) +;;; Conversion between flonums and machine floats +(define-rtl-expression float->object rtl: expression) +(define-rtl-expression @address->float rtl: expression) +;;; Floating-point arithmetic operations (define-rtl-expression flonum-1-arg rtl: operator operand overflow?) (define-rtl-expression flonum-2-args rtl: operator operand-1 operand-2 overflow?) + +(define-rtl-predicate fixnum-pred-1-arg % predicate operand) +(define-rtl-predicate fixnum-pred-2-args % predicate operand-1 operand-2) (define-rtl-predicate flonum-pred-1-arg % predicate operand) (define-rtl-predicate flonum-pred-2-args % predicate operand-1 operand-2) -(define-rtl-expression generic-unary rtl: operator operand) -(define-rtl-expression generic-binary rtl: operator operand-1 operand-2) - (define-rtl-predicate eq-test % expression-1 expression-2) -(define-rtl-predicate true-test % expression) (define-rtl-predicate type-test % expression type) -(define-rtl-predicate unassigned-test % expression) (define-rtl-predicate overflow-test rtl:) diff --git a/v7/src/compiler/rtlbase/rtlty2.scm b/v7/src/compiler/rtlbase/rtlty2.scm index e09d13099..fa6dfaa00 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.7 1989/10/26 07:38:39 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlty2.scm,v 4.8 1990/01/18 22:45:53 cph Exp $ -Copyright (c) 1988, 1989 Massachusetts Institute of Technology +Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -36,6 +36,7 @@ MIT in each case. |# (declare (usual-integrations)) +(define-integrable rtl:expression? pair?) (define-integrable rtl:expression-type car) (define-integrable rtl:address-register cadr) (define-integrable rtl:address-number caddr) @@ -46,11 +47,6 @@ MIT in each case. |# (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 diff --git a/v7/src/compiler/rtlbase/valclass.scm b/v7/src/compiler/rtlbase/valclass.scm index a99adaed4..06208eb0d 100644 --- a/v7/src/compiler/rtlbase/valclass.scm +++ b/v7/src/compiler/rtlbase/valclass.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/valclass.scm,v 1.1 1989/07/25 12:05:17 arthur Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/valclass.scm,v 1.2 1990/01/18 22:45:58 cph Rel $ -Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology +Copyright (c) 1989, 1990 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -32,148 +32,89 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. |# -;;;; Register Transfer Language Value Classes +;;;; RTL Value Classes (declare (usual-integrations)) -;;;; Association between RTL expression types and their value classifiers. - -(package (define-value-classifier rtl->value-class) - - (define mapping '()) - - (define-export (define-value-classifier rtl-type value-classifier) - (let ((find (assq rtl-type mapping))) - (if find - (set-cdr! find value-classifier) - (set! mapping (cons (cons rtl-type value-classifier) mapping))))) - - (define (rtl-type->value-classifier rtl-type) - (let ((entry (assq rtl-type mapping))) - (and entry (cdr entry)))) - - ;;; If no classifier is found for the RTL-type, classify as VALUE (least - ;;; specific value class). - (define-export (rtl->value-class rtl) - (let ((classify (rtl-type->value-classifier (rtl:expression-type rtl)))) - (if classify - (if (symbol? classify) - classify - (classify rtl)) - 'VALUE))) -) +(define-structure (value-class + (conc-name value-class/) + (constructor %make-value-class (name parent)) + (print-procedure + (unparser/standard-method 'VALUE-CLASS + (lambda (state class) + (unparse-object state (value-class/name class)))))) + (name false read-only true) + (parent false read-only true) + (children '()) + (properties (make-1d-table) read-only true)) + +(define (make-value-class name parent) + (let ((class (%make-value-class name parent))) + (if parent + (set-value-class/children! + parent + (cons class (value-class/children parent)))) + class)) + +(define (value-class/ancestor-or-self? class ancestor) + (or (eq? class ancestor) + (let loop ((class (value-class/parent class))) + (and class + (or (eq? class ancestor) + (loop (value-class/parent class))))))) + +(define (value-class/ancestry class) + (value-class/partial-ancestry class value-class=value)) + +(define (value-class/partial-ancestry class ancestor) + (let loop ((class* class) (ancestry '())) + (if (not class*) + (error "value-class not an ancestor" class ancestor)) + (let ((ancestry (cons class* ancestry))) + (if (eq? class* ancestor) + ancestry + (loop (value-class/parent class*) ancestry))))) + +(define (value-class/nearest-common-ancestor x y) + (let loop + ((join false) + (x (value-class/ancestry x)) + (y (value-class/ancestry y))) + (if (and (not (null? x)) + (not (null? y)) + (eq? (car x) (car y))) + (loop (car x) (cdr x) (cdr y)) + join))) -;;;; Procedures for determining the compatibility of value classes of registers. - -(package (register-holds-value-in-class? - register-holds-compatible-value?) - - ;;; Hierarchy of value classes: - ;;; - ;;; VALUE -+-> WORD --+-> OBJECT - ;;; | | - ;;; +-> FLOAT +-> UNBOXED - ;;; - ;;; VALUE is the all-encompassing value class. - ;;; - ;;; A "breakdown" may appear anywhere in the tree where a class might, and - ;;; represents the class named in the first argument and all its subclasses - ;;; (the second through nth arguments, which may also be breakdowns). - ;;; Subclasses are classes which are considered to be compatible with, but - ;;; more specific than, their parent. A breakdown is a node, and simple - ;;; classes are leaves. - - (define (make-breakdown class . subclasses) - (cons class (list->vector subclasses))) - - (define (breakdown? object) - (pair? object)) - - (define (breakdown/class breakdown) - (car breakdown)) - - (define (breakdown/subclasses breakdown) - (cdr breakdown)) - - (define value-class-structure - (make-breakdown - 'VALUE - (make-breakdown 'WORD - 'OBJECT - 'UNBOXED) - 'FLOAT)) - - ;;; Find a path (list) from the top of the value class structure to CLASS. - (define (find-path class) - (let outer ((structure value-class-structure) - (path '())) - (if (breakdown? structure) - (let ((name (breakdown/class structure))) - (if (eq? class name) - (cons class path) - (let ((subclasses (breakdown/subclasses structure))) - (let inner ((index (-1+ (vector-length subclasses)))) - (if (>= index 0) - (or (outer (vector-ref subclasses index) - (cons name path)) - (inner (-1+ index))) - '()))))) - (and (eq? class structure) (cons class path))))) - - ;;; Return #f iff SUPER is neither a superclass of CLASS nor the same as - ;;; CLASS. - (define (value-class/compatible? super class) - (let ((path (find-path class))) - (if path - (memq super path) - (error "No such class" class)))) - - (define-export (register-holds-value-in-class? register value-class) - (eq? value-class (rgraph-register-value-class *current-rgraph* register))) - - (define-export (register-holds-compatible-value? register value-class) - (value-class/compatible? - value-class - (rgraph-register-value-class *current-rgraph* register))) -) - -;;;; Pseudo-register classifiers - -(let-syntax ((make-pseudo-check - (macro (value-class) - `(define (,(symbol-append 'pseudo- value-class '?) register) - (and (pseudo-register? register) - (register-holds-compatible-value? register ',value-class)))))) - (make-pseudo-check FLOAT) - (make-pseudo-check OBJECT) - (make-pseudo-check UNBOXED)) - -;; Assume word register if not float register. - -(define (pseudo-word? register) - (and (pseudo-register? register) - (not (register-holds-compatible-value? register 'FLOAT)))) - -;;;; RTL expression value classifiers - -(define-value-classifier '@ADDRESS->FLOAT 'FLOAT) -(define-value-classifier 'FLONUM-1-ARG 'FLOAT) -(define-value-classifier 'FLONUM-2-ARGS 'FLOAT) - -(define-value-classifier 'OFFSET - (lambda (rtl) - (if (rtl:offset? rtl) - (let ((register (rtl:register-number (rtl:offset-register rtl)))) - (if (pseudo-register? register) - (rgraph-register-value-class *current-rgraph* register) - 'VALUE)) - (error "Not an offset expression")))) - -(define-value-classifier 'REGISTER - (lambda (rtl) - (if (rtl:register? rtl) - (let ((register (rtl:register-number rtl))) - (if (pseudo-register? register) - (rgraph-register-value-class *current-rgraph* register) - 'VALUE)) - (error "Not a register expression")))) \ No newline at end of file +(let-syntax + ((define-value-class + (lambda (name parent-name) + (let* ((name->variable + (lambda (name) (symbol-append 'VALUE-CLASS= name))) + (variable (name->variable name))) + `(BEGIN + (DEFINE ,variable + (MAKE-VALUE-CLASS ',name + ,(if parent-name + (name->variable parent-name) + `#F))) + (DEFINE (,(symbol-append variable '?) CLASS) + (VALUE-CLASS/ANCESTOR-OR-SELF? CLASS ,variable)) + (DEFINE + (,(symbol-append 'REGISTER- variable '?) REGISTER) + (VALUE-CLASS/ANCESTOR-OR-SELF? (REGISTER-VALUE-CLASS REGISTER) + ,variable))))))) + +(define-value-class value #f) +(define-value-class float value) +(define-value-class word value) +(define-value-class object word) +(define-value-class unboxed word) +(define-value-class address unboxed) +(define-value-class immediate unboxed) +(define-value-class ascii immediate) +(define-value-class datum immediate) +(define-value-class fixnum immediate) +(define-value-class type immediate) + +) \ No newline at end of file diff --git a/v7/src/compiler/rtlgen/opncod.scm b/v7/src/compiler/rtlgen/opncod.scm index 7eb13f7f5..c08584604 100644 --- a/v7/src/compiler/rtlgen/opncod.scm +++ b/v7/src/compiler/rtlgen/opncod.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/opncod.scm,v 4.33 1989/12/05 20:51:13 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/opncod.scm,v 4.34 1990/01/18 22:46:50 cph Exp $ -Copyright (c) 1988, 1989 Massachusetts Institute of Technology +Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -41,8 +41,7 @@ MIT in each case. |# ;; These allows each port to open code a subset of everything below. (define-integrable (available-primitive? prim) - (lambda (prim) - (not (memq prim compiler:primitives-with-no-open-coding)))) + (not (memq prim compiler:primitives-with-no-open-coding))) (define (open-coding-analysis applications) (for-each (if compiler:open-code-primitives? @@ -455,15 +454,15 @@ MIT in each case. |# address-units-per-packed-char))) (define (rtl:length-fetch locative) - (rtl:make-cons-pointer (rtl:make-constant (ucode-type fixnum)) + (rtl:make-cons-pointer (rtl:make-machine-constant (ucode-type fixnum)) (rtl:make-fetch locative))) (define (rtl:vector-length-fetch locative) - (rtl:make-cons-pointer (rtl:make-constant (ucode-type fixnum)) + (rtl:make-cons-pointer (rtl:make-machine-constant (ucode-type fixnum)) (rtl:make-object->datum (rtl:make-fetch locative)))) (define (rtl:string-fetch locative) - (rtl:make-cons-pointer (rtl:make-constant (ucode-type character)) + (rtl:make-cons-pointer (rtl:make-machine-constant (ucode-type character)) (rtl:make-fetch locative))) (define (rtl:string-assignment locative value) @@ -494,7 +493,7 @@ MIT in each case. |# (simple-open-coder (lambda (combination expressions finish) combination - (finish (pcfg-invert (rtl:make-true-test (car expressions))))) + (finish (rtl:make-false-test (car expressions)))) '(0) false)) @@ -530,7 +529,7 @@ MIT in each case. |# (lambda (combination expressions finish) combination (finish - (rtl:make-typed-cons:pair (rtl:make-constant type) + (rtl:make-typed-cons:pair (rtl:make-machine-constant type) (car expressions) (cadr expressions))))))) @@ -547,7 +546,7 @@ MIT in each case. |# combination (finish (rtl:make-typed-cons:vector - (rtl:make-constant (ucode-type vector)) + (rtl:make-machine-constant (ucode-type vector)) expressions))) (all-operand-indices operands) false) @@ -576,7 +575,7 @@ MIT in each case. |# (list (open-code:nonnegative-check length)) (finish (rtl:make-typed-cons:string - (rtl:make-constant (ucode-type string)) + (rtl:make-machine-constant (ucode-type string)) length)) finish 'STRING-ALLOCATE @@ -726,7 +725,7 @@ MIT in each case. |# (list (open-code:type-check char (ucode-type character))) (finish (rtl:make-cons-pointer - (rtl:make-constant (ucode-type fixnum)) + (rtl:make-machine-constant (ucode-type fixnum)) (rtl:make-object->datum char))) finish 'CHAR->INTEGER diff --git a/v7/src/compiler/rtlgen/rgrval.scm b/v7/src/compiler/rtlgen/rgrval.scm index ee6f23d9e..3bb36ae61 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.14 1989/10/26 07:39:12 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgrval.scm,v 4.15 1990/01/18 22:47:04 cph Exp $ #| -*-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.14 1989/10/26 07:39:12 cph Exp $ + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgrval.scm,v 4.15 1990/01/18 22:47:04 cph Exp $ Copyright (c) 1988, 1990 Massachusetts Institute of Technology @@ -173,7 +173,7 @@ promotional, or sales literature without prior written consent from (define (make-trivial-closure-cons procedure) (enqueue-procedure! procedure) (rtl:make-cons-pointer - (rtl:make-constant type-code:compiled-entry) + (rtl:make-machine-constant type-code:compiled-entry) (rtl:make-entry:procedure (procedure-label procedure)))) (else @@ -193,7 +193,8 @@ promotional, or sales literature without prior written consent from '() false))) (let ((kernel - (rtl:make-constant (scode/procedure-type-code header)) + (lambda (scfg expression) + (values scfg (rtl:make-typed-cons:pair (rtl:make-machine-constant (scode/procedure-type-code header)) @@ -210,7 +211,7 @@ promotional, or sales literature without prior written consent from ;; inside another IC procedure? (define (make-non-trivial-closure-cons procedure) (rtl:make-cons-pointer - (rtl:make-constant type-code:compiled-entry) + (rtl:make-machine-constant type-code:compiled-entry) (with-values (lambda () (procedure-arity-encoding procedure)) (lambda (min max) (rtl:make-cons-closure diff --git a/v7/src/compiler/rtlgen/rgstmt.scm b/v7/src/compiler/rtlgen/rgstmt.scm index ebbf297b0..a5494a10d 100644 --- a/v7/src/compiler/rtlgen/rgstmt.scm +++ b/v7/src/compiler/rtlgen/rgstmt.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgstmt.scm,v 4.10 1988/12/30 07:11:11 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgstmt.scm,v 4.11 1990/01/18 22:47:15 cph Exp $ -Copyright (c) 1988 Massachusetts Institute of Technology +Copyright (c) 1988, 1990 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -133,12 +133,15 @@ MIT in each case. |# ;; a mistake to make blocks be rvalues in the first place. (let ((static-link-reference (lambda () - (rtl:make-environment - (block-ancestor-or-self->locative - (virtual-continuation/context operator) - operand - 0 - 0))))) + (let ((locative + (block-ancestor-or-self->locative + (virtual-continuation/context operator) + operand + 0 + 0))) + (if (stack-block? operand) + (rtl:make-environment locative) + locative))))) (enumeration-case continuation-type (virtual-continuation/type operator) ((EFFECT) diff --git a/v7/src/compiler/rtlopt/rcompr.scm b/v7/src/compiler/rtlopt/rcompr.scm index 9f39dd649..78fb6f4c6 100644 --- a/v7/src/compiler/rtlopt/rcompr.scm +++ b/v7/src/compiler/rtlopt/rcompr.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcompr.scm,v 1.9 1989/11/02 08:07:46 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcompr.scm,v 1.10 1990/01/18 22:47:38 cph Rel $ -Copyright (c) 1988. 1989 Massachusetts Institute of Technology +Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -63,7 +63,7 @@ MIT in each case. |# (define (optimize-rtl bblock live rinst rtl) ;; Look for assignments whose address is a pseudo register. If that - ;; register has exactly one reference which is known to be in this + ;; register has exactly one reference that is known to be in this ;; basic block, it is a candidate for expression folding. (let ((register (and (rtl:assign? rtl) @@ -77,54 +77,107 @@ MIT in each case. |# (let ((expression (rtl:assign-expression rtl))) (if (not (rtl:expression-contains? expression rtl:volatile-expression?)) - (let ((next - (find-reference-instruction (rinst-next rinst) - register - expression))) - (if next - (fold-instructions! live - rinst - next - register - expression)))))))) + (with-values + (lambda () + (let ((next (rinst-next rinst))) + (if (rinst-dead-register? next register) + (values next expression) + (find-reference-instruction next + register + expression)))) + (lambda (next expression) + (if next + (fold-instructions! live + rinst + next + register + expression))))))))) (define (find-reference-instruction next register expression) - ;; Find the instruction which contains the single reference to + ;; Find the instruction that contains the single reference to ;; `register', and determine if it is possible to fold `expression' ;; into that instruction in `register's place. - (let ((search-stopping-at - (lambda (predicate) - (define (phi-1 next) - (and (not (predicate (rinst-rtl next))) - (phi-2 (rinst-next next)))) - (define (phi-2 next) - (if (rinst-dead-register? next register) - next - (phi-1 next))) - (phi-1 next)))) - (cond ((rinst-dead-register? next register) next) - ((interpreter-value-register? expression) - (search-stopping-at - (lambda (rtl) - (and (rtl:assign? rtl) - (interpreter-value-register? (rtl:assign-address rtl)))))) - ((rtl:stack-reference-expression? expression) - (search-stopping-at - (lambda (rtl) - (or (and (rtl:assign? rtl) - (equal? (rtl:assign-address rtl) expression)) - (expression-clobbers-stack-pointer? rtl))))) - ((and (rtl:offset-address? expression) - (interpreter-stack-pointer? - (rtl:offset-address-register expression))) - (search-stopping-at expression-clobbers-stack-pointer?)) - ((rtl:constant-expression? expression) - (let loop ((next (rinst-next next))) - (if (rinst-dead-register? next register) - next - (loop (rinst-next next))))) - (else false)))) - + (let loop ((expression expression)) + (let ((search-stopping-at + (lambda (expression predicate) + (define (phi-1 next) + (if (predicate (rinst-rtl next)) + (values false false) + (phi-2 (rinst-next next)))) + (define (phi-2 next) + (if (rinst-dead-register? next register) + (values next expression) + (phi-1 next))) + (phi-1 next))) + (recursion + (lambda (unwrap wrap) + (with-values + (lambda () + (loop (unwrap expression))) + (lambda (next expression) + (if next + (values next (wrap expression)) + (values false false))))))) + (cond ((interpreter-value-register? expression) + (search-stopping-at expression + (lambda (rtl) + (and (rtl:assign? rtl) + (interpreter-value-register? + (rtl:assign-address rtl)))))) + ((and (rtl:offset? expression) + (interpreter-stack-pointer? (rtl:offset-base expression))) + (let () + (define (phi-1 next offset) + (let ((rtl (rinst-rtl next))) + (cond ((expression-is-stack-push? rtl) + (phi-2 (rinst-next next) (1+ offset))) + ((or (and (rtl:assign? rtl) + (rtl:expression=? (rtl:assign-address rtl) + expression)) + (expression-clobbers-stack-pointer? rtl)) + (values false false)) + (else + (phi-2 (rinst-next next) offset))))) + (define (phi-2 next offset) + (if (rinst-dead-register? next register) + (values next + (rtl:make-offset (rtl:offset-base expression) + offset)) + (phi-1 next offset))) + (phi-1 next (rtl:offset-number expression)))) + ((and (rtl:offset-address? expression) + (interpreter-stack-pointer? + (rtl:offset-address-base expression))) + (search-stopping-at expression + expression-clobbers-stack-pointer?)) + ((rtl:constant-expression? expression) + (let loop ((next (rinst-next next))) + (if (rinst-dead-register? next register) + (values next expression) + (loop (rinst-next next))))) + ((rtl:offset? expression) + (search-stopping-at expression + (lambda (rtl) + (or (and (rtl:assign? rtl) + (memq (rtl:expression-type + (rtl:assign-address rtl)) + '(OFFSET POST-INCREMENT PRE-INCREMENT))) + (expression-clobbers-stack-pointer? rtl))))) + ((rtl:object->address? expression) + (recursion rtl:object->address-expression + rtl:make-object->address)) + ((rtl:object->datum? expression) + (recursion rtl:object->datum-expression rtl:make-object->datum)) + ((rtl:object->fixnum? expression) + (recursion rtl:object->fixnum-expression rtl:make-object->fixnum)) + ((rtl:object->type? expression) + (recursion rtl:object->type-expression rtl:make-object->type)) + ((rtl:object->unsigned-fixnum? expression) + (recursion rtl:object->unsigned-fixnum-expression + rtl:make-object->unsigned-fixnum)) + (else + (values false false)))))) + (define (expression-clobbers-stack-pointer? rtl) (or (and (rtl:assign? rtl) (rtl:register? (rtl:assign-address rtl)) @@ -142,7 +195,15 @@ MIT in each case. |# (rtl:post-increment-register expression))) (else (loop expression)))))))) - + +(define (expression-is-stack-push? rtl) + (and (rtl:assign? rtl) + (let ((address (rtl:assign-address rtl))) + (and (rtl:pre-increment? address) + (interpreter-stack-pointer? + (rtl:pre-increment-register address)) + (= -1 (rtl:pre-increment-number address)))))) + (define (fold-instructions! live rinst next register expression) ;; Attempt to fold `expression' into the place of `register' in the ;; RTL instruction `next'. If the resulting instruction is @@ -156,15 +217,44 @@ MIT in each case. |# (begin (set-rinst-rtl! rinst false) (set-rinst-rtl! next rtl) - (let ((dead (rinst-dead-registers rinst))) - (for-each increment-register-live-length! dead) + (for-each-regset-member live decrement-register-live-length!) + (let ((dead + (new-dead-registers + (rinst-next rinst) + next + (rinst-dead-registers rinst) + (rtl:expression-register-references expression)))) (set-rinst-dead-registers! next (eqv-set-union dead (delv! register (rinst-dead-registers next))))) - (for-each-regset-member live decrement-register-live-length!) (reset-register-n-refs! register) (reset-register-n-deaths! register) (reset-register-live-length! register) - (set-register-bblock! register false))))))) \ No newline at end of file + (set-register-bblock! register false))))))) + +(define (new-dead-registers rinst next old-dead registers) + (let loop ((rinst rinst) (new-dead old-dead)) + (for-each increment-register-live-length! new-dead) + (if (eq? rinst next) + new-dead + (let* ((dead (rinst-dead-registers rinst)) + (dead* (eqv-set-intersection dead registers))) + (if (not (null? dead*)) + (begin + (set-rinst-dead-registers! + rinst + (eqv-set-difference dead dead*)) + (loop (rinst-next rinst) (eqv-set-union dead* new-dead))) + (loop (rinst-next rinst) new-dead)))))) + +(define (rtl:expression-register-references expression) + (let ((registers '())) + (let loop ((expression expression)) + (if (rtl:pseudo-register-expression? expression) + (let ((register (rtl:register-number expression))) + (if (not (memv register registers)) + (set! registers (cons register registers)))) + (rtl:for-each-subexpression expression loop))) + registers)) \ No newline at end of file diff --git a/v7/src/compiler/rtlopt/rcse1.scm b/v7/src/compiler/rtlopt/rcse1.scm index 666ad9c5a..5b5660982 100644 --- a/v7/src/compiler/rtlopt/rcse1.scm +++ b/v7/src/compiler/rtlopt/rcse1.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcse1.scm,v 4.19 1989/10/28 09:41:27 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcse1.scm,v 4.20 1990/01/18 22:47:43 cph Rel $ -Copyright (c) 1988, 1989 Massachusetts Institute of Technology +Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -90,7 +90,9 @@ MIT in each case. |# (make-state (register-tables/copy *register-tables*) (hash-table-copy *hash-table*) *stack-offset* - (list-copy *stack-reference-quantities*))) + (map (lambda (entry) + (cons (car entry) (quantity-copy (cdr entry)))) + *stack-reference-quantities*))) (define (walk-bblock bblock) (let loop ((rinst (bblock-instructions bblock))) @@ -171,8 +173,7 @@ MIT in each case. |# (define (cse/assign/register address expression volatile? insert-source!) (if (interpreter-stack-pointer? address) (if (and (rtl:offset? expression) - (interpreter-stack-pointer? - (rtl:offset-register expression))) + (interpreter-stack-pointer? (rtl:offset-base expression))) (stack-pointer-adjust! (rtl:offset-number expression)) (begin (stack-invalidate!) @@ -305,14 +306,8 @@ MIT in each case. |# rtl:flonum-pred-2-args-operand-1 rtl:set-flonum-pred-2-args-operand-1! rtl:flonum-pred-2-args-operand-2 rtl:set-flonum-pred-2-args-operand-2!) -(define-trivial-one-arg-method 'TRUE-TEST - rtl:true-test-expression rtl:set-true-test-expression!) - (define-trivial-one-arg-method 'TYPE-TEST rtl:type-test-expression rtl:set-type-test-expression!) - -(define-trivial-one-arg-method 'UNASSIGNED-TEST - rtl:type-test-expression rtl:set-unassigned-test-expression!) (define (method/noop statement) statement diff --git a/v7/src/compiler/rtlopt/rcse2.scm b/v7/src/compiler/rtlopt/rcse2.scm index 6e0b2a9b7..c66836f2a 100644 --- a/v7/src/compiler/rtlopt/rcse2.scm +++ b/v7/src/compiler/rtlopt/rcse2.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$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 $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcse2.scm,v 4.13 1990/01/18 22:47:49 cph Rel $ -Copyright (c) 1988, 1989 Massachusetts Institute of Technology +Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -116,7 +116,7 @@ MIT in each case. |# ;; memory for purposes of invalidation. This is because ;; (supposedly) no one ever accesses the stack directly ;; except the compiler's output, which is explicit. - (if (interpreter-stack-pointer? (rtl:offset-register expression)) + (if (interpreter-stack-pointer? (rtl:offset-base expression)) (quantity-number (stack-reference-quantity expression)) (begin (set! hash-arg-in-memory? true) @@ -271,7 +271,7 @@ MIT in each case. |# (define (non-object-invalidate!) (hash-table-delete-class! (lambda (element) - (rtl:non-object-valued-expression? (element-expression element))))) + (not (rtl:object-valued-expression? (element-expression element)))))) (define (varying-address-invalidate!) (hash-table-delete-class! diff --git a/v7/src/compiler/rtlopt/rcseep.scm b/v7/src/compiler/rtlopt/rcseep.scm index 4124d79fd..ea552ae2b 100644 --- a/v7/src/compiler/rtlopt/rcseep.scm +++ b/v7/src/compiler/rtlopt/rcseep.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcseep.scm,v 4.5 1988/08/29 23:18:23 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcseep.scm,v 4.6 1990/01/18 22:47:53 cph Rel $ -Copyright (c) 1987 Massachusetts Institute of Technology +Copyright (c) 1987, 1988, 1990 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -43,19 +43,15 @@ MIT in each case. |# (define (loop x y) (let ((type (rtl:expression-type x))) (and (eq? type (rtl:expression-type y)) - (case type - ((REGISTER) - (register-equivalent? x y)) - ((OFFSET BYTE-OFFSET) - (let ((rx (rtl:offset-register x))) - (and (register-equivalent? rx (rtl:offset-register y)) - (if (interpreter-stack-pointer? rx) - (eq? (stack-reference-quantity x) - (stack-reference-quantity y)) - (= (rtl:offset-number x) - (rtl:offset-number y)))))) - (else - (rtl:match-subexpressions x y loop)))))) + (cond ((eq? type 'REGISTER) + (register-equivalent? x y)) + ((and (memq type '(OFFSET BYTE-OFFSET)) + (interpreter-stack-pointer? (rtl:offset-base x))) + (and (interpreter-stack-pointer? (rtl:offset-base y)) + (eq? (stack-reference-quantity x) + (stack-reference-quantity y)))) + (else + (rtl:match-subexpressions x y loop)))))) (define (register-equivalent? x y) (let ((x (rtl:register-number x)) @@ -75,9 +71,9 @@ MIT in each case. |# (rtl:any-subexpression? x loop)))) (loop x)) -(define-integrable (interpreter-register-reference? expression) +(define (interpreter-register-reference? expression) (and (rtl:offset? expression) - (interpreter-regs-pointer? (rtl:offset-register expression)))) + (interpreter-regs-pointer? (rtl:offset-base expression)))) (define (expression-address-varies? expression) (and (not (interpreter-register-reference? expression)) diff --git a/v7/src/compiler/rtlopt/rcseht.scm b/v7/src/compiler/rtlopt/rcseht.scm index 20db64709..18bfa1a19 100644 --- a/v7/src/compiler/rtlopt/rcseht.scm +++ b/v7/src/compiler/rtlopt/rcseht.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$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 $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcseht.scm,v 4.10 1990/01/18 22:47:57 cph Exp $ -Copyright (c) 1988, 1989 Massachusetts Institute of Technology +Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -96,8 +96,7 @@ MIT in each case. |# (loop (element-next-value x)))))) (else (set-element-first-value! element class) - (let loop ((previous class) - (next (element-next-value class))) + (let loop ((previous class) (next (element-next-value class))) (cond ((not next) (set-element-next-value! element false) (set-element-next-value! previous element) @@ -131,8 +130,7 @@ MIT in each case. |# (if next (set-element-previous-hash! next previous)) (if previous (set-element-next-hash! previous next) - (hash-table-set! hash next))))) - unspecific) + (hash-table-set! hash next)))))) (define (hash-table-delete-class! predicate) (let table-loop ((i 0)) @@ -140,35 +138,9 @@ MIT in each case. |# (let bucket-loop ((element (hash-table-ref i))) (if element (begin - (if (predicate element) - (hash-table-delete! i element)) + (if (predicate element) (hash-table-delete! i element)) (bucket-loop (element-next-hash element))) - (table-loop (1+ i)))))) - unspecific) - -(define (rtl:expression-cost expression) - (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))))) + (table-loop (1+ i))))))) (define (hash-table-copy table) ;; During this procedure, the `element-cost' slots of `table' are diff --git a/v7/src/compiler/rtlopt/rinvex.scm b/v7/src/compiler/rtlopt/rinvex.scm index b5da9f310..1d8971315 100644 --- a/v7/src/compiler/rtlopt/rinvex.scm +++ b/v7/src/compiler/rtlopt/rinvex.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rinvex.scm,v 1.2 1989/07/25 12:31:04 arthur Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rinvex.scm,v 1.3 1990/01/18 22:48:02 cph Exp $ -Copyright (c) 1989 Massachusetts Institute of Technology +Copyright (c) 1989, 1990 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -220,18 +220,10 @@ MIT in each case. |# rtl:flonum-pred-1-arg-operand rtl:set-flonum-pred-1-arg-operand!) -(define-one-arg-method 'TRUE-TEST - rtl:true-test-expression - rtl:set-true-test-expression!) - (define-one-arg-method 'TYPE-TEST rtl:type-test-expression rtl:set-type-test-expression!) -(define-one-arg-method 'UNASSIGNED-TEST - rtl:type-test-expression - rtl:set-unassigned-test-expression!) - (define-one-arg-method 'INVOCATION:CACHE-REFERENCE rtl:invocation:cache-reference-name rtl:set-invocation:cache-reference-name!)