#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlcon.scm,v 4.15 1988/11/04 10:26:02 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlcon.scm,v 4.16 1989/01/21 09:18:55 cph Rel $
-Copyright (c) 1988 Massachusetts Institute of Technology
+Copyright (c) 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(expression-simplify-for-statement expression
(lambda (expression)
(locative-dereference-for-statement locative
- (lambda (address)
- (if (and (rtl:pseudo-register-expression? address)
- (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*
- (rtl:register-number address)))
- (%make-assign address expression))))))
+ (lambda (locative)
+ (rtl:make-assignment-internal locative expression))))))
+
+(define (rtl:make-assignment-internal locative expression)
+ (let ((assign-register
+ (lambda (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*
+ (rtl:register-number locative)))
+ (%make-assign 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))
+ (else
+ (let ((register (rtl:make-pseudo-register)))
+ (scfg*scfg->scfg! (assign-register register)
+ (%make-assign locative register)))))))
(define (rtl:make-eq-test expression-1 expression-2)
(expression-simplify-for-predicate expression-1
(define (rtl:make-pop locative)
(locative-dereference-for-statement locative
(lambda (locative)
- (%make-assign locative (stack-pop-address)))))
+ (rtl:make-assignment-internal locative (stack-pop-address)))))
(define (rtl:make-push expression)
(expression-simplify-for-statement expression
(lambda (expression)
- (%make-assign (stack-push-address) 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-integrable (rtl:make-push-return continuation)
+(define (rtl:make-push-return continuation)
(rtl:make-push (rtl:make-entry:continuation continuation)))
(define (rtl:make-push-link)
(rtl:make-push
- (rtl:make-cons-pointer (rtl:make-constant (ucode-type stack-environment))
- (rtl:make-fetch register:dynamic-link))))
+ (rtl:make-address->environment (rtl:make-fetch register:dynamic-link))))
(define (rtl:make-pop-link)
(rtl:make-assignment register:dynamic-link
(define-export (expression-simplify-for-predicate expression receiver)
(expression-simplify expression scfg*pcfg->pcfg! receiver))
-(define (expression-simplify* expression scfg-append! receiver)
- (expression-simplify expression
- scfg-append!
- (expression-receiver scfg-append! receiver)))
-
-(define ((expression-receiver scfg-append! receiver) expression)
- (if (rtl:trivial-expression? expression)
- (receiver expression)
- (assign-to-temporary expression scfg-append! receiver)))
-
(define (expression-simplify expression scfg-append! receiver)
- (let ((entry (assq (car expression) expression-methods)))
- (if entry
- (apply (cdr entry) receiver scfg-append! (cdr expression))
- (receiver expression))))
+ (let ((receiver
+ (lambda (expression)
+ (if (rtl:trivial-expression? expression)
+ (receiver expression)
+ (assign-to-temporary expression scfg-append! receiver)))))
+ (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)))
(define expression-methods
'())
\f
+(define-expression-method 'FETCH
+ (lambda (receiver scfg-append! locative)
+ (locative-dereference locative scfg-append!
+ receiver
+ (lambda (register offset granularity)
+ (receiver (make-offset register offset granularity))))))
+
(define (address-method generator)
(lambda (receiver scfg-append! locative)
(locative-dereference-1 locative scfg-append! locative-fetch-1
scfg-append!
receiver))))))
-(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)
- scfg-append!
- (lambda (temporary)
- (scfg-append!
- (%make-assign (rtl:make-post-increment free 1) expression)
- (receiver temporary)))))))))
-
(define-expression-method 'ENVIRONMENT
(address-method
(lambda (receiver scfg-append!)
(lambda (register)
(receiver (rtl:make-address->environment register)))))))))))
\f
-(define-expression-method 'FETCH
- (lambda (receiver scfg-append! locative)
- (locative-dereference locative scfg-append!
- receiver
- (lambda (register offset granularity)
- (receiver (make-offset register offset granularity))))))
+(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)
+ scfg-append!
+ (lambda (temporary)
+ (let ((setup
+ (rtl:make-assignment-internal
+ (rtl:make-post-increment free 1)
+ expression)))
+ (scfg-append! setup (receiver temporary))))))))))
(define-expression-method 'TYPED-CONS:PAIR
(lambda (receiver scfg-append! type car cdr)
(let ((free (interpreter-free-pointer)))
(let ((target (rtl:make-post-increment free 1)))
- (expression-simplify* type scfg-append!
+ (expression-simplify type scfg-append!
(lambda (type)
- (expression-simplify* car scfg-append!
+ (expression-simplify car scfg-append!
(lambda (car)
- (expression-simplify* cdr scfg-append!
+ (expression-simplify cdr scfg-append!
(lambda (cdr)
(assign-to-temporary (rtl:make-cons-pointer type free)
scfg-append!
(lambda (temporary)
- (scfg-append!
- (%make-assign target car)
- (scfg-append! (%make-assign target cdr)
- (receiver 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))))))))))))))))
(define-expression-method 'TYPED-CONS:VECTOR
(lambda (receiver scfg-append! type . elements)
(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!
+ (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)
- (scfg-append!
- (%make-assign target header)
- (let loop ((elements (reverse! simplified-elements)))
- (if (null? elements)
- (receiver temporary)
- (scfg-append! (%make-assign target (car elements))
- (loop (cdr elements))))))))
- (expression-simplify* (car elements) scfg-append!
+ (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))))))))))))
-;; A NOP for simplification
-
(define-expression-method 'TYPED-CONS:PROCEDURE
+ ;; A NOP for simplification
(lambda (receiver scfg-append! type entry min max size)
scfg-append!
(receiver (rtl:make-typed-cons:procedure type entry min max size))))
\f
(define (object-selector make-object-selector)
(lambda (receiver scfg-append! expression)
- (expression-simplify* expression scfg-append!
+ (expression-simplify expression scfg-append!
(lambda (expression)
(receiver (make-object-selector expression))))))
(define-expression-method 'OBJECT->DATUM
(lambda (receiver scfg-append! expression)
- (expression-simplify* expression scfg-append!
+ (expression-simplify expression scfg-append!
(lambda (expression)
(assign-to-temporary (rtl:make-object->datum expression)
scfg-append!
(define-expression-method 'OBJECT->FIXNUM
(lambda (receiver scfg-append! expression)
- (expression-simplify* expression scfg-append!
+ (expression-simplify expression scfg-append!
(lambda (expression)
(if (rtl:non-object-valued-expression? expression)
(receiver expression)
(define-expression-method 'CONS-POINTER
(lambda (receiver scfg-append! type datum)
- (expression-simplify* type scfg-append!
+ (expression-simplify type scfg-append!
(lambda (type)
- (expression-simplify* datum scfg-append!
+ (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)
- (expression-simplify* operand1 scfg-append!
- (lambda (s-operand1)
- (expression-simplify* operand2 scfg-append!
- (lambda (s-operand2)
- (receiver (rtl:make-fixnum-2-args
- operator
- s-operand1
- s-operand2))))))))
+ (expression-simplify operand1 scfg-append!
+ (lambda (operand1)
+ (expression-simplify operand2 scfg-append!
+ (lambda (operand2)
+ (receiver
+ (rtl:make-fixnum-2-args operator operand1 operand2))))))))
(define-expression-method 'FIXNUM-1-ARG
(lambda (receiver scfg-append! operator operand)
- (expression-simplify* operand scfg-append!
- (lambda (s-operand)
- (receiver (rtl:make-fixnum-1-arg
- operator
- s-operand))))))
+ (expression-simplify operand scfg-append!
+ (lambda (operand)
+ (receiver (rtl:make-fixnum-1-arg operator operand))))))
(define-expression-method 'GENERIC-BINARY
(lambda (receiver scfg-append! operator operand1 operand2)
- (expression-simplify* operand1 scfg-append!
- (lambda (s-operand1)
- (expression-simplify* operand2 scfg-append!
- (lambda (s-operand2)
- (receiver (rtl:make-generic-binary
- operator
- s-operand1
- s-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 (s-operand)
- (receiver (rtl:make-generic-unary
- operator
- s-operand))))))
-
+ (expression-simplify operand scfg-append!
+ (lambda (operand)
+ (receiver (rtl:make-generic-unary operator operand))))))
;;; end EXPRESSION-SIMPLIFY package
)
\ No newline at end of file
projects / mit-scheme.git / commitdiff