From: Chris Hanson Date: Mon, 29 Aug 1988 23:08:52 +0000 (+0000) Subject: Merge concepts of `address' and `fixnum' register into `non-object' X-Git-Tag: 20090517-FFI~12569 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=b3ad8d94c8d395445ae842f806722d578cbc65d9;p=mit-scheme.git Merge concepts of `address' and `fixnum' register into `non-object' register. Implement operations to detect substitutable register within a given expression, and to substitute subexpressions for those registers. Implement predicate to determine if an expression is constant. All of these new operations are used by the improved register combiner. Simplify `rtl:trivial-expression?' by disallowing stack references. This causes some inefficiencies that must be corrected elsewhere, but reveals more intermediate values to the CSE. --- diff --git a/v7/src/compiler/rtlbase/rtlexp.scm b/v7/src/compiler/rtlbase/rtlexp.scm index 3afbfd043..9cc2193a4 100644 --- a/v7/src/compiler/rtlbase/rtlexp.scm +++ b/v7/src/compiler/rtlbase/rtlexp.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlexp.scm,v 4.6 1988/05/19 15:20:13 markf Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlexp.scm,v 4.7 1988/08/29 23:08:52 cph Exp $ -Copyright (c) 1987 Massachusetts Institute of Technology +Copyright (c) 1987, 1988 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -47,18 +47,29 @@ MIT in each case. |# INVOCATION:CACHE-REFERENCE INVOCATION:LOOKUP))) -(define (rtl:trivial-expression? expression) - (if (memq (rtl:expression-type expression) - '(REGISTER - CONSTANT - ENTRY:CONTINUATION - ENTRY:PROCEDURE - UNASSIGNED - VARIABLE-CACHE - ASSIGNMENT-CACHE)) - true - (and (rtl:offset? expression) - (interpreter-stack-pointer? (rtl:offset-register expression))))) +(define-integrable (rtl:trivial-expression? expression) + (memq (rtl:expression-type expression) + '(ASSIGNMENT-CACHE + CONSTANT + ENTRY:CONTINUATION + ENTRY:PROCEDURE + REGISTER + UNASSIGNED + VARIABLE-CACHE))) +(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 + FIXNUM-1-ARG + FIXNUM-2-ARGS + OBJECT->ADDRESS + OBJECT->DATUM + OBJECT->FIXNUM + OBJECT->TYPE + OFFSET-ADDRESS + VARIABLE-CACHE)))) (define (rtl:machine-register-expression? expression) (and (rtl:register? expression) @@ -68,34 +79,6 @@ MIT in each case. |# (and (rtl:register? expression) (pseudo-register? (rtl:register-number expression)))) -(define (rtl:address-valued-expression? expression) - (if (rtl:register? expression) - (register-contains-address? (rtl:register-number expression)) - (or (rtl:object->address? expression) - (rtl:variable-cache? expression) - (rtl:assignment-cache? expression)))) - -(define (rtl:fixnum-valued-expression? expression) - (if (rtl:register? expression) - (register-contains-fixnum? (rtl:register-number expression)) - (or (rtl:object->fixnum? expression) - (rtl:fixnum-1-arg? expression) - (rtl:fixnum-2-args? expression)))) - - -(define (rtl:optimizable? expression) - ;;; In order to avoid a combinatorial explosion in the number of - ;;; rules required in the lapgen phase we create a class of - ;;; expression types which we don't want optimized. We will - ;;; explicitly assign these expression types to registers during - ;;; rtl generation and then we need only create rules for how to - ;;; generate assignments to registers. Some day we will have - ;;; some facility for subrule hierarchies which may avoid the - ;;; combinatorial explosion. When that happens the next test may - ;;; be replaced by true. - (not (memq (rtl:expression-type expression) - '(OBJECT->FIXNUM OBJECT->DATUM)))) ;; Mhwu - (define (rtl:map-subexpressions expression procedure) (if (rtl:constant? expression) (map identity-procedure expression) @@ -116,17 +99,17 @@ MIT in each case. |# (define (rtl:any-subexpression? expression predicate) (and (not (rtl:constant? expression)) (there-exists? (cdr expression) - (lambda (x) - (and (pair? x) - (predicate x)))))) - + (lambda (x) + (and (pair? x) + (predicate x)))))) + (define (rtl:all-subexpressions? expression predicate) (or (rtl:constant? expression) (for-all? (cdr expression) - (lambda (x) - (or (not (pair? x)) - (predicate x)))))) - + (lambda (x) + (or (not (pair? x)) + (predicate x)))))) + (define (rtl:reduce-subparts expression operator initial if-expression if-not) (let ((remap (if (rtl:constant? expression) @@ -135,12 +118,11 @@ MIT in each case. |# (if (pair? x) (if-expression x) (if-not x)))))) - (define (loop parts accum) + (let loop ((parts (cdr expression)) (accum initial)) (if (null? parts) accum (loop (cdr parts) - (operator accum (remap (car parts)))))) - (loop (cdr expression) initial))) + (operator accum (remap (car parts)))))))) (define (rtl:match-subexpressions x y predicate) (let ((type (rtl:expression-type x))) @@ -163,6 +145,87 @@ MIT in each case. |# (if (not (null? tail)) (begin (if (pair? (car tail)) (procedure (car tail) - (lambda (expression) - (set-car! tail expression)))) - (loop (cdr tail))))))) \ No newline at end of file + (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:refers-to-register? rtl register) + (let loop ((expression 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))))) + +(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))))))) + +(define-integrable (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. + ;; `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 + CONSTANT + ENTRY:CONTINUATION + ENTRY:PROCEDURE + OFFSET + OFFSET-ADDRESS + POST-INCREMENT + PRE-INCREMENT + UNASSIGNED + VARIABLE-CACHE))) + +(define (rtl:constant-expression? expression) + (if (pair? expression) + (case (rtl:expression-type expression) + ((CONSTANT UNASSIGNED ASSIGNMENT-CACHE VARIABLE-CACHE + ENTRY:CONTINUATION ENTRY:PROCEDURE) + true) + ((CHAR->ASCII FIXNUM->OBJECT OBJECT->ADDRESS OBJECT->DATUM + OBJECT->FIXNUM OBJECT->TYPE) + (rtl:constant-expression? (cadr expression))) + ((CONS-POINTER) + (and (rtl:constant-expression? (rtl:cons-pointer-type expression)) + (rtl:constant-expression? (rtl:cons-pointer-datum expression)))) + ((FIXNUM-1-ARG) + (rtl:constant-expression? (rtl:fixnum-1-arg-operand expression))) + ((FIXNUM-2-ARGS) + (and (rtl:constant-expression? + (rtl:fixnum-2-args-operand-1 expression)) + (rtl:constant-expression? + (rtl:fixnum-2-args-operand-2 expression)))) (else + false)) + true)) \ No newline at end of file