From: Guillermo J. Rozas Date: Thu, 1 Jul 1993 03:25:52 +0000 (+0000) Subject: Diddle with locatives to allow index addressing modes. X-Git-Tag: 20090517-FFI~8233 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=c2312392108da195b6cd0782dc9810a4d12e377d;p=mit-scheme.git Diddle with locatives to allow index addressing modes. --- diff --git a/v7/src/compiler/rtlbase/rtlcon.scm b/v7/src/compiler/rtlbase/rtlcon.scm index 48ab8470c..31b26c25c 100644 --- a/v7/src/compiler/rtlbase/rtlcon.scm +++ b/v7/src/compiler/rtlbase/rtlcon.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -259,9 +259,25 @@ MIT in each case. |# (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)))) (define (locative-dereference locative scfg-append! if-register if-memory) (let ((dereference-fetch @@ -317,8 +333,63 @@ MIT in each case. |# (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 @@ -366,9 +437,11 @@ MIT in each case. |# (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 @@ -386,9 +459,11 @@ MIT in each case. |# 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) @@ -423,12 +498,14 @@ MIT in each case. |# 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 @@ -455,16 +532,20 @@ MIT in each case. |# (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)))))))))))))))) (define-expression-method 'TYPED-CONS:VECTOR @@ -503,18 +584,24 @@ MIT in each case. |# (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)))))))))))))))))))) @@ -533,7 +620,7 @@ MIT in each case. |# 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) @@ -572,7 +659,8 @@ MIT in each case. |# free (rtl:make-offset-address free - (1+ nelements))) + (rtl:make-machine-constant + (1+ nelements)))) (receiver temporary)))) (do-chunk (list-head elements chunk-size) offset @@ -594,8 +682,9 @@ MIT in each case. |# (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 @@ -608,11 +697,24 @@ MIT in each case. |# 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 diff --git a/v7/src/compiler/rtlbase/rtlexp.scm b/v7/src/compiler/rtlbase/rtlexp.scm index 553fbee33..94f6fe3c8 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.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 @@ -62,18 +62,15 @@ MIT in each case. |# (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) @@ -86,7 +83,7 @@ MIT in each case. |# 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)))) @@ -283,6 +280,7 @@ MIT in each case. |# FIXNUM-2-ARGS FIXNUM->ADDRESS FIXNUM->OBJECT + FLOAT-OFFSET-ADDRESS FLONUM-1-ARG FLONUM-2-ARGS GENERIC-BINARY diff --git a/v7/src/compiler/rtlbase/rtlty1.scm b/v7/src/compiler/rtlbase/rtlty1.scm index e8f1a6807..f48c7f759 100644 --- a/v7/src/compiler/rtlbase/rtlty1.scm +++ b/v7/src/compiler/rtlbase/rtlty1.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -49,12 +49,14 @@ MIT in each case. |# (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) @@ -82,8 +84,9 @@ MIT in each case. |# ;;; (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) diff --git a/v7/src/compiler/rtlbase/rtlty2.scm b/v7/src/compiler/rtlbase/rtlty2.scm index 530d0b43a..9b52454a3 100644 --- a/v7/src/compiler/rtlbase/rtlty2.scm +++ b/v7/src/compiler/rtlbase/rtlty2.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -103,6 +103,7 @@ MIT in each case. |# (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) @@ -110,18 +111,61 @@ MIT in each case. |# (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) @@ -129,19 +173,31 @@ MIT in each case. |# OBJECT))) (else `(OFFSET ,locative ,offset OBJECT)))) + +(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)) ;;; Expressions that are used in the intermediate form.