#| -*-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
\f
;;;; 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)
(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))
\f
;;;; Output block generation
#| -*-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
(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
#| -*-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
'()
(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)))
#| -*-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
(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)
(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)))))))
#| -*-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
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))
\f
;; `*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
(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*)))
\f
;; 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)
(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))))
\f
(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)
(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)
(add-pseudo-register-alias *register-map* register alias false))
(need-register! alias))
\f
-(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
(set! *needed-registers* '())
instructions))
-(define-integrable (clear-map)
+(define (clear-map)
(clear-map-instructions *register-map*))
(define (clear-registers! . registers)
(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)))))
\f
(define (standard-register-reference register preferred-type alternate-types?)
;; Generate a standard reference for `register'. This procedure
(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,
(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)
machine-register))))
\f
(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))
;; 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))))))
\f
-;; 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)))))
-\f
-;;;; 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!))
-\f
\ 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
#| -*-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
(declare (usual-integrations))
\f
-(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
#| -*-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
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.
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.
|#
(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))
(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)
;;; 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)
#| -*-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
(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
#| -*-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
(declare (usual-integrations))
\f
-(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
(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))))
\f
(define-structure (cc-vector (constructor cc-vector/make)
(conc-name cc-vector/))
(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*))))
-\f
-;;;; 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
#| -*-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
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
(cross-link-end cross-compilation)
*result*)))
\f
-;; 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*)))))
\f
(define-structure (cc-vector (constructor cc-vector/make)
(conc-name cc-vector/))
#| -*-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
(else
(error "debug/where -- what?" object))))
\f
-(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
(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)
(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)))
'(LABEL CONTINUATION-ENTRY CONTINUATION-HEADER IC-PROCEDURE-HEADER
OPEN-PROCEDURE-HEADER PROCEDURE-HEADER CLOSURE-HEADER))
(newline))
- (*show-instruction* rtl))
+ (*show-instruction* rtl)
+ (newline))
\f
(define procedure-queue)
(define procedures-located)
#| -*-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
(PACKAGE ,transform/package)))
(syntax-table-define lap-generator-syntax-table 'DEFINE-RULE
transform/define-rule))
-\f
+
(define compiler-syntax-table
(make-syntax-table syntax-table/system-internal))
(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))
(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)))
(* 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)
`(,(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)))))))
\f
;;;; 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)))
-\f
+
(define transform/define-enumeration
(macro (name elements)
(let ((enumeration (symbol-append name 'S)))
#| -*-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
;;; 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)
(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)
#| -*-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
(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)))
+\f
(define (compiler-pathnames input-string output-string default transform)
(let* ((core
(lambda (input-string)
;;;; 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)
(define compiler:abort-handled? false)
(define compiler:abort-continuation)
\f
+;;; 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*)))
+\f
(define (compile-recursively scode procedure-result?)
;; Used by the compiler when it wants to compile subexpressions as
;; separate code-blocks.
(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
(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
(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*)
(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*)
(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*)
(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)
(*dbg-expression*)
(*dbg-procedures*)
(*dbg-continuations*)
- (*bits*)
+ (*lap*)
(*next-constant*)
(*interned-constants*)
(*interned-variables*)
(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)
(set! *dbg-expression*)
(set! *dbg-procedures*)
(set! *dbg-continuations*)
- (set! *bits*)
+ (set! *lap*)
(set! *next-constant*)
(set! *interned-constants*)
(set! *interned-variables*)
(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)
(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))
(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?
(phase/linearization-analysis)
(phase/register-allocation)
(phase/rtl-optimization-cleanup))))
+\f
+(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"
(compiler-subphase "Invertible Expression Elimination"
(lambda ()
(invertible-expression-elimination *rtl-graphs*))))
-\f
+
(define (phase/common-suffix-merging)
(compiler-subphase "Common Suffix Merging"
(lambda ()
(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))))))
\f
-(define (phase/bit-generation)
+(define (phase/lap-generation)
(compiler-phase "LAP Generation"
(lambda ()
(set! *next-constant* 0)
(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))
(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*
(set! *rtl-root*)
unspecific)))))
\f
+(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)
#| -*-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
(declare (usual-integrations))
\f
(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)))))
+\f
+(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)
(walk-rvalue (true-test-rvalue node)))))
((FG-NOOP)
(walk-next (snode-next node) '()))))
-\f
-(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
#| -*-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
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?
*rtl-procedures*
*rtl-graphs*)
(import (runtime compiler-info)
- make-dbg-info-vector))
+ make-dbg-info-vector)
+ (import (runtime unparser)
+ *unparse-uninterned-symbols-by-name?*))
\f
(define-package (compiler debug)
(files "base/debug")
(parent (compiler))
(export ()
- compiler:write-rtl-file
debug/find-continuation
debug/find-entry-node
debug/find-procedure
show-bblock-rtl
show-fg
show-fg-node
- show-rtl)
+ show-rtl
+ write-rtl-instructions)
(import (runtime pretty-printer)
*pp-primitives-by-name*))
(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)
(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))
(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))
"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
*interned-uuo-links*
*interned-variables*
*next-constant*
- generate-bits)
+ generate-lap)
(import (scode-optimizer expansion)
scode->scode-expander))
(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
#| -*-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
((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
#| -*-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
"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"
"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"
(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
(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")
(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
(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)
#| -*-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
(declare (usual-integrations))
\f
-;;;; Basic machine instructions
+;;;; Register-Allocator Interface
(define (reference->register-transfer source target)
(if (or (and (effective-address/data-register? source)
(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)))
(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))
+\f
+;;;; Basic Machine Instructions
+
(define-integrable (pseudo->machine-register source target)
(memory->machine-register (pseudo-register-home source) target))
(+ (+ (* 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))
(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)))))
\f
(define (load-dnl n d)
(cond ((zero? n)
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))))
\f
(define (test-byte n effective-address)
;; This is used to test actual bytes.
(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!
(LAP (B ,cc (@PCR ,label))))
(lambda (label)
(LAP (B ,(invert-cc cc) (@PCR ,label))))))
-\f
+
(define (invert-cc cc)
(cdr (or (assq cc
'((T . F) (F . T)
(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)))
(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)
(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
(LAP)
(LAP ,(instruction-gen)
,@(loop (-1+ n)))))))
-\f
-;;;; 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))
(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))))
\f
;;;; 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)
(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)))))
(define (machine-operation-target? target)
(or (rtl:register? target)
- (rtl:offset? target)))
+ (and (rtl:offset? target)
+ (rtl:register? (rtl:offset-base target)))))
\f
(define (two-arg-register-operation
operate commutative?
(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)))
;; `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)))))
+\f
;;;; CHAR->ASCII rules
(define (coerce->any/byte-reference register)
#| -*-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
(declare (usual-integrations))
\f
-(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)
(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 &/))
-\f
(define-integrable d0 0)
(define-integrable d1 1)
(define-integrable d2 2)
(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)
(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))
-\f
-(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))))
\f
-(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)))
+\f
+(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
#| -*-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
((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
#| -*-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
(declare (usual-integrations))
\f
-;;;; 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)))))
-\f
;;; 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
;;; 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))))
+\f
+(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))
-\f
-(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)))
+\f
+;;;; 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))
-\f
-(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))))
-\f
-(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)))
+\f
+;;;; 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))))
\f
;;;; Transfers to Memory
(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))))
(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)))
(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)))
(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)))))
\f
(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))))
(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)))))
\f
;;;; 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)))))
(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)))))
\f
(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
(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)
(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))
(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)
(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))
(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))
(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)
(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))))
(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))
(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))
#| -*-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
(declare (usual-integrations))
\f
(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)))))
(LAP (MOV L ,memory-1 ,temp)
(CMP L ,memory-2 ,temp))))
\f
-(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)
\f
(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))
(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
(compare/register*memory register
(INST-EA (@PCR ,(constant->label constant)))
'EQ)))
+\f
+(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))))
\f
;;;; Fixnum/Flonum Predicates
(define-rule predicate
(FIXNUM-PRED-1-ARG (? predicate) (REGISTER (? register)))
- (QUALIFIER (pseudo-register? register))
(set-standard-branches! (fixnum-predicate->cc predicate))
- (test-fixnum (standard-register-reference register 'DATA 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)
(predicate/memory-operand-reference memory-2)
(fixnum-predicate->cc predicate)))
\f
-(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)))
(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)
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))))
(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
#| -*-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
\f
(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!)
(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!)
(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)))
\f
(define-rule statement
(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)))
(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))
(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))
(& ,(+ (* (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 <entry>))
(MOV L ,temporary (@A+ 5))
(CLR W (@A+ 5))
#| -*-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
\f
;;;; 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
\f
(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
,(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))))
-\f
(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
(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
#| -*-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
(copier false)
(constructor make-rgraph (n-registers)))
n-registers
- (non-object-registers (reverse initial-non-object-registers))
entry-edges
bblocks
register-bblock
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))))
(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*)
#| -*-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
\f
;;;; 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)))))))
-\f
(define (rtl:make-eq-test expression-1 expression-2)
(expression-simplify-for-predicate expression-1
(lambda (expression-1)
(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
(%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))))
+\f
(define (rtl:make-fixnum-pred-1-arg predicate operand)
(expression-simplify-for-predicate operand
(lambda (operand)
(expression-simplify-for-predicate operand2
(lambda (operand2)
(%make-flonum-pred-2-args predicate operand1 operand2))))))
-\f
-(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
(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))))
\f
;;; Interpreter Calls
(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))))
+\f
+(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
(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")))))
-\f
-(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)))))))
-\f
-(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))))
+\f
(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
'())
-\f
+
(define-expression-method 'FETCH
(lambda (receiver scfg-append! locative)
(locative-dereference locative scfg-append!
(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))
(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))))))))
\f
(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)
(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
(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))
(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))))))))
-\f
(define-expression-method 'FIXNUM-2-ARGS
(lambda (receiver scfg-append! operator operand1 operand2 overflow?)
(expression-simplify operand1 scfg-append!
(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?)
(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!
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
#| -*-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
(declare (usual-integrations))
\f
-(define-integrable (rtl:invocation? rtl)
+(define (rtl:invocation? rtl)
(memq (rtl:expression-type rtl)
'(INVOCATION:APPLY
INVOCATION:JUMP
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)
(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)))))))
\f
(define (rtl:map-subexpressions expression procedure)
(if (rtl:constant? expression)
- (map identity-procedure expression)
+ expression
(cons (car expression)
(map (lambda (x)
(if (pair? x)
(lambda (x)
(or (not (pair? x))
(predicate x))))))
-\f
+
(define (rtl:reduce-subparts expression operator initial if-expression if-not)
(let ((remap
(if (rtl:constant? expression)
(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)))
;; 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)))))))))
\f
(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)))
-
+\f
(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
#| -*-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
(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
#| -*-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
(declare (usual-integrations))
\f
-(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?)
+\f
+(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:)
#| -*-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
(declare (usual-integrations))
\f
+(define-integrable rtl:expression? pair?)
(define-integrable rtl:expression-type car)
(define-integrable rtl:address-register cadr)
(define-integrable rtl:address-number caddr)
(define-integrable (rtl:set-invocation-continuation! rtl continuation)
(set-car! (cddr rtl) continuation))
-(define (rtl:make-constant value)
- (if (unassigned-reference-trap? value)
- (rtl:make-unassigned)
- (%make-constant value)))
-
;;;; Locatives
;;; Locatives are used as an intermediate form by the code generator
#| -*-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
promotional, or sales literature without prior written consent from
MIT in each case. |#
-;;;; Register Transfer Language Value Classes
+;;;; RTL Value Classes
(declare (usual-integrations))
\f
-;;;; 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)))
\f
-;;;; 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)))
-)
-\f
-;;;; 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))))
-\f
-;;;; 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
#| -*-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
;; 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?
address-units-per-packed-char)))
\f
(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)
(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))
(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)))))))
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)
(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
(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
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
(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
'()
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))
;; 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
#| -*-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
;; 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)
#| -*-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
(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)
(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)))))))))
\f
(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))))))
+\f
(define (expression-clobbers-stack-pointer? rtl)
(or (and (rtl:assign? rtl)
(rtl:register? (rtl:assign-address rtl))
(rtl:post-increment-register expression)))
(else
(loop expression))))))))
-\f
+
+(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
(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
#| -*-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
(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*)))
\f
(define (walk-bblock bblock)
(let loop ((rinst (bblock-instructions bblock)))
(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!)
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!)
\f
(define (method/noop statement)
statement
#| -*-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
;; 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)
(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!
#| -*-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
(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))
(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))
#| -*-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
(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)
(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))
(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)))))))
\f
(define (hash-table-copy table)
;; During this procedure, the `element-cost' slots of `table' are
#| -*-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
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!)
projects / mit-scheme.git / commitdiff