From 1bcf72d6b57c87e750c14554cd1642a2a5488020 Mon Sep 17 00:00:00 2001 From: Taylor R Campbell Date: Sun, 30 Dec 2018 21:01:00 +0000 Subject: [PATCH] Allow careful use of available machine registers in RTL. This will enable us to put fixed machine registers such as the value register carefully into the RTL even if they are ordinarily available as pseudo-register aliases for machine register allocation. - CGEN-RINST calls TARGET-MACHINE-REGISTER! if the target of an RTL instruction is a machine register that is ordinarily available for register allocation. - REGISTER-ALIAS declines to return any aliases reserved by TARGET-MACHINE-REGISTER!, until... - DELETE-DEAD-REGISTERS! makes the target machine registers available again for REGISTER-ALIAS so that they can be chosen as targets. (However, they still won't be chosen as temporaries.) - MOVE-TO-ALIAS-REGISTER! -- which may be used only after all other source registers have been chosen -- also allows the machine target to be used as a source alias in order to avoid unnecessary register motion. - Don't propagate RTL references to available machine registers in common subexpression elimination or in code compression. Since the machine register might be allocated as an alias for another register, it can't be moved around. The RTL generator ensures these references appear only at the beginning or end of a block where the machine register cannot be an alias for any live pseudo-register. --- src/compiler/back/lapgn1.scm | 13 ++++++++++++- src/compiler/back/lapgn2.scm | 26 ++++++++++++++++++++++++-- src/compiler/back/regmap.scm | 11 +++++------ src/compiler/machines/i386/rulflo.scm | 11 +++++++++-- src/compiler/rtlopt/rcompr.scm | 12 +++++++++++- src/compiler/rtlopt/rcse2.scm | 13 +++++++++++-- 6 files changed, 72 insertions(+), 14 deletions(-) diff --git a/src/compiler/back/lapgn1.scm b/src/compiler/back/lapgn1.scm index 822c19eb3..0d9193304 100644 --- a/src/compiler/back/lapgn1.scm +++ b/src/compiler/back/lapgn1.scm @@ -179,7 +179,9 @@ USA. (*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?* @@ -268,6 +270,15 @@ USA. *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))))))) ;;; Instruction sequence sharing mechanisms diff --git a/src/compiler/back/lapgn2.scm b/src/compiler/back/lapgn2.scm index 7d4d129b7..21e480964 100644 --- a/src/compiler/back/lapgn2.scm +++ b/src/compiler/back/lapgn2.scm @@ -61,6 +61,20 @@ USA. (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*))) + ;; `*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 @@ -90,6 +104,7 @@ USA. (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 @@ -133,7 +148,10 @@ USA. ;; `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 @@ -163,7 +181,10 @@ USA. (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)) @@ -368,6 +389,7 @@ USA. (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) diff --git a/src/compiler/back/regmap.scm b/src/compiler/back/regmap.scm index fa44e6179..1d2083a09 100644 --- a/src/compiler/back/regmap.scm +++ b/src/compiler/back/regmap.scm @@ -497,8 +497,7 @@ registers into some interesting sorting order. ;; 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) @@ -561,13 +560,13 @@ the same value as REGISTER. If no such register exists, returns #F." (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." diff --git a/src/compiler/machines/i386/rulflo.scm b/src/compiler/machines/i386/rulflo.scm index 20cd56c37..211a2d536 100644 --- a/src/compiler/machines/i386/rulflo.scm +++ b/src/compiler/machines/i386/rulflo.scm @@ -179,7 +179,11 @@ USA. ;; 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) @@ -222,7 +226,10 @@ USA. (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))) diff --git a/src/compiler/rtlopt/rcompr.scm b/src/compiler/rtlopt/rcompr.scm index 93c436292..85b9f6a19 100644 --- a/src/compiler/rtlopt/rcompr.scm +++ b/src/compiler/rtlopt/rcompr.scm @@ -69,7 +69,7 @@ USA. (= 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))) @@ -85,6 +85,16 @@ USA. 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)))))) (define (find-reference-instruction next register expression) ;; Find the instruction that contains the single reference to diff --git a/src/compiler/rtlopt/rcse2.scm b/src/compiler/rtlopt/rcse2.scm index ca2bf3cea..288a158df 100644 --- a/src/compiler/rtlopt/rcse2.scm +++ b/src/compiler/rtlopt/rcse2.scm @@ -101,8 +101,17 @@ USA. (+ (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 -- 2.25.1