(*registers-to-delete* dead-registers)
(*prefix-instructions* (LAP))
(*suffix-instructions* (LAP))
- (*needed-registers* '()))
+ (*needed-registers* '())
+ (*target-machine-registers* '()))
+ (reserve-machine-targets! rtl)
(let ((instructions (match-result)))
(delete-dead-registers!)
(LAP ,@(if *insert-rtl?*
*assign-rules*)))
(or (and rules (pattern-lookup (cdr rules) rtl))
(pattern-lookup *assign-variable-rules* rtl)))))
+
+(define (reserve-machine-targets! rtl)
+ (if (rtl:assign? rtl)
+ (let ((address (rtl:assign-address rtl)))
+ (if (rtl:register? address)
+ (let ((register (rtl:register-number address)))
+ (if (and (machine-register? register)
+ (memv register available-machine-registers))
+ (target-machine-register! register)))))))
\f
;;; Instruction sequence sharing mechanisms
(define (dont-need-registers! registers)
(set! *needed-registers* (eqv-set-difference *needed-registers* registers)))
+;; `*target-machine-registers*' contains a set of machine registers
+;; that are targets for the current RTL instruction and as such must
+;; not be allocated as aliases for source registers.
+
+(define *target-machine-registers*)
+
+(define (target-machine-register! register)
+ (need-register! register)
+ (set! *target-machine-registers* (cons register *target-machine-registers*)))
+
+(define (untarget-machine-register! register)
+ (set! *target-machine-registers*
+ (delv! register *target-machine-registers*)))
+\f
;; `*dead-registers*' is initialized at the beginning of each RTL
;; instruction to the set of pseudo registers that become dead during
;; that instruction. This information is used to decide whether or
(set! *register-map*
(delete-pseudo-registers *register-map* *registers-to-delete*))
(set! *registers-to-delete* '())
+ (set! *target-machine-registers* '())
unspecific)
;; `*prefix-instructions*' is used to accumulate LAP instructions to
;; `register' may be any kind of register.
(if (machine-register? register)
(register-type? register type)
- (pseudo-register-alias *register-map* type register)))
+ (pseudo-register-alias *register-map*
+ type
+ register
+ *target-machine-registers*)))
(define (alias-is-unique? alias)
;; `alias' must be a valid alias for some pseudo register. This
(if (machine-register? register)
(and (register-type? register type) register)
(maybe-need-register!
- (pseudo-register-alias *register-map* type register))))
+ (pseudo-register-alias *register-map*
+ type
+ register
+ *target-machine-registers*))))
(define (guarantee-registers-compatible r1 r2)
(if (not (registers-compatible? r1 r2))
(if (and (machine-register? target)
(register-type? target type))
(begin
+ (untarget-machine-register! target)
(prefix-instructions!
(reference->register-transfer
(standard-register-reference source type true)
;; contents into that register.
(or (let ((entry (map-entries:find-home map home)))
(and entry
- (let ((alias (find (register-type-predicate type)
- (map-entry-aliases entry))))
+ (let ((alias (map-entry:find-alias entry type needed-registers)))
(and alias
(allocator-values alias map (LAP))))))
(bind-allocator-values (make-free-register map type needed-registers)
(register-type? type register*)))
(map-entry-aliases entry)))))
-(define (pseudo-register-alias map type register)
+(define (pseudo-register-alias map type register needed-registers)
"Returns a machine register, of the given TYPE, which is an alias
-for REGISTER. If no such register exists, returns #F."
+for REGISTER, except those in NEEDED-REGISTERS. If no such register
+exists, returns #F."
(let ((entry (map-entries:find-home map register)))
(and entry
- (find (register-type-predicate type)
- (map-entry-aliases entry)))))
+ (map-entry:find-alias entry type needed-registers))))
(define (machine-register-is-unique? map register)
"True if REGISTER has no other aliases."
;; Attempt to reuse source for target if it is in ST(0).
;; Otherwise we will target ST(0) by sorting the machine registers.
(cond ((and (pseudo-register? target) (pseudo-register? source)
- (eqv? fr0 (pseudo-register-alias *register-map* 'FLOAT source)))
+ (eqv? fr0
+ (pseudo-register-alias *register-map*
+ 'FLOAT
+ source
+ *target-machine-registers*)))
(reuse-pseudo-register-alias
source 'FLOAT
(lambda (alias)
(cond ((pseudo-register? target)
(let ((alias
(and (dead-register? source)
- (pseudo-register-alias *register-map* 'FLOAT source))))
+ (pseudo-register-alias *register-map*
+ 'FLOAT
+ source
+ *target-machine-registers*))))
(if alias
(default)))
(= 2 (register-n-refs register)))
(let ((expression (rtl:assign-expression rtl)))
(if (not (rtl:expression-contains? expression
- rtl:volatile-expression?))
+ nonfoldable-expression?))
(with-values
(lambda ()
(let ((next (rinst-next rinst)))
next
register
expression)))))))))
+
+(define (nonfoldable-expression? expression)
+ ;; We can't fold expressions with side effects or references to
+ ;; machine registers that are available for allocation, since they
+ ;; both depend on where they are in the RTL.
+ (or (rtl:volatile-expression? expression)
+ (and (rtl:register? expression)
+ (let ((register (rtl:register-number expression)))
+ (and (machine-register? register)
+ (memv register available-machine-registers))))))
\f
(define (find-reference-instruction next register expression)
;; Find the instruction that contains the single reference to
(+ (symbol-hash type)
(case type
((REGISTER)
- (quantity-number
- (get-register-quantity (rtl:register-number expression))))
+ (let ((register (rtl:register-number expression)))
+ (if (memv register available-machine-registers)
+ ;; This is a special-purpose register, like the
+ ;; value register or an interpreter call result
+ ;; register, which is also generally available
+ ;; for allocation. Since this may be assigned as
+ ;; an alias for other pseudo-registers in the
+ ;; future, don't let this get propagated past
+ ;; their assignments.
+ (set! do-not-record? true))
+ (quantity-number (get-register-quantity register))))
((OFFSET)
;; Note that stack-references do not get treated as
;; memory for purposes of invalidation. This is because
projects / mit-scheme.git / commitdiff