#| -*-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
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)
(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
-\f
(define (rtl:map-subexpressions expression procedure)
(if (rtl:constant? expression)
(map identity-procedure expression)
(define (rtl:any-subexpression? expression predicate)
(and (not (rtl:constant? expression))
(there-exists? (cdr expression)
- (lambda (x)
- (and (pair? x)
- (predicate x))))))
-\f
+ (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))))))
+\f
(define (rtl:reduce-subparts expression operator initial if-expression if-not)
(let ((remap
(if (rtl:constant? expression)
(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)))
(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)))))))
+\f
+(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
projects / mit-scheme.git / commitdiff