#| -*-Scheme-*-
-$Id: rtlcon.scm,v 4.25 1993/02/25 02:12:39 gjr Exp $
+$Id: rtlcon.scm,v 4.26 1993/07/01 03:25:31 gjr Exp $
Copyright (c) 1988-1993 Massachusetts Institute of Technology
(define (make-offset register offset granularity)
(case granularity
- ((OBJECT) (rtl:make-offset register offset))
- ((BYTE) (rtl:make-byte-offset register offset))
- (else (error "unknown offset granularity" granularity))))
+ ((OBJECT)
+ (rtl:make-offset register (rtl:make-machine-constant offset)))
+ ((BYTE)
+ (rtl:make-byte-offset register (rtl:make-machine-constant offset)))
+ ((FLOAT)
+ (rtl:make-float-offset register (rtl:make-machine-constant offset)))
+ (else
+ (error "unknown offset granularity" granularity))))
+
+(define (make-offset-address register offset granularity)
+ (case granularity
+ ((OBJECT)
+ (rtl:make-offset-address register offset))
+ ((BYTE)
+ (rtl:make-byte-offset-address register offset))
+ ((FLOAT)
+ (rtl:make-float-offset-address register offset))
+ (else
+ (error "unknown offset granularity" granularity))))
\f
(define (locative-dereference locative scfg-append! if-register if-memory)
(let ((dereference-fetch
(dereference-fetch base offset granularity))
((CONSTANT)
(dereference-constant base offset granularity))
+ ((INDEX)
+ (locative-dereference
+ base
+ scfg-append!
+ (lambda (reg)
+ (error "Can't be a reg" locative reg))
+ (lambda (base* zero granularity*)
+ zero granularity* ; ignored
+ (if-memory base* offset granularity))))
+ ((OFFSET)
+ (locative-dereference
+ base
+ scfg-append!
+ (lambda (reg)
+ (error "Can't be a reg" locative reg))
+ (lambda (base* offset* granularity*)
+ (assign-to-temporary
+ (make-offset-address
+ base*
+ (rtl:make-machine-constant offset*)
+ granularity*)
+ scfg-append!
+ (lambda (base-reg)
+ (if-memory base-reg offset granularity))))))
(else
(error "illegal offset base" locative)))))
+ ((INDEX)
+ (let ((base (rtl:locative-index-base locative))
+ (offset (rtl:locative-index-offset locative))
+ (granularity (rtl:locative-index-granularity locative)))
+ (define (finish base-reg-expr offset-expr)
+ (assign-to-temporary
+ (make-offset-address base-reg-expr offset-expr granularity)
+ scfg-append!
+ (lambda (loc-reg-expr)
+ ;; granularity ok?
+ (if-memory loc-reg-expr 0 granularity))))
+ (expression-simplify
+ offset
+ scfg-append!
+ (lambda (offset-expr)
+ (locative-dereference
+ base
+ scfg-append!
+ (lambda (base-reg-expr)
+ (finish base-reg-expr offset-expr))
+ (lambda (base*-reg-expr offset* granularity*)
+ (if (zero? offset*)
+ (finish base*-reg-expr offset-expr)
+ (assign-to-temporary
+ (make-offset-address
+ base*-reg-expr
+ (rtl:make-machine-constant offset*)
+ granularity*)
+ scfg-append!
+ (lambda (loc-reg-expr)
+ (finish loc-reg-expr offset-expr))))))))))
((CONSTANT)
(dereference-constant locative 0 'OBJECT))
(else
(lambda (address offset granularity)
(if (not (eq? granularity 'OBJECT))
(error "can't take address of non-object offset" granularity))
- (if (zero? offset)
- (receiver address)
- (receiver (rtl:make-offset-address address offset)))))))
+ (receiver
+ (if (zero? offset)
+ address
+ (rtl:make-offset-address address
+ (rtl:make-machine-constant offset))))))))
(define-expression-method 'ENVIRONMENT
(address-method
receiver))))
(if (zero? offset)
(receiver address)
- (assign-to-temporary (rtl:make-offset-address address offset)
- scfg-append!
- receiver)))))))
+ (assign-to-temporary
+ (rtl:make-offset-address address
+ (rtl:make-machine-constant offset))
+ scfg-append!
+ receiver)))))))
(define-expression-method 'CONS-POINTER
(lambda (receiver scfg-append! type datum)
expression)
(receiver temporary))
(scfg-append!
- (rtl:make-assignment-internal (rtl:make-offset free 0)
- expression)
+ (rtl:make-assignment-internal
+ (rtl:make-offset free (rtl:make-machine-constant 0))
+ expression)
(scfg-append!
(rtl:make-assignment-internal
free
- (rtl:make-offset-address free 1))
+ (rtl:make-offset-address free
+ (rtl:make-machine-constant 1)))
(receiver temporary)))))))))))
(define-expression-method 'TYPED-CONS:PAIR
(receiver temporary)))
(scfg-append!
(rtl:make-assignment-internal
- (rtl:make-offset free 0)
+ (rtl:make-offset free
+ (rtl:make-machine-constant 0))
car)
(scfg-append!
(rtl:make-assignment-internal
- (rtl:make-offset free 1)
+ (rtl:make-offset free
+ (rtl:make-machine-constant 1))
cdr)
(scfg-append!
(rtl:make-assignment-internal
free
- (rtl:make-offset-address free 2))
+ (rtl:make-offset-address
+ free
+ (rtl:make-machine-constant 2)))
(receiver temporary))))))))))))))))
\f
(define-expression-method 'TYPED-CONS:VECTOR
(loop (cdr elements))))))
(scfg-append!
(rtl:make-assignment-internal
- (rtl:make-offset free 0)
+ (rtl:make-offset
+ free
+ (rtl:make-machine-constant 0))
header)
(let loop ((elements elements) (offset 1))
(if (null? elements)
(scfg-append!
(rtl:make-assignment-internal
free
- (rtl:make-offset-address free offset))
+ (rtl:make-offset-address
+ free
+ (rtl:make-machine-constant offset)))
(receiver temporary))
(scfg-append!
(rtl:make-assignment-internal
- (rtl:make-offset free offset)
+ (rtl:make-offset
+ free
+ (rtl:make-machine-constant offset))
(car elements))
(loop (cdr elements)
(+ offset 1))))))))))))))))))))
element))
(lambda (element offset)
(rtl:make-assignment-internal
- (rtl:make-offset free offset)
+ (rtl:make-offset free (rtl:make-machine-constant offset))
element)))))
(define (do-chunk elements offset tail)
free
(rtl:make-offset-address
free
- (1+ nelements)))
+ (rtl:make-machine-constant
+ (1+ nelements))))
(receiver temporary))))
(do-chunk (list-head elements chunk-size)
offset
(set! value
(length (list-transform-positive reg-list
(lambda (reg)
- (value-class/ancestor-or-self? (machine-register-value-class reg)
- value-class=word)))))
+ (value-class/ancestor-or-self?
+ (machine-register-value-class reg)
+ value-class=word)))))
value)))))
(define-expression-method 'TYPED-CONS:PROCEDURE
entry))))))
(define-expression-method 'BYTE-OFFSET-ADDRESS
- (lambda (receiver scfg-append! base number)
+ (lambda (receiver scfg-append! base offset)
+ (expression-simplify
+ base scfg-append!
+ (lambda (base)
+ (expression-simplify
+ offset scfg-append!
+ (lambda (offset)
+ (receiver (rtl:make-byte-offset-address base offset))))))))
+
+(define-expression-method 'FLOAT-OFFSET-ADDRESS
+ (lambda (receiver scfg-append! base offset)
(expression-simplify
base scfg-append!
(lambda (base)
- (receiver (rtl:make-byte-offset-address base number))))))
+ (expression-simplify
+ offset scfg-append!
+ (lambda (offset)
+ (receiver (rtl:make-float-offset-address base offset))))))))
;; NOPs for simplification
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlexp.scm,v 4.18 1991/10/25 00:14:21 cph Exp $
+$Id: rtlexp.scm,v 4.19 1993/07/01 03:25:40 gjr Exp $
-Copyright (c) 1987-91 Massachusetts Institute of Technology
+Copyright (c) 1987-1993 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(register-value-class (rtl:register-number expression)))
((CONS-NON-POINTER CONS-POINTER CONSTANT FIXNUM->OBJECT FLOAT->OBJECT
GENERIC-BINARY GENERIC-UNARY OFFSET POST-INCREMENT
- PRE-INCREMENT
- ;; This is a lie, but it is the only way that
- ;; it is used now! It should be moved to
- ;; value-class=address, and a cast type
- ;; introduced to handle current usage.
- BYTE-OFFSET-ADDRESS)
+ PRE-INCREMENT)
value-class=object)
((FIXNUM->ADDRESS OBJECT->ADDRESS
- OFFSET-ADDRESS
ASSIGNMENT-CACHE VARIABLE-CACHE
CONS-CLOSURE CONS-MULTICLOSURE
- ENTRY:CONTINUATION ENTRY:PROCEDURE)
+ ENTRY:CONTINUATION ENTRY:PROCEDURE
+ OFFSET-ADDRESS
+ FLOAT-OFFSET-ADDRESS
+ BYTE-OFFSET-ADDRESS)
value-class=address)
((MACHINE-CONSTANT)
value-class=immediate)
value-class=fixnum)
((OBJECT->TYPE)
value-class=type)
- ((OBJECT->FLOAT FLONUM-1-ARG FLONUM-2-ARGS)
+ ((OBJECT->FLOAT FLONUM-1-ARG FLONUM-2-ARGS FLOAT-OFFSET)
value-class=float)
(else
(error "unknown RTL expression type" expression))))
FIXNUM-2-ARGS
FIXNUM->ADDRESS
FIXNUM->OBJECT
+ FLOAT-OFFSET-ADDRESS
FLONUM-1-ARG
FLONUM-2-ARGS
GENERIC-BINARY
#| -*-Scheme-*-
-$Id: rtlty1.scm,v 4.20 1992/11/09 18:42:11 jinx Exp $
+$Id: rtlty1.scm,v 4.21 1993/07/01 03:25:47 gjr Exp $
-Copyright (c) 1987-1992 Massachusetts Institute of Technology
+Copyright (c) 1987-1993 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(define-rtl-expression constant % value)
;;; Memory references that return Scheme objects
-(define-rtl-expression offset rtl: base number)
+(define-rtl-expression offset rtl: base offset)
(define-rtl-expression pre-increment rtl: register number)
(define-rtl-expression post-increment rtl: register number)
;;; Memory reference that returns ASCII integer
-(define-rtl-expression byte-offset rtl: base number)
+(define-rtl-expression byte-offset rtl: base offset)
+;;; Memory reference that returns a floating-point number
+(define-rtl-expression float-offset rtl: base offset)
;;; Generic arithmetic operations on Scheme number objects
;;; (define-rtl-expression generic-unary rtl: operator operand)
;;; (define-rtl-expression address->datum rtl: expression)
;;; Add a constant offset to an address
-(define-rtl-expression offset-address rtl: base number)
-(define-rtl-expression byte-offset-address rtl: base number)
+(define-rtl-expression offset-address rtl: base offset)
+(define-rtl-expression byte-offset-address rtl: base offset)
+(define-rtl-expression float-offset-address rtl: base offset)
;;; A machine constant (an integer, usually unsigned)
(define-rtl-expression machine-constant rtl: value)
#| -*-Scheme-*-
-$Id: rtlty2.scm,v 4.11 1993/01/08 00:05:27 cph Exp $
+$Id: rtlty2.scm,v 4.12 1993/07/01 03:25:52 gjr Exp $
Copyright (c) 1988-1993 Massachusetts Institute of Technology
(define-integrable rtl:locative-offset-base cadr)
(define-integrable rtl:locative-offset-offset caddr)
+#|
(define (rtl:locative-offset-granularity locative)
;; This is kludged up for backward compatibility
(if (rtl:locative-offset? locative)
(cadddr locative)
'OBJECT)
(error "Not a locative offset" locative)))
+|#
+(define-integrable rtl:locative-offset-granularity cadddr)
(define-integrable (rtl:locative-byte-offset? locative)
(eq? (rtl:locative-offset-granularity locative) 'BYTE))
+(define-integrable (rtl:locative-float-offset? locative)
+ (eq? (rtl:locative-offset-granularity locative) 'FLOAT))
+
(define-integrable (rtl:locative-object-offset? locative)
(eq? (rtl:locative-offset-granularity locative) 'OBJECT))
-(define (rtl:locative-offset locative offset)
+(define-integrable (rtl:locative-offset locative offset)
+ (rtl:locative-object-offset locative offset))
+
+(define (rtl:locative-byte-offset locative byte-offset)
+ (cond ((rtl:locative-offset? locative)
+ `(OFFSET ,(rtl:locative-offset-base locative)
+ ,(back-end:+
+ byte-offset
+ (cond ((rtl:locative-byte-offset? locative)
+ (rtl:locative-offset-offset locative))
+ ((rtl:locative-object-offset? locative)
+ (back-end:*
+ (rtl:locative-offset-offset locative)
+ address-units-per-object))
+ (else
+ (back-end:*
+ (rtl:locative-offset-offset locative)
+ address-units-per-float))))
+ BYTE))
+ ((back-end:= byte-offset 0)
+ locative)
+ (else
+ `(OFFSET ,locative ,byte-offset BYTE))))
+
+(define (rtl:locative-float-offset locative float-offset)
+ (let ((default
+ (lambda ()
+ `(OFFSET ,locative ,float-offset FLOAT))))
+ (cond ((rtl:locative-offset? locative)
+ (if (rtl:locative-float-offset? locative)
+ `(OFFSET ,(rtl:locative-offset-base locative)
+ ,(back-end:+ (rtl:locative-offset-offset locative)
+ float-offset)
+ FLOAT)
+ (default)))
+ (else
+ (default)))))
+
+(define (rtl:locative-object-offset locative offset)
(cond ((back-end:= offset 0) locative)
((rtl:locative-offset? locative)
- (if (rtl:locative-byte-offset? locative)
- (error "Can't add object-offset to byte-offset"
+ (if (not (rtl:locative-object-offset? locative))
+ (error "Can't add object offset to non-object offset"
locative offset)
`(OFFSET ,(rtl:locative-offset-base locative)
,(back-end:+ (rtl:locative-offset-offset locative)
OBJECT)))
(else
`(OFFSET ,locative ,offset OBJECT))))
+\f
+(define (rtl:locative-index? locative)
+ (and (pair? locative) (eq? (car locative) 'INDEX)))
-(define (rtl:locative-byte-offset locative byte-offset)
- (cond ((back-end:= byte-offset 0) locative)
- ((rtl:locative-offset? locative)
- `(OFFSET ,(rtl:locative-offset-base locative)
- ,(back-end:+ byte-offset
- (if (rtl:locative-byte-offset? locative)
- (rtl:locative-offset-offset locative)
- (back-end:* (rtl:locative-offset-offset locative)
- address-units-per-object)))
- BYTE))
- (else
- `(OFFSET ,locative ,byte-offset BYTE))))
+(define-integrable rtl:locative-index-base cadr)
+(define-integrable rtl:locative-index-offset caddr)
+(define-integrable rtl:locative-index-granularity cadddr)
+
+(define-integrable (rtl:locative-byte-index? locative)
+ (eq? (rtl:locative-index-granularity locative) 'BYTE))
+
+(define-integrable (rtl:locative-float-index? locative)
+ (eq? (rtl:locative-index-granularity locative) 'FLOAT))
+
+(define-integrable (rtl:locative-object-index? locative)
+ (eq? (rtl:locative-index-granularity locative) 'OBJECT))
+
+(define (rtl:locative-byte-index locative offset)
+ `(INDEX ,locative ,offset BYTE))
+
+(define (rtl:locative-float-index locative offset)
+ `(INDEX ,locative ,offset FLOAT))
+
+(define (rtl:locative-object-index locative offset)
+ `(INDEX ,locative ,offset OBJECT))
\f
;;; Expressions that are used in the intermediate form.
projects / mit-scheme.git / commitdiff