From: Guillermo J. Rozas <edu/mit/csail/zurich/gjr>
Date: Tue, 6 Jul 1993 00:56:32 +0000 (+0000)
Subject: - Update to match change in RTL introduced to improve array indexing.
X-Git-Tag: 20090517-FFI~8215
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=3db8dc1dffe34d9cfadd295c80d62194b557b950;p=mit-scheme.git
- Update to match change in RTL introduced to improve array indexing.
- Add floating-vector support.
- Add top-level code compression support.
---
diff --git a/v7/src/compiler/machines/bobcat/compiler.pkg b/v7/src/compiler/machines/bobcat/compiler.pkg
index 556119691..77ec5cf8f 100644
--- a/v7/src/compiler/machines/bobcat/compiler.pkg
+++ b/v7/src/compiler/machines/bobcat/compiler.pkg
@@ -1,6 +1,6 @@
#| -*-Scheme-*-
-$Id: compiler.pkg,v 1.43 1993/02/25 02:16:04 gjr Exp $
+$Id: compiler.pkg,v 1.44 1993/07/06 00:56:22 gjr Exp $
Copyright (c) 1988-1993 Massachusetts Institute of Technology
@@ -511,7 +511,8 @@ MIT in each case. |#
(files "rtlgen/rgcomb")
(parent (compiler rtl-generator))
(export (compiler rtl-generator)
- generate/combination)
+ generate/combination
+ rtl:bump-closure)
(export (compiler rtl-generator combination/inline)
generate/invocation-prefix))
diff --git a/v7/src/compiler/machines/bobcat/lapgen.scm b/v7/src/compiler/machines/bobcat/lapgen.scm
index 5f3a99b9f..d3d5c2119 100644
--- a/v7/src/compiler/machines/bobcat/lapgen.scm
+++ b/v7/src/compiler/machines/bobcat/lapgen.scm
@@ -1,8 +1,8 @@
#| -*-Scheme-*-
-$Id: lapgen.scm,v 4.47 1993/01/13 00:18:46 cph Exp $
+$Id: lapgen.scm,v 4.48 1993/07/06 00:56:23 gjr Exp $
-Copyright (c) 1988-93 Massachusetts Institute of Technology
+Copyright (c) 1988-1993 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
@@ -350,9 +350,134 @@ MIT in each case. |#
(register-alias register 'DATA)
(load-alias-register! register 'ADDRESS)))
-(define (offset->indirect-reference! offset)
- (indirect-reference! (rtl:register-number (rtl:offset-base offset))
- (rtl:offset-number offset)))
+(define (rtl:simple-byte-offset? expression)
+ (and (rtl:byte-offset? expression)
+ (let ((base (rtl:byte-offset-base expression))
+ (offset (rtl:byte-offset-offset expression)))
+ (if (rtl:register? base)
+ (or (rtl:machine-constant? offset)
+ (rtl:register? offset))
+ (and (rtl:byte-offset-address? base)
+ (rtl:machine-constant? offset)
+ (rtl:register? (rtl:byte-offset-address-base base))
+ (rtl:register? (rtl:byte-offset-address-offset base)))))
+ expression))
+
+(define (byte-offset->reference! offset)
+ ;; OFFSET must be a simple byte offset
+ (let ((base (rtl:byte-offset-base offset))
+ (offset (rtl:byte-offset-offset offset)))
+ (cond ((not (rtl:register? base))
+ (indexed-ea (rtl:register-number
+ (rtl:byte-offset-address-base base))
+ (rtl:register-number
+ (rtl:byte-offset-address-offset base))
+ 1
+ (rtl:machine-constant-value offset)))
+ ((rtl:machine-constant? offset)
+ (indirect-byte-reference! (rtl:register-number base)
+ (rtl:machine-constant-value offset)))
+ (else
+ (indexed-ea (rtl:register-number base)
+ (rtl:register-number offset)
+ 1
+ 0)))))
+
+(define (rtl:simple-offset? expression)
+ (and (rtl:offset? expression)
+ (let ((base (rtl:offset-base expression))
+ (offset (rtl:offset-offset expression)))
+ (if (rtl:register? base)
+ (or (rtl:machine-constant? offset)
+ (rtl:register? offset))
+ (and (rtl:offset-address? base)
+ (rtl:machine-constant? offset)
+ (rtl:register? (rtl:offset-address-base base))
+ (rtl:register? (rtl:offset-address-offset base)))))
+ expression))
+
+(define (offset->reference! offset)
+ ;; OFFSET must be a simple offset
+ (let ((base (rtl:offset-base offset))
+ (offset (rtl:offset-offset offset)))
+ (cond ((not (rtl:register? base))
+ (indexed-ea (rtl:register-number (rtl:offset-address-base base))
+ (rtl:register-number (rtl:offset-address-offset base))
+ 4
+ (* 4 (rtl:machine-constant-value offset))))
+ ((rtl:machine-constant? offset)
+ (indirect-reference! (rtl:register-number base)
+ (rtl:machine-constant-value offset)))
+ (else
+ (indexed-ea (rtl:register-number base)
+ (rtl:register-number offset)
+ 4
+ 0)))))
+
+(define (offset->reference!/char offset)
+ ;; OFFSET must be a simple offset
+ (let ((base (rtl:offset-base offset))
+ (offset (rtl:offset-offset offset)))
+ (cond ((not (rtl:register? base))
+ (indexed-ea (rtl:register-number (rtl:offset-address-base base))
+ (rtl:register-number (rtl:offset-address-offset base))
+ 4
+ (+ 3 (* 4 (rtl:machine-constant-value offset)))))
+ ((rtl:machine-constant? offset)
+ (indirect-byte-reference!
+ (rtl:register-number base)
+ (+ 3 (* 4 (rtl:machine-constant-value offset)))))
+ (else
+ (indexed-ea (rtl:register-number base)
+ (rtl:register-number offset)
+ 4
+ 3)))))
+
+(define (rtl:simple-float-offset? expression)
+ (and (rtl:float-offset? expression)
+ (let ((base (rtl:float-offset-base expression))
+ (offset (rtl:float-offset-offset expression)))
+ (and (or (rtl:machine-constant? offset)
+ (rtl:register? offset))
+ (or (rtl:register? base)
+ (and (rtl:offset-address? base)
+ (rtl:register? (rtl:offset-address-base base))
+ (rtl:machine-constant?
+ (rtl:offset-address-offset base))))))
+ expression))
+
+(define (float-offset->reference! offset)
+ ;; OFFSET must be a simple float offset
+ (let ((base (rtl:float-offset-base offset))
+ (offset (rtl:float-offset-offset offset)))
+ (cond ((not (rtl:register? base))
+ (let ((base*
+ (rtl:register-number (rtl:offset-address-base base)))
+ (w-offset
+ (rtl:machine-constant-value
+ (rtl:offset-address-offset base))))
+ (if (rtl:machine-constant? offset)
+ (indirect-reference!
+ base*
+ (+ (* 2 (rtl:machine-constant-value offset))
+ w-offset))
+ (indexed-ea base*
+ (rtl:register-number offset)
+ 8
+ (* 4 w-offset)))))
+ ((rtl:machine-constant? offset)
+ (indirect-reference! (rtl:register-number base)
+ (* 2 (rtl:machine-constant-value offset))))
+ (else
+ (indexed-ea (rtl:register-number base)
+ (rtl:register-number offset)
+ 8
+ 0)))))
+
+(define (indexed-ea base index scale offset)
+ (let ((base (allocate-indirection-register! base))
+ (index (preferred-data-register-reference index)))
+ (INST-EA (@AOXS ,(->areg base) ,offset (,index L ,scale)))))
(define (indirect-reference! register offset)
(offset-reference (allocate-indirection-register! register) offset))
@@ -362,19 +487,7 @@ MIT in each case. |#
(define-integrable (allocate-indirection-register! register)
(load-alias-register! register 'ADDRESS))
-
-#|
-
-;; *** This is believed to be a fossil. ***
-;; Left here until the first compilation to make sure that it really is.
-;; Can be removed the next time it is seen.
-
-(define (code-object-label-initialize code-object)
- code-object
- false)
-
-|#
-
+
(define (generate-n-times n limit instruction-gen with-counter)
(if (> n limit)
(let ((loop (generate-label 'LOOP)))
@@ -390,17 +503,21 @@ MIT in each case. |#
(LAP ,@(instruction-gen)
,@(loop (-1+ n)))))))
+#|
+
+;;; These seem to be fossils --- GJR 7/1/1993
+
(define (standard-target-expression? target)
- (or (and (rtl:offset? target)
- (rtl:register? (rtl:offset-base target)))
+ (or (rtl:simple-offset? target)
(rtl:free-push? target)
(rtl:stack-push? target)))
(define (standard-target-expression->ea target)
- (cond ((rtl:offset? target) (offset->indirect-reference! target))
+ (cond ((rtl:offset? target) (offset->reference! target))
((rtl:free-push? target) (INST-EA (@A+ 5)))
((rtl:stack-push? target) (INST-EA (@-A 7)))
(else (error "STANDARD-TARGET->EA: Not a standard target" target))))
+|#
(define (rtl:free-push? expression)
(and (rtl:post-increment? expression)
@@ -451,7 +568,7 @@ MIT in each case. |#
(operate-on-machine-target target)
(use-temporary target))))))
((OFFSET)
- (use-temporary (offset->indirect-reference! target)))
+ (use-temporary (offset->reference! target)))
(else
(error "Illegal machine target" target)))))
@@ -466,10 +583,9 @@ MIT in each case. |#
(operate-on-target (reference-target-alias! target type)))
operate-on-target))
-(define (machine-operation-target? target)
- (or (rtl:register? target)
- (and (rtl:offset? target)
- (rtl:register? (rtl:offset-base target)))))
+(define (machine-operation-target? expression)
+ (or (rtl:register? expression)
+ (rtl:simple-offset? expression)))
(define (two-arg-register-operation
operate commutative?
diff --git a/v7/src/compiler/machines/bobcat/machin.scm b/v7/src/compiler/machines/bobcat/machin.scm
index 64095888e..b2af96768 100644
--- a/v7/src/compiler/machines/bobcat/machin.scm
+++ b/v7/src/compiler/machines/bobcat/machin.scm
@@ -1,6 +1,6 @@
#| -*-Scheme-*-
-$Id: machin.scm,v 4.30 1993/06/29 22:23:16 gjr Exp $
+$Id: machin.scm,v 4.31 1993/07/06 00:56:25 gjr Exp $
Copyright (c) 1988-1993 Massachusetts Institute of Technology
@@ -288,12 +288,15 @@ MIT in each case. |#
(= (rtl:register-number expression) regnum:return-value)))
(define (interpreter-environment-register)
- (rtl:make-offset (interpreter-regs-pointer) 3))
+ (rtl:make-offset (interpreter-regs-pointer)
+ (rtl:make-machine-constant 3)))
(define (interpreter-environment-register? expression)
(and (rtl:offset? expression)
(interpreter-regs-pointer? (rtl:offset-base expression))
- (= 3 (rtl:offset-number expression))))
+ (let ((offset (rtl:offset-offset expression)))
+ (and (rtl:machine-constant? offset)
+ (= 3 (rtl:machine-constant-value offset))))))
(define (interpreter-free-pointer)
(rtl:make-machine-register regnum:free-pointer))
@@ -381,7 +384,8 @@ MIT in each case. |#
ASSIGNMENT-CACHE
VARIABLE-CACHE
OFFSET-ADDRESS
- BYTE-OFFSET-ADDRESS)
+ BYTE-OFFSET-ADDRESS
+ FLOAT-OFFSET-ADDRESS)
3)
((CONS-POINTER)
(and (rtl:machine-constant? (rtl:cons-pointer-type expression))
@@ -398,4 +402,4 @@ MIT in each case. |#
(define compiler:primitives-with-no-open-coding
'(DIVIDE-FIXNUM GCD-FIXNUM &/
VECTOR-CONS STRING-ALLOCATE FLOATING-VECTOR-CONS
- FLOATING-VECTOR-REF FLOATING-VECTOR-SET!))
\ No newline at end of file
+ FLONUM-CEILING FLONUM-FLOOR FLONUM-ATAN2))
\ No newline at end of file
diff --git a/v7/src/compiler/machines/bobcat/make.scm-68040 b/v7/src/compiler/machines/bobcat/make.scm-68040
index f3c360b35..8dff8745c 100644
--- a/v7/src/compiler/machines/bobcat/make.scm-68040
+++ b/v7/src/compiler/machines/bobcat/make.scm-68040
@@ -1,8 +1,8 @@
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 4.88 1991/10/25 06:49:46 cph Exp $
+$Id: make.scm-68040,v 4.89 1993/07/06 00:56:26 gjr Exp $
-Copyright (c) 1991 Massachusetts Institute of Technology
+Copyright (c) 1991-1993 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
@@ -37,6 +37,8 @@ MIT in each case. |#
(declare (usual-integrations))
((load "base/make") "Motorola MC68040")
+(set! (access compiler:compress-top-level? (->environment '(compiler)))
+ true)
((environment-lookup (->environment '(COMPILER LAP-SYNTAXER))
'MC68K/TOGGLE-CLOSURE-FORMAT)
'MC68040)
\ No newline at end of file
diff --git a/v7/src/compiler/machines/bobcat/rules1.scm b/v7/src/compiler/machines/bobcat/rules1.scm
index 50d53de0f..8f139c620 100644
--- a/v7/src/compiler/machines/bobcat/rules1.scm
+++ b/v7/src/compiler/machines/bobcat/rules1.scm
@@ -1,8 +1,8 @@
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules1.scm,v 4.37 1992/07/05 14:20:36 jinx Exp $
+$Id: rules1.scm,v 4.38 1993/07/06 00:56:27 gjr Exp $
-Copyright (c) 1988-1992 Massachusetts Institute of Technology
+Copyright (c) 1988-1993 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
@@ -50,32 +50,94 @@ MIT in each case. |#
(ASSIGN (REGISTER (? target)) (REGISTER (? source)))
(assign-register->register target source))
+(define (assign-register->register target source)
+ (standard-move-to-target! source (register-type target) target)
+ (LAP))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (OFFSET-ADDRESS (REGISTER (? base))
+ (REGISTER (? index))))
+ (load-indexed-address target base index 4 0))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (BYTE-OFFSET-ADDRESS (REGISTER (? base))
+ (REGISTER (? index))))
+ (load-indexed-address target base index 1 0))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (FLOAT-OFFSET-ADDRESS (REGISTER (? base))
+ (REGISTER (? index))))
+ (load-indexed-address target base index 8 0))
+
+(define-integrable (->areg reg)
+ (- reg 8))
+
+(define (load-indexed-address target base index scale offset)
+ (let ((load-address
+ (lambda (get-target-reference)
+ (let ((ea (indexed-ea base index scale offset)))
+ (LAP (LEA ,ea ,(get-target-reference)))))))
+ (cond ((or (not (machine-register? target))
+ (eq? (register-type target) 'ADDRESS))
+ (load-address
+ (lambda ()
+ (target-register-reference target 'ADDRESS))))
+ ((eq? (register-type target) 'DATA)
+ (let ((temp
+ (register-reference
+ (allocate-temporary-register! 'ADDRESS))))
+ (LAP ,@(load-address (lambda () temp))
+ (MOV L ,temp ,(register-reference target)))))
+ (else
+ (error "load-indexed-address: Unknown register type"
+ target)))))
+
+(define (target-register-reference target type)
+ (delete-dead-registers!)
+ (register-reference
+ (or (register-alias target type)
+ (allocate-alias-register! target type))))
+
(define-rule statement
- (ASSIGN (REGISTER (? target)) (OFFSET-ADDRESS (REGISTER (? source)) (? n)))
+ (ASSIGN (REGISTER (? target))
+ (OFFSET-ADDRESS (REGISTER (? source))
+ (MACHINE-CONSTANT (? n))))
(load-static-link target source (* 4 n) false))
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (BYTE-OFFSET-ADDRESS (REGISTER (? source))
+ (MACHINE-CONSTANT (? n))))
+ (load-static-link target source n false))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (FLOAT-OFFSET-ADDRESS (REGISTER (? source))
+ (MACHINE-CONSTANT (? n))))
+ (load-static-link target source (* 8 n) false))
+
(define-rule statement
;; This is an intermediate rule -- not intended to produce code.
(ASSIGN (REGISTER (? target))
(CONS-POINTER (MACHINE-CONSTANT (? type))
- (OFFSET-ADDRESS (REGISTER (? source)) (? n))))
+ (OFFSET-ADDRESS (REGISTER (? source))
+ (MACHINE-CONSTANT (? n)))))
(load-static-link target source (* 4 n)
(lambda (target)
(LAP (OR UL (& ,(make-non-pointer-literal type 0)) ,target)))))
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (BYTE-OFFSET-ADDRESS (REGISTER (? source)) (? n)))
- (load-static-link target source n false))
-
(define-rule statement
(ASSIGN (REGISTER (? target))
(CONS-POINTER (MACHINE-CONSTANT (? type))
- (BYTE-OFFSET-ADDRESS (REGISTER (? source)) (? n))))
+ (BYTE-OFFSET-ADDRESS (REGISTER (? source))
+ (MACHINE-CONSTANT (? n)))))
(load-static-link target source n
(lambda (target)
(LAP (OR UL (& ,(make-non-pointer-literal type 0)) ,target)))))
-
+
(define (load-static-link target source n suffix)
(cond ((and (not suffix) (zero? n))
(assign-register->register target source))
@@ -103,6 +165,7 @@ MIT in each case. |#
(else
(error "load-static-link: Unknown register type"
(register-type target))))))
+
(else
(let ((non-reusable
(cond ((not suffix)
@@ -148,11 +211,7 @@ MIT in each case. |#
(suffix (register-reference reusable-alias))
(LAP))))
non-reusable))))))
-
-(define (assign-register->register target source)
- (standard-move-to-target! source (register-type target) target)
- (LAP))
-
+
(define-rule statement
(ASSIGN (REGISTER (? target)) (OBJECT->TYPE (REGISTER (? source))))
;; See if we can reuse a source alias, because `object->type' can
@@ -172,7 +231,7 @@ MIT in each case. |#
(let ((source (register-reference source)))
(object->type source source)))
no-reuse))))
-
+
(define-rule statement
(ASSIGN (REGISTER (? target))
(CONS-POINTER (REGISTER (? type)) (REGISTER (? datum))))
@@ -313,96 +372,101 @@ MIT in each case. |#
(define-rule statement
(ASSIGN (REGISTER (? target))
- (OBJECT->TYPE (OFFSET (REGISTER (? address)) (? offset))))
- (let ((source (indirect-reference! address offset)))
+ (? expression rtl:simple-offset?))
+ (let ((source (offset->reference! expression)))
+ (LAP (MOV L ,source ,(standard-target-reference target)))))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (POST-INCREMENT (REGISTER 15) 1))
+ (LAP (MOV L (@A+ 7) ,(standard-target-reference target))))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (OBJECT->TYPE (? expression rtl:simple-offset?)))
+ (let ((source (offset->reference! expression)))
(delete-dead-registers!)
(object->type source (reference-target-alias! target 'DATA))))
(define-rule statement
(ASSIGN (REGISTER (? target))
- (OBJECT->DATUM (OFFSET (REGISTER (? address)) (? offset))))
- (convert-object/offset->register target address offset object->datum))
+ (OBJECT->DATUM (? expression rtl:simple-offset?)))
+ (convert-object/offset->register target expression object->datum))
(define-rule statement
(ASSIGN (REGISTER (? target))
- (OBJECT->ADDRESS (OFFSET (REGISTER (? address)) (? offset))))
- (convert-object/offset->register target address offset object->address))
+ (OBJECT->ADDRESS (? expression rtl:simple-offset?)))
+ (convert-object/offset->register target expression object->address))
(define-rule statement
(ASSIGN (REGISTER (? target))
(ADDRESS->FIXNUM
- (OBJECT->ADDRESS (OFFSET (REGISTER (? address)) (? offset)))))
- (convert-object/offset->register target address offset address->fixnum))
+ (OBJECT->ADDRESS (? expression rtl:simple-offset?))))
+ (convert-object/offset->register target expression address->fixnum))
(define-rule statement
(ASSIGN (REGISTER (? target))
- (OBJECT->FIXNUM (OFFSET (REGISTER (? address)) (? offset))))
- (convert-object/offset->register target address offset object->fixnum))
+ (OBJECT->FIXNUM (? expression rtl:simple-offset?)))
+ (convert-object/offset->register target expression object->fixnum))
-(define (convert-object/offset->register target address offset conversion)
- (let ((source (indirect-reference! address offset)))
+(define (convert-object/offset->register target expression conversion)
+ (let ((source (offset->reference! expression)))
(delete-dead-registers!)
(let ((target (reference-target-alias! target 'DATA)))
(LAP (MOV L ,source ,target)
,@(conversion target)))))
+
+;;;; Transfers to Memory
(define-rule statement
- (ASSIGN (REGISTER (? target)) (OFFSET (REGISTER (? address)) (? offset)))
- (let ((source (indirect-reference! address offset)))
- (LAP (MOV L ,source ,(standard-target-reference target)))))
+ (ASSIGN (? expression rtl:simple-offset?)
+ (REGISTER (? r)))
+ (QUALIFIER (register-value-class=word? r))
+ (LAP (MOV L
+ ,(standard-register-reference r false true)
+ ,(offset->reference! expression))))
(define-rule statement
- (ASSIGN (REGISTER (? target)) (POST-INCREMENT (REGISTER 15) 1))
- (LAP (MOV L (@A+ 7) ,(standard-target-reference target))))
-
-;;;; Transfers to Memory
+ (ASSIGN (? expression rtl:simple-offset?)
+ (POST-INCREMENT (REGISTER 15) 1))
+ (LAP (MOV L (@A+ 7) ,(offset->reference! expression))))
(define-rule statement
- (ASSIGN (OFFSET (REGISTER (? a)) (? n))
+ (ASSIGN (? expression rtl:simple-offset?)
(CONSTANT (? object)))
- (load-constant object (indirect-reference! a n)))
+ (load-constant object (offset->reference! expression)))
(define-rule statement
- (ASSIGN (OFFSET (REGISTER (? a)) (? n))
+ (ASSIGN (? expression rtl:simple-offset?)
(CONS-POINTER (MACHINE-CONSTANT (? type))
(MACHINE-CONSTANT (? datum))))
- (load-non-pointer type datum (indirect-reference! a n)))
-
-(define-rule statement
- (ASSIGN (OFFSET (REGISTER (? a)) (? n)) (REGISTER (? r)))
- (QUALIFIER (register-value-class=word? r))
- (LAP (MOV L
- ,(standard-register-reference r false true)
- ,(indirect-reference! a n))))
-
-(define-rule statement
- (ASSIGN (OFFSET (REGISTER (? a)) (? n))
- (POST-INCREMENT (REGISTER 15) 1))
- (LAP (MOV L (@A+ 7) ,(indirect-reference! a n))))
+ (load-non-pointer type datum (offset->reference! expression)))
(define-rule statement
- (ASSIGN (OFFSET (REGISTER (? address)) (? offset))
- (CONS-POINTER (MACHINE-CONSTANT (? type)) (REGISTER (? datum))))
- (let ((target (indirect-reference! address offset)))
+ (ASSIGN (? expression rtl:simple-offset?)
+ (CONS-POINTER (MACHINE-CONSTANT (? type))
+ (REGISTER (? datum))))
+ (let ((target (offset->reference! expression)))
(LAP (MOV L ,(standard-register-reference datum 'DATA true) ,target)
,@(memory-set-type type target))))
(define-rule statement
- (ASSIGN (OFFSET (REGISTER (? address)) (? offset))
+ (ASSIGN (? expression rtl:simple-offset?)
(CONS-POINTER (MACHINE-CONSTANT (? type))
- (OFFSET-ADDRESS (REGISTER (? source)) (? n))))
+ (OFFSET-ADDRESS (REGISTER (? source))
+ (MACHINE-CONSTANT (? n)))))
(let ((temp (reference-temporary-register! 'ADDRESS))
- (target (indirect-reference! address offset)))
+ (target (offset->reference! expression)))
(LAP (LEA ,(indirect-reference! source n) ,temp)
(MOV L ,temp ,target)
,@(memory-set-type type target))))
(define-rule statement
- (ASSIGN (OFFSET (REGISTER (? address)) (? offset))
+ (ASSIGN (? expression rtl:simple-offset?)
(CONS-POINTER (MACHINE-CONSTANT (? type))
- (BYTE-OFFSET-ADDRESS (REGISTER (? source)) (? n))))
+ (BYTE-OFFSET-ADDRESS (REGISTER (? source))
+ (MACHINE-CONSTANT (? n)))))
(let ((temp (reference-temporary-register! 'ADDRESS))
- (target (indirect-reference! address offset)))
+ (target (offset->reference! expression)))
(LAP (LEA ,(indirect-byte-reference! source n) ,temp)
(MOV L ,temp ,target)
,@(memory-set-type type target))))
@@ -410,12 +474,13 @@ MIT in each case. |#
;; Common case that can be done cheaply:
(define-rule statement
- (ASSIGN (OFFSET (REGISTER (? address)) (? offset))
- (BYTE-OFFSET-ADDRESS (OFFSET (REGISTER (? address)) (? offset))
- (? n)))
+ (ASSIGN (? expression0 rtl:simple-offset?)
+ (BYTE-OFFSET-ADDRESS (? expression rtl:simple-offset?)
+ (MACHINE-CONSTANT (? n))))
+ (QUALIFIER (equal? expression0 expression))
(if (zero? n)
(LAP)
- (let ((target (indirect-reference! address offset)))
+ (let ((target (offset->reference! expression)))
(cond ((<= 1 n 8)
(LAP (ADDQ L (& ,n) ,target)))
((<= -8 n -1)
@@ -428,31 +493,36 @@ MIT in each case. |#
(LAP (ADD L (& ,n) ,target)))))))
(define-rule statement
- (ASSIGN (OFFSET (REGISTER (? address)) (? offset))
+ (ASSIGN (? expression rtl:simple-offset?)
(CONS-POINTER (MACHINE-CONSTANT (? type))
(ENTRY:PROCEDURE (? label))))
(let ((temp (reference-temporary-register! 'ADDRESS))
- (target (indirect-reference! address offset)))
+ (target (offset->reference! expression)))
(LAP (LEA (@PCR ,(rtl-procedure/external-label (label->object label)))
,temp)
(MOV L ,temp ,target)
,@(memory-set-type type target))))
-(define-rule statement
- (ASSIGN (OFFSET (REGISTER (? a0)) (? n0))
- (OFFSET (REGISTER (? a1)) (? n1)))
- (if (and (= a0 a1) (= n0 n1))
- (LAP)
- (let ((source (indirect-reference! a1 n1)))
- (LAP (MOV L ,source ,(indirect-reference! a0 n0))))))
+#|
+;; This is no better than assigning to a register and then assigning
+;; from the register
(define-rule statement
- (ASSIGN (OFFSET (REGISTER (? a)) (? n))
+ (ASSIGN (? expression rtl:simple-offset?)
(FIXNUM->OBJECT (REGISTER (? source))))
- (let ((target (indirect-reference! a n)))
+ (let ((target (offset->reference! expression)))
(let ((temporary (standard-move-to-temporary! source 'DATA)))
(LAP ,@(fixnum->object temporary)
(MOV L ,temporary ,target)))))
+|#
+
+(define-rule statement
+ (ASSIGN (? expression0 rtl:simple-offset?)
+ (? expression1 rtl:simple-offset?))
+ (if (equal? expression0 expression1)
+ (LAP)
+ (LAP (MOV L ,(offset->reference! expression1)
+ ,(offset->reference! expression0)))))
;;;; Consing
@@ -472,8 +542,13 @@ MIT in each case. |#
(LAP (MOV L ,(standard-register-reference r false true) (@A+ 5))))
(define-rule statement
- (ASSIGN (POST-INCREMENT (REGISTER 13) 1) (OFFSET (REGISTER (? r)) (? n)))
- (LAP (MOV L ,(indirect-reference! r n) (@A+ 5))))
+ (ASSIGN (POST-INCREMENT (REGISTER 13) 1)
+ (? expression rtl:simple-offset?))
+ (LAP (MOV L ,(offset->reference! expression) (@A+ 5))))
+
+#|
+;; This is no better than assigning to a register and then assigning
+;; from the register
(define-rule statement
(ASSIGN (POST-INCREMENT (REGISTER 13) 1)
@@ -481,6 +556,7 @@ MIT in each case. |#
(let ((temporary (standard-move-to-temporary! r 'DATA)))
(LAP ,@(fixnum->object temporary)
(MOV L ,temporary (@A+ 5)))))
+|#
(define-rule statement
;; This pops the top of stack into the heap
@@ -527,20 +603,27 @@ MIT in each case. |#
(define-rule statement
(ASSIGN (PRE-INCREMENT (REGISTER 15) -1)
(CONS-POINTER (MACHINE-CONSTANT (? type))
- (OFFSET-ADDRESS (REGISTER (? r)) (? n))))
+ (OFFSET-ADDRESS (REGISTER (? r))
+ (MACHINE-CONSTANT (? n)))))
(LAP (PEA ,(indirect-reference! r n))
,@(memory-set-type type (INST-EA (@A 7)))))
(define-rule statement
(ASSIGN (PRE-INCREMENT (REGISTER 15) -1)
(CONS-POINTER (MACHINE-CONSTANT (? type))
- (BYTE-OFFSET-ADDRESS (REGISTER (? r)) (? n))))
+ (BYTE-OFFSET-ADDRESS (REGISTER (? r))
+ (MACHINE-CONSTANT (? n)))))
(LAP (PEA ,(indirect-byte-reference! r n))
,@(memory-set-type type (INST-EA (@A 7)))))
(define-rule statement
- (ASSIGN (PRE-INCREMENT (REGISTER 15) -1) (OFFSET (REGISTER (? r)) (? n)))
- (LAP (MOV L ,(indirect-reference! r n) (@-A 7))))
+ (ASSIGN (PRE-INCREMENT (REGISTER 15) -1)
+ (? expression rtl:simple-offset?))
+ (LAP (MOV L ,(offset->reference! expression) (@-A 7))))
+
+#|
+;; This is no better than assigning to a register and then assigning
+;; from the register
(define-rule statement
(ASSIGN (PRE-INCREMENT (REGISTER 15) -1)
@@ -548,6 +631,7 @@ MIT in each case. |#
(let ((temporary (standard-move-to-temporary! r 'DATA)))
(LAP ,@(fixnum->object temporary)
(MOV L ,temporary (@-A 7)))))
+|#
;;;; Fixnum Operations
@@ -653,21 +737,21 @@ MIT in each case. |#
(ASSIGN (? target)
(FIXNUM-2-ARGS MULTIPLY-FIXNUM
(OBJECT->FIXNUM (CONSTANT 4))
- (OBJECT->FIXNUM (OFFSET (REGISTER (? r)) (? n)))
+ (OBJECT->FIXNUM (? expression rtl:simple-offset?))
(? overflow?)))
(QUALIFIER (machine-operation-target? target))
overflow? ; ignored
- (convert-index->fixnum/offset target r n))
+ (convert-index->fixnum/offset target expression))
(define-rule statement
(ASSIGN (? target)
(FIXNUM-2-ARGS MULTIPLY-FIXNUM
- (OBJECT->FIXNUM (OFFSET (REGISTER (? r)) (? n)))
+ (OBJECT->FIXNUM (? expression rtl:simple-offset?))
(OBJECT->FIXNUM (CONSTANT 4))
(? overflow?)))
(QUALIFIER (machine-operation-target? target))
overflow? ; ignored
- (convert-index->fixnum/offset target r n))
+ (convert-index->fixnum/offset target expression))
;;; end (IF (<= SCHEME-TYPE-WIDTH 6) ...)
))
@@ -680,8 +764,8 @@ MIT in each case. |#
(lambda (target)
(LAP (AS L L (& ,(+ scheme-type-width 2)) ,target)))))
-(define (convert-index->fixnum/offset target address offset)
- (let ((source (indirect-reference! address offset)))
+(define (convert-index->fixnum/offset target expression)
+ (let ((source (offset->reference! expression)))
(reuse-and-operate-on-machine-target! 'DATA target
(lambda (target)
(LAP (MOV L ,source ,target)
@@ -698,7 +782,7 @@ MIT in each case. |#
(LAP (MOV L (A 5) ,target)
(OR L (& ,(make-non-pointer-literal (ucode-type flonum) 0)) ,target)
,@(load-non-pointer (ucode-type manifest-nm-vector)
- flonum-size
+ 2
(INST-EA (@A+ 5)))
(FMOVE D ,source (@A+ 5))))))
@@ -706,12 +790,11 @@ MIT in each case. |#
(ASSIGN (REGISTER (? target)) (OBJECT->FLOAT (REGISTER (? source))))
(let ((source (standard-move-to-temporary! source 'DATA))
(temp (allocate-temporary-register! 'ADDRESS)))
- (delete-dead-registers!)
(LAP ,@(object->address source)
(MOV L ,source ,(register-reference temp))
(FMOVE D
,(offset-reference temp 1)
- ,(reference-target-alias! target 'FLOAT)))))
+ ,(target-float-reference target)))))
(define-rule statement
(ASSIGN (? target)
@@ -757,56 +840,80 @@ MIT in each case. |#
(define-rule statement
(ASSIGN (REGISTER (? target))
- (CHAR->ASCII (OFFSET (REGISTER (? address)) (? offset))))
+ (CHAR->ASCII (REGISTER (? source))))
(load-char-into-register 0
- (indirect-char/ascii-reference! address offset)
+ (reference-alias-register! source 'DATA)
target))
(define-rule statement
(ASSIGN (REGISTER (? target))
- (CHAR->ASCII (REGISTER (? source))))
+ (CHAR->ASCII (? expression rtl:simple-offset?)))
(load-char-into-register 0
- (reference-alias-register! source 'DATA)
+ (offset->reference!/char expression)
target))
(define-rule statement
(ASSIGN (REGISTER (? target))
- (BYTE-OFFSET (REGISTER (? address)) (? offset)))
+ (? expression rtl:simple-byte-offset?))
(load-char-into-register 0
- (indirect-byte-reference! address offset)
+ (byte-offset->reference! expression)
target))
(define-rule statement
(ASSIGN (REGISTER (? target))
(CONS-POINTER (MACHINE-CONSTANT (? type))
- (BYTE-OFFSET (REGISTER (? address)) (? offset))))
+ (? expression rtl:simple-byte-offset?)))
(load-char-into-register type
- (indirect-byte-reference! address offset)
+ (byte-offset->reference! expression)
target))
(define-rule statement
- (ASSIGN (BYTE-OFFSET (REGISTER (? address)) (? offset))
- (CHAR->ASCII (CONSTANT (? character))))
- (LAP (MOV B
- (& ,(char->signed-8-bit-immediate character))
- ,(indirect-byte-reference! address offset))))
+ (ASSIGN (? expression rtl:simple-byte-offset?)
+ (REGISTER (? source)))
+ (LAP (MOV B ,(coerce->any/byte-reference source)
+ ,(byte-offset->reference! expression))))
(define-rule statement
- (ASSIGN (BYTE-OFFSET (REGISTER (? address)) (? offset))
- (REGISTER (? source)))
- (let ((source (coerce->any/byte-reference source)))
- (let ((target (indirect-byte-reference! address offset)))
- (LAP (MOV B ,source ,target)))))
+ (ASSIGN (? expression rtl:simple-byte-offset?)
+ (CHAR->ASCII (CONSTANT (? character))))
+ (LAP (MOV B (& ,(char->signed-8-bit-immediate character))
+ ,(byte-offset->reference! expression))))
(define-rule statement
- (ASSIGN (BYTE-OFFSET (REGISTER (? address)) (? offset))
+ (ASSIGN (? expression rtl:simple-byte-offset?)
(CHAR->ASCII (REGISTER (? source))))
- (let ((source (coerce->any/byte-reference source)))
- (let ((target (indirect-byte-reference! address offset)))
- (LAP (MOV B ,source ,target)))))
+ (LAP (MOV B ,(coerce->any/byte-reference source)
+ ,(byte-offset->reference! expression))))
(define-rule statement
- (ASSIGN (BYTE-OFFSET (REGISTER (? target)) (? target-offset))
- (CHAR->ASCII (OFFSET (REGISTER (? source)) (? source-offset))))
- (let ((source (indirect-char/ascii-reference! source source-offset)))
- (LAP (MOV B ,source ,(indirect-byte-reference! target target-offset)))))
\ No newline at end of file
+ (ASSIGN (? expression0 rtl:simple-byte-offset?)
+ (CHAR->ASCII (? expression1 rtl:simple-offset?)))
+ (LAP (MOV B ,(offset->reference!/char expression1)
+ ,(byte-offset->reference! expression0))))
+
+(define-rule statement
+ (ASSIGN (? expression0 rtl:simple-byte-offset?)
+ (? expression1 rtl:simple-byte-offset?))
+ (LAP (MOV B ,(byte-offset->reference! expression1)
+ ,(byte-offset->reference! expression0))))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (? expression rtl:simple-float-offset?))
+ (let ((ea (float-offset->reference! expression)))
+ (LAP (FMOVE D ,ea ,(target-float-reference target)))))
+
+(define-rule statement
+ (ASSIGN (? expression rtl:simple-float-offset?)
+ (REGISTER (? source)))
+ (LAP (FMOVE D ,(source-float-reference source)
+ ,(float-offset->reference! expression))))
+
+(define (target-float-reference target)
+ (delete-dead-registers!)
+ (reference-target-alias! target 'FLOAT))
+
+(define (source-float-reference source)
+ (register-reference
+ (or (register-alias source 'FLOAT)
+ (allocate-alias-register! source 'FLOAT))))
\ No newline at end of file
diff --git a/v7/src/compiler/machines/bobcat/rules2.scm b/v7/src/compiler/machines/bobcat/rules2.scm
index 1a88e9578..6de191290 100644
--- a/v7/src/compiler/machines/bobcat/rules2.scm
+++ b/v7/src/compiler/machines/bobcat/rules2.scm
@@ -1,8 +1,8 @@
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules2.scm,v 4.13 1992/07/05 14:20:58 jinx Exp $
+$Id: rules2.scm,v 4.14 1993/07/06 00:56:28 gjr Exp $
-Copyright (c) 1988-1992 Massachusetts Institute of Technology
+Copyright (c) 1988-1993 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
@@ -38,17 +38,18 @@ MIT in each case. |#
(declare (usual-integrations))
(define (predicate/memory-operand? expression)
- (or (and (rtl:offset? expression)
- (rtl:register? (rtl:offset-base expression)))
+ (or (rtl:simple-offset? expression)
(and (rtl:post-increment? expression)
(interpreter-stack-pointer?
(rtl:post-increment-register expression)))))
(define (predicate/memory-operand-reference expression)
(case (rtl:expression-type expression)
- ((OFFSET) (offset->indirect-reference! expression))
+ ((OFFSET)
+ (offset->reference! expression))
((POST-INCREMENT) (INST-EA (@A+ 7)))
- (else (error "Illegal memory operand" expression))))
+ (else
+ (error "Illegal memory operand" expression))))
(define (compare/register*register register-1 register-2 cc)
(let ((finish
@@ -125,10 +126,10 @@ MIT in each case. |#
type))))))
(define-rule predicate
- (TYPE-TEST (OBJECT->TYPE (OFFSET (REGISTER (? address)) (? offset)))
+ (TYPE-TEST (OBJECT->TYPE (? expression rtl:simple-offset?))
(? type))
(set-standard-branches! 'EQ)
- (let ((source (indirect-reference! address offset)))
+ (let ((source (offset->reference! expression)))
(cond ((= scheme-type-width 8)
(test-byte type source))
((and (zero? type) use-68020-instructions?)
diff --git a/v7/src/compiler/machines/bobcat/rules3.scm b/v7/src/compiler/machines/bobcat/rules3.scm
index 0e205db94..155190c66 100644
--- a/v7/src/compiler/machines/bobcat/rules3.scm
+++ b/v7/src/compiler/machines/bobcat/rules3.scm
@@ -1,8 +1,8 @@
#| -*-Scheme-*-
-$Id: rules3.scm,v 4.38 1993/02/19 17:48:51 cph Exp $
+$Id: rules3.scm,v 4.39 1993/07/06 00:56:29 gjr Exp $
-Copyright (c) 1988-93 Massachusetts Institute of Technology
+Copyright (c) 1988-1993 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
@@ -233,8 +233,10 @@ MIT in each case. |#
,@(generate/move-frame-up* frame-size temp))))
(define-rule statement
- (INVOCATION-PREFIX:MOVE-FRAME-UP (? frame-size)
- (OFFSET-ADDRESS (REGISTER 15) (? offset)))
+ (INVOCATION-PREFIX:MOVE-FRAME-UP
+ (? frame-size)
+ (OFFSET-ADDRESS (REGISTER 15)
+ (MACHINE-CONSTANT (? offset))))
(let ((how-far (- offset frame-size)))
(cond ((zero? how-far)
(LAP))
@@ -257,9 +259,10 @@ MIT in each case. |#
(generate/move-frame-up frame-size (offset-reference a7 offset))))))
(define-rule statement
- (INVOCATION-PREFIX:MOVE-FRAME-UP (? frame-size)
- (OFFSET-ADDRESS (REGISTER (? base))
- (? offset)))
+ (INVOCATION-PREFIX:MOVE-FRAME-UP
+ (? frame-size)
+ (OFFSET-ADDRESS (REGISTER (? base))
+ (MACHINE-CONSTANT (? offset))))
(generate/move-frame-up frame-size (indirect-reference! base offset)))
(define-rule statement
@@ -267,10 +270,11 @@ MIT in each case. |#
(LAP))
(define-rule statement
- (INVOCATION-PREFIX:DYNAMIC-LINK (? frame-size)
- (OFFSET-ADDRESS (REGISTER (? base))
- (? offset))
- (REGISTER 12))
+ (INVOCATION-PREFIX:DYNAMIC-LINK
+ (? frame-size)
+ (OFFSET-ADDRESS (REGISTER (? base))
+ (MACHINE-CONSTANT (? offset)))
+ (REGISTER 12))
(let ((label (generate-label))
(temp (allocate-temporary-register! 'ADDRESS)))
(let ((temp-ref (register-reference temp)))
@@ -816,6 +820,67 @@ long-word aligned and there is no need for shuffling.
,@(make-external-label (continuation-code-word false)
(generate-label)))))
+(define (generate/remote-links n-code-blocks code-blocks-label n-sections)
+ (if (= n-code-blocks 0)
+ (LAP)
+ (let ((loop (generate-label))
+ (bytes (generate-label)))
+ (LAP (CLR L (D 0))
+ ;; Set up counter
+ (MOV L (D 0) (@-A 7))
+ (BRA (@PCR ,loop))
+ (LABEL ,bytes)
+ ,@(sections->bytes n-code-blocks n-sections)
+ (LABEL ,loop)
+ ;; Increment counter for next iteration
+ (ADDQ L (& 1) (@A 7))
+ ;; Get subblock
+ (MOV L (@PCR ,code-blocks-label) (D 2))
+ (AND L (D 7) (D 2))
+ (MOV L (D 2) (A 0))
+ (MOV L (@AOXS 0 4 ((D 0) L 4)) (D 2))
+ ;; Get number of linkage sections
+ (CLR L (D 4))
+ (MOV B (@PCRXS ,bytes ((D 0) L 1)) (D 4))
+ ;; block -> address
+ (AND L (D 7) (D 2))
+ (MOV L (D 2) (A 0))
+ ;; Get length and non-marked length
+ (MOV L (@A 0) (D 3))
+ (MOV L (@AO 0 4) (D 5))
+ ;; Strip type tags
+ (AND L (D 7) (D 3))
+ (AND L (D 7) (D 5))
+ ;; Store environment
+ (MOV L ,reg:environment (@AOXS 0 0 ((D 3) L 4)))
+ ;; Address of first constant (linkage area)
+ (LEA (@AOXS 0 8 ((D 5) L 4)) (A 1))
+ (MOV L (A 1) (D 3))
+ (JSR ,entry:compiler-link)
+ ,@(make-external-label (continuation-code-word false)
+ (generate-label))
+ ;; Counter value
+ (MOV L (@A 7) (D 0))
+ ;; Exit loop if we've done all
+ (CMP L (& ,n-code-blocks) (D 0))
+ (B NE (@PCR ,loop))
+ ;; Pop counter off the stack
+ (ADDQ L (& 4) (A 7))))))
+
+(define (sections->bytes n-code-blocks n-sections)
+ (let walk ((bytes
+ (append (vector->list n-sections)
+ (let ((left (remainder n-code-blocks 2)))
+ (if (zero? left)
+ '()
+ (make-list (- 2 left) 0))))))
+ (if (null? bytes)
+ (LAP)
+ (let ((hi (car bytes))
+ (lo (cadr bytes)))
+ (LAP (DC UW ,(+ lo (* 256 hi)))
+ ,@(walk (cddr bytes)))))))
+
(define (generate/constants-block constants references assignments
uuo-links global-links static-vars)
(let ((constant-info
diff --git a/v7/src/compiler/machines/bobcat/rules4.scm b/v7/src/compiler/machines/bobcat/rules4.scm
index 79f3d8514..78f2e3cf9 100644
--- a/v7/src/compiler/machines/bobcat/rules4.scm
+++ b/v7/src/compiler/machines/bobcat/rules4.scm
@@ -1,8 +1,8 @@
#| -*-Scheme-*-
-$Id: rules4.scm,v 4.13 1992/11/09 18:46:07 jinx Exp $
+$Id: rules4.scm,v 4.14 1993/07/06 00:56:31 gjr Exp $
-Copyright (c) 1988-1992 Massachusetts Institute of Technology
+Copyright (c) 1988-1993 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
@@ -89,8 +89,7 @@ MIT in each case. |#
(and (rtl:cons-pointer? expression)
(rtl:machine-constant? (rtl:cons-pointer-type expression))
(rtl:machine-constant? (rtl:cons-pointer-datum expression)))
- (and (rtl:offset? expression)
- (rtl:register? (rtl:offset-base expression)))))
+ (rtl:simple-offset? expression)))
(define (interpreter-call-argument->machine-register! expression register)
(let ((target (register-reference register)))
@@ -108,7 +107,7 @@ MIT in each case. |#
(rtl:cons-pointer-datum expression))
target)))
((OFFSET)
- (let ((source-reference (offset->indirect-reference! expression)))
+ (let ((source-reference (offset->reference! expression)))
(LAP ,@(clear-registers! register)
(MOV L ,source-reference ,target))))
(else
diff --git a/v7/src/compiler/machines/bobcat/rulrew.scm b/v7/src/compiler/machines/bobcat/rulrew.scm
index 995917318..c42f88fa7 100644
--- a/v7/src/compiler/machines/bobcat/rulrew.scm
+++ b/v7/src/compiler/machines/bobcat/rulrew.scm
@@ -1,8 +1,8 @@
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rulrew.scm,v 1.5 1992/03/31 19:50:01 jinx Exp $
+$Id: rulrew.scm,v 1.6 1993/07/06 00:56:32 gjr Exp $
-Copyright (c) 1990-91 Massachusetts Institute of Technology
+Copyright (c) 1990-1993 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
@@ -193,7 +193,11 @@ MIT in each case. |#
(? operand-1)
(REGISTER (? operand-2 register-known-value))
(? overflow?))
- (QUALIFIER (rtl:constant-fixnum-test operand-2 (lambda (n) true)))
+ (QUALIFIER
+ (rtl:constant-fixnum-test operand-2
+ (lambda (n)
+ n ; ignored
+ true)))
(rtl:make-fixnum-2-args 'FIXNUM-LSH operand-1 operand-2 overflow?))
(define (rtl:constant-fixnum? expression)
@@ -206,4 +210,55 @@ MIT in each case. |#
(and (rtl:constant? expression)
(let ((n (rtl:constant-value expression)))
(and (fix:fixnum? n)
- (predicate n)))))))
\ No newline at end of file
+ (predicate n)))))))
+
+;;;; Indexed addressing modes
+
+(define-rule rewriting
+ (OFFSET (REGISTER (? base register-known-value))
+ (MACHINE-CONSTANT (? value)))
+ (QUALIFIER (and (rtl:offset-address? base)
+ (rtl:simple-subexpressions? base)))
+ (rtl:make-offset base (rtl:make-machine-constant value)))
+
+(define-rule rewriting
+ (BYTE-OFFSET (REGISTER (? base register-known-value))
+ (MACHINE-CONSTANT (? value)))
+ (QUALIFIER (and (rtl:byte-offset-address? base)
+ (rtl:simple-subexpressions? base)))
+ (rtl:make-byte-offset base (rtl:make-machine-constant value)))
+
+(define-rule rewriting
+ (FLOAT-OFFSET (REGISTER (? base register-known-value))
+ (MACHINE-CONSTANT (? value)))
+ (QUALIFIER (and (rtl:float-offset-address? base)
+ (rtl:simple-subexpressions? base)))
+ (if (zero? value)
+ (rtl:make-float-offset
+ (rtl:float-offset-address-base base)
+ (rtl:float-offset-address-offset base))
+ (rtl:make-float-offset base (rtl:make-machine-constant value))))
+
+(define-rule rewriting
+ (FLOAT-OFFSET (REGISTER (? base register-known-value))
+ (MACHINE-CONSTANT (? value)))
+ (QUALIFIER
+ (and (rtl:offset-address? base)
+ (rtl:simple-subexpressions? base)
+ (rtl:machine-constant? (rtl:offset-address-offset base))))
+ (rtl:make-float-offset base (rtl:make-machine-constant value)))
+
+;; This is here to avoid generating things like
+;;
+;; (offset (offset-address (object->address (constant #(foo bar baz gack)))
+;; (register 29))
+;; (machine-constant 1))
+;;
+;; since the offset-address subexpression is constant, and therefore
+;; known!
+
+(define (rtl:simple-subexpressions? expr)
+ (for-all? (cdr expr)
+ (lambda (sub)
+ (or (rtl:machine-constant? sub)
+ (rtl:register? sub)))))
\ No newline at end of file