floating-point vectors.
#| -*-Scheme-*-
-$Id: decls.scm,v 1.4 1992/11/18 03:50:59 gjr Exp $
+$Id: decls.scm,v 1.5 1993/07/16 19:27:46 gjr Exp $
-Copyright (c) 1992 Massachusetts Institute of Technology
+Copyright (c) 1992-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-integration-dependencies "rtlbase" "rtlcon" "base" "cfg3" "utils")
(define-integration-dependencies "rtlbase" "rtlcon" "machines/i386"
"machin")
+ (file-dependency/integration/join (filename/append "rtlbase" "rtlcon")
+ rtl-base)
(define-integration-dependencies "rtlbase" "rtlexp" "rtlbase"
"rtlreg" "rtlty1")
(define-integration-dependencies "rtlbase" "rtline" "base" "cfg1" "cfg2")
#| -*-Scheme-*-
-$Id: lapgen.scm,v 1.22 1993/02/23 17:34:10 gjr Exp $
+$Id: lapgen.scm,v 1.23 1993/07/16 19:27:48 gjr Exp $
Copyright (c) 1992-1993 Massachusetts Institute of Technology
(machine->machine-register source target))
(define (reference->register-transfer source target)
- (if (equal? (INST-EA (R ,target)) source)
- (LAP)
- (memory->machine-register source target)))
+ (cond ((equal? (register-reference target) source)
+ (LAP))
+ ((float-register-reference? source)
+ ;; Assume target is a float register
+ (LAP (FLD ,source)))
+ (else
+ (memory->machine-register source target))))
(define-integrable (pseudo-register-home register)
(offset-reference regnum:regs-pointer
(define (register->home-transfer source target)
(machine->pseudo-register source target))
+
+(define-integrable (float-register-reference? ea)
+ (and (pair? ea)
+ (eq? (car ea) 'ST)))
\f
;;;; Linearizer interface
(define-integrable (temporary-register-reference)
(reference-temporary-register! 'GENERAL))
-(define (source-register-reference source)
- (register-reference
+(define (source-register source)
(or (register-alias source 'GENERAL)
- (load-alias-register! source 'GENERAL))))
+ (load-alias-register! source 'GENERAL)))
+
+(define-integrable (source-register-reference source)
+ (register-reference (source-register source)))
(define-integrable (any-reference rtl-reg)
(standard-register-reference rtl-reg 'GENERAL true))
(define (standard-move-to-target! source target)
(register-reference (move-to-alias-register! source 'GENERAL target)))
-(define-integrable (source-indirect-reference! rtl-reg offset)
- (indirect-reference! rtl-reg offset))
-
-(define-integrable (target-indirect-reference! rtl-reg offset)
- (indirect-reference! rtl-reg offset))
-
(define (indirect-reference! rtl-reg offset)
(offset-reference (allocate-indirection-register! rtl-reg)
offset))
+(define (indirect-byte-reference! register offset)
+ (byte-offset-reference (allocate-indirection-register! register) offset))
+
(define-integrable (allocate-indirection-register! register)
(load-alias-register! register 'GENERAL))
-
-(define (offset->indirect-reference! rtl-expr)
- (indirect-reference! (rtl:register-number (rtl:offset-base rtl-expr))
- (rtl:offset-number rtl-expr)))
-
+\f
+(define (with-indexed-address base* index* scale b-offset protect recvr)
+ (let* ((base (allocate-indirection-register! base*))
+ (index (source-register index*))
+ (with-address-temp
+ (lambda (temp)
+ (let ((tref (register-reference temp))
+ (ea (indexed-ea-mode base index scale b-offset)))
+ (LAP (LEA ,tref ,ea)
+ ,@(object->address tref)
+ ,@(recvr (INST-EA (@R ,temp)))))))
+ (with-reused-temp
+ (lambda (temp)
+ (need-register! temp)
+ (with-address-temp temp)))
+ (fail-index
+ (lambda ()
+ (with-address-temp
+ (allocate-temporary-register! 'GENERAL))))
+ (fail-base
+ (lambda ()
+ (if (and protect (= index* protect))
+ (fail-index)
+ (reuse-pseudo-register-alias! index*
+ 'GENERAL
+ with-reused-temp
+ fail-index)))))
+ (if (and protect (= base* protect))
+ (fail-base)
+ (reuse-pseudo-register-alias! base*
+ 'GENERAL
+ with-reused-temp
+ fail-base))))
+
+(define (indexed-ea base index scale offset)
+ (indexed-ea-mode (allocate-indirection-register! base)
+ (source-register index)
+ scale
+ offset))
+
+(define (indexed-ea-mode base index scale offset)
+ (cond ((zero? offset)
+ (INST-EA (@RI ,base ,index ,scale)))
+ ((<= -128 offset 127)
+ (INST-EA (@ROI B ,base ,offset ,index ,scale)))
+ (else
+ (INST-EA (@ROI W ,base ,offset ,index ,scale)))))
+\f
+(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 (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 (rtl:detagged-index? base offset)
+ (let ((o-ok? (and (rtl:object->datum? offset)
+ (rtl:register? (rtl:object->datum-expression offset)))))
+ (if (and (rtl:object->address? base)
+ (rtl:register? (rtl:object->address-expression base)))
+ (or o-ok? (rtl:register? offset))
+ (and o-ok? (rtl:register? base)))))
+\f
+(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-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)))))
+\f
(define (object->type target)
(LAP (SHR W ,target (& ,scheme-datum-width))))
(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)))
(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 W ,target ,source-reference))))
(else
#| -*-Scheme-*-
-$Id: machin.scm,v 1.17 1993/06/29 22:25:12 gjr Exp $
+$Id: machin.scm,v 1.18 1993/07/16 19:27:49 gjr Exp $
Copyright (c) 1992-1993 Massachusetts Institute of Technology
(define (interpreter-register:unbound?)
(rtl:make-machine-register eax))
-(define-integrable (interpreter-value-register)
+(define-integrable (interpreter-block-register offset-value)
(rtl:make-offset (interpreter-regs-pointer)
- register-block/value-offset))
+ (rtl:make-machine-constant offset-value)))
-(define (interpreter-value-register? expression)
+(define-integrable (interpreter-block-register? expression offset-value)
(and (rtl:offset? expression)
(interpreter-regs-pointer? (rtl:offset-base expression))
- (= (rtl:offset-number expression) register-block/value-offset)))
+ (let ((offset (rtl:offset-offset expression)))
+ (and (rtl:machine-constant? offset)
+ (= (rtl:machine-constant-value offset)
+ offset-value)))))
+
+(define-integrable (interpreter-value-register)
+ (interpreter-block-register register-block/value-offset))
+
+(define (interpreter-value-register? expression)
+ (interpreter-block-register? expression register-block/value-offset))
(define (interpreter-environment-register)
- (rtl:make-offset (interpreter-regs-pointer)
- register-block/environment-offset))
+ (interpreter-block-register register-block/environment-offset))
(define (interpreter-environment-register? expression)
- (and (rtl:offset? expression)
- (interpreter-regs-pointer? (rtl:offset-base expression))
- (= (rtl:offset-number expression) register-block/environment-offset)))
+ (interpreter-block-register? expression register-block/environment-offset))
(define (interpreter-free-pointer)
(rtl:make-machine-register regnum:free-pointer))
(= (rtl:register-number expression) regnum:stack-pointer)))
(define (interpreter-dynamic-link)
- (rtl:make-offset (interpreter-regs-pointer)
- register-block/dynamic-link-offset))
+ (interpreter-block-register register-block/dynamic-link-offset))
(define (interpreter-dynamic-link? expression)
- (and (rtl:offset? expression)
- (interpreter-regs-pointer? (rtl:offset-base expression))
- (= (rtl:offset-number expression) register-block/dynamic-link-offset)))
+ (interpreter-block-register? expression register-block/dynamic-link-offset))
\f
(define (rtl:machine-register? rtl-register)
(case rtl-register
VARIABLE-CACHE)
(+ get-pc-cost based-reference-cost))
((OFFSET-ADDRESS
- BYTE-OFFSET-ADDRESS)
+ BYTE-OFFSET-ADDRESS
+ FLOAT-OFFSET-ADDRESS)
address-offset-cost)
((CONS-POINTER)
(and (rtl:machine-constant? (rtl:cons-pointer-type expression))
;; Disabled for now. The F2XM1 instruction is
;; broken on the 387 (or at least some of them).
FLONUM-EXP
- VECTOR-CONS STRING-ALLOCATE FLOATING-VECTOR-CONS
- FLOATING-VECTOR-REF FLOATING-VECTOR-SET!))
\ No newline at end of file
+ VECTOR-CONS STRING-ALLOCATE FLOATING-VECTOR-CONS))
\ No newline at end of file
#| -*-Scheme-*-
-$Id: rules1.scm,v 1.17 1993/03/28 21:53:34 gjr Exp $
+$Id: rules1.scm,v 1.18 1993/07/16 19:27:52 gjr Exp $
Copyright (c) 1992-1993 Massachusetts Institute of Technology
(assign-register->register target source))
(define-rule statement
- (ASSIGN (REGISTER (? target)) (OFFSET-ADDRESS (REGISTER (? source)) (? n)))
+ (ASSIGN (REGISTER (? target))
+ (OFFSET-ADDRESS (REGISTER (? source))
+ (REGISTER (? index))))
+ (load-indexed-register target source index 4))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (OFFSET-ADDRESS (REGISTER (? source))
+ (MACHINE-CONSTANT (? n))))
(load-displaced-register target source (* 4 n)))
(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))))
- (load-displaced-register/typed target source type (* 4 n)))
+ (BYTE-OFFSET-ADDRESS (REGISTER (? source))
+ (REGISTER (? index))))
+ (load-indexed-register target source index 1))
(define-rule statement
(ASSIGN (REGISTER (? target))
- (BYTE-OFFSET-ADDRESS (REGISTER (? source)) (? n)))
+ (BYTE-OFFSET-ADDRESS (REGISTER (? source))
+ (MACHINE-CONSTANT (? n))))
(load-displaced-register target source n))
(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (FLOAT-OFFSET-ADDRESS (REGISTER (? source))
+ (REGISTER (? index))))
+ (load-indexed-register target source index 8))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (FLOAT-OFFSET-ADDRESS (REGISTER (? source))
+ (MACHINE-CONSTANT (? n))))
+ (load-displaced-register target source (* 8 n)))
+
+(define-rule statement
+ ;; This is an intermediate rule -- not intended to produce code.
(ASSIGN (REGISTER (? target))
(CONS-POINTER (MACHINE-CONSTANT (? type))
- (BYTE-OFFSET-ADDRESS (REGISTER (? source)) (? n))))
+ (OFFSET-ADDRESS (REGISTER (? source))
+ (MACHINE-CONSTANT (? n)))))
+ (load-displaced-register/typed target source type (* 4 n)))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (CONS-POINTER (MACHINE-CONSTANT (? type))
+ (BYTE-OFFSET-ADDRESS (REGISTER (? source))
+ (MACHINE-CONSTANT (? n)))))
(load-displaced-register/typed target source type n))
(define-rule statement
;;;; Transfers from Memory
(define-rule statement
- (ASSIGN (REGISTER (? target)) (OFFSET (REGISTER (? address)) (? offset)))
- (let ((source (source-indirect-reference! address offset)))
+ (ASSIGN (REGISTER (? target)) (? expression rtl:simple-offset?))
+ (let ((source (offset->reference! expression)))
(LAP (MOV W ,(target-register-reference target) ,source))))
(define-rule statement
;;;; Transfers to Memory
(define-rule statement
- (ASSIGN (OFFSET (REGISTER (? a)) (? n)) (REGISTER (? r)))
+ (ASSIGN (? expression rtl:simple-offset?) (REGISTER (? r)))
(QUALIFIER (register-value-class=word? r))
(let ((source (source-register-reference r)))
(LAP (MOV W
- ,(target-indirect-reference! a n)
+ ,(offset->reference! expression)
,source))))
(define-rule statement
- (ASSIGN (OFFSET (REGISTER (? a)) (? n)) (CONSTANT (? value)))
+ (ASSIGN (? expression rtl:simple-offset?) (CONSTANT (? value)))
(QUALIFIER (non-pointer-object? value))
- (LAP (MOV W ,(target-indirect-reference! a n)
+ (LAP (MOV W ,(offset->reference! expression)
(&U ,(non-pointer->literal value)))))
(define-rule statement
- (ASSIGN (OFFSET (REGISTER (? a)) (? n))
+ (ASSIGN (? expression rtl:simple-offset?)
(CONS-POINTER (MACHINE-CONSTANT (? type))
(MACHINE-CONSTANT (? datum))))
- (LAP (MOV W ,(target-indirect-reference! a n)
+ (LAP (MOV W ,(offset->reference! expression)
(&U ,(make-non-pointer-literal type datum)))))
(define-rule statement
- (ASSIGN (OFFSET (REGISTER (? address)) (? offset))
- (BYTE-OFFSET-ADDRESS (OFFSET (REGISTER (? address)) (? offset))
- (? n)))
+ (ASSIGN (? expression rtl:simple-offset?)
+ (BYTE-OFFSET-ADDRESS (? expression)
+ (MACHINE-CONSTANT (? n))))
(if (zero? n)
(LAP)
- (LAP (ADD W ,(target-indirect-reference! address offset) (& ,n)))))
+ (LAP (ADD W ,(offset->reference! expression) (& ,n)))))
\f
;;;; Consing
(define-rule statement
(ASSIGN (REGISTER (? target))
- (CHAR->ASCII (OFFSET (REGISTER (? address)) (? offset))))
+ (CHAR->ASCII (? expression rtl:simple-offset?)))
(load-char-into-register 0
- (indirect-char/ascii-reference! address offset)
+ (offset->reference! expression)
target))
(define-rule statement
target))
(define-rule statement
- (ASSIGN (REGISTER (? target))
- (BYTE-OFFSET (REGISTER (? address)) (? offset)))
+ (ASSIGN (REGISTER (? target)) (? 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))
+ (ASSIGN (? expression rtl:simple-byte-offset?)
(CHAR->ASCII (CONSTANT (? character))))
(LAP (MOV B
- ,(indirect-byte-reference! address offset)
+ ,(byte-offset->reference! expression)
(& ,(char->signed-8-bit-immediate character)))))
-(define (char->signed-8-bit-immediate character)
- (let ((ascii (char->ascii character)))
- (if (< ascii 128) ascii (- ascii 256))))
-
(define-rule statement
- (ASSIGN (BYTE-OFFSET (REGISTER (? address)) (? offset))
+ (ASSIGN (? expression rtl:simple-byte-offset?)
(REGISTER (? source)))
- (let ((source (source-register-reference source)))
- (let ((target (indirect-byte-reference! address offset)))
- (LAP (MOV B ,target ,source)))))
+ (let* ((source (source-register-reference source))
+ (target (byte-offset->reference! expression)))
+ (LAP (MOV B ,target ,source))))
(define-rule statement
- (ASSIGN (BYTE-OFFSET (REGISTER (? address)) (? offset))
+ (ASSIGN (? expression rtl:simple-byte-offset?)
(CHAR->ASCII (REGISTER (? source))))
- (let ((source (source-register-reference source)))
- (let ((target (indirect-byte-reference! address offset)))
- (LAP (MOV B ,target ,source)))))
+ (let ((source (source-register-reference source))
+ (target (byte-offset->reference! expression)))
+ (LAP (MOV B ,target ,source))))
+
+(define (char->signed-8-bit-immediate character)
+ (let ((ascii (char->ascii character)))
+ (if (< ascii 128) ascii (- ascii 256))))
\f
;;;; Utilities specific to rules1
n))
false))
+(define (load-indexed-register target source index scale)
+ (let* ((source (indexed-ea source index scale 0))
+ (target (target-register-reference target)))
+ (LAP (LEA ,target ,source))))
+
(define (load-pc-relative-address/typed target type label)
(with-pc
(lambda (pc-label pc-register)
(LAP ,@(load-non-pointer target type 0)
(MOV B ,target ,source))))))
-(define (indirect-char/ascii-reference! register offset)
- (indirect-byte-reference! register (* offset 4)))
-
-(define (indirect-byte-reference! register offset)
- (byte-offset-reference (allocate-indirection-register! register) offset))
-
(define (indirect-unsigned-byte-reference! register offset)
(byte-unsigned-offset-reference (allocate-indirection-register! register)
- offset))
\ No newline at end of file
+ offset))
+\f
+;;;; Improved vector and string references
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (? expression rtl:detagged-offset?))
+ (with-detagged-vector-location expression false
+ (lambda (temp)
+ (LAP (MOV W ,(target-register-reference target) ,temp)))))
+
+(define-rule statement
+ (ASSIGN (? expression rtl:detagged-offset?)
+ (REGISTER (? source)))
+ (QUALIFIER (register-value-class=word? source))
+ (with-detagged-vector-location expression source
+ (lambda (temp)
+ (LAP (MOV W ,temp ,(source-register-reference source))))))
+
+(define (with-detagged-vector-location rtl-expression protect recvr)
+ (with-decoded-detagged-offset rtl-expression
+ (lambda (base index offset)
+ (with-indexed-address base index 4 (* 4 offset) protect recvr))))
+
+(define (rtl:detagged-offset? expression)
+ (and (rtl:offset? expression)
+ (rtl:machine-constant? (rtl:offset-offset expression))
+ (let ((base (rtl:offset-base expression)))
+ (and (rtl:offset-address? base)
+ (rtl:detagged-index? (rtl:offset-address-base base)
+ (rtl:offset-address-offset base))))
+ expression))
+
+(define (with-decoded-detagged-offset expression recvr)
+ (let ((base (rtl:offset-base expression)))
+ (let ((base* (rtl:offset-address-base base))
+ (index (rtl:offset-address-offset base)))
+ (recvr (rtl:register-number (if (rtl:register? base*)
+ base*
+ (rtl:object->address-expression base*)))
+ (rtl:register-number (if (rtl:register? index)
+ index
+ (rtl:object->datum-expression index)))
+ (rtl:machine-constant-value (rtl:offset-offset expression))))))
+\f
+;;;; Improved string references
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (? expression rtl:detagged-byte-offset?))
+ (load-char-indexed/detag 0 target expression))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (CONS-POINTER (MACHINE-CONSTANT (? type))
+ (? expression rtl:detagged-byte-offset?)))
+ (load-char-indexed/detag type target expression))
+
+(define-rule statement
+ (ASSIGN (? expression rtl:detagged-byte-offset?)
+ (REGISTER (? source)))
+ (store-char-indexed/detag expression
+ source
+ (source-register-reference source)))
+
+(define-rule statement
+ (ASSIGN (? expression rtl:detagged-byte-offset?)
+ (CHAR->ASCII (REGISTER (? source))))
+ (store-char-indexed/detag expression
+ source
+ (source-register-reference source)))
+
+(define-rule statement
+ (ASSIGN (? expression rtl:detagged-byte-offset?)
+ (CHAR->ASCII (CONSTANT (? character))))
+ (store-char-indexed/detag expression
+ false
+ (INST-EA (& ,(char->signed-8-bit-immediate
+ character)))))
+
+(define (load-char-indexed/detag tag target rtl-source-expression)
+ (with-detagged-string-location rtl-source-expression false
+ (lambda (temp)
+ (load-char-into-register tag temp target))))
+
+(define (store-char-indexed/detag rtl-target-expression protect source)
+ (with-detagged-string-location rtl-target-expression protect
+ (lambda (temp)
+ (LAP (MOV B ,temp ,source)))))
+
+(define (with-detagged-string-location rtl-expression protect recvr)
+ (with-decoded-detagged-byte-offset rtl-expression
+ (lambda (base index offset)
+ (with-indexed-address base index 1 offset protect recvr))))
+
+(define (rtl:detagged-byte-offset? expression)
+ (and (rtl:byte-offset? expression)
+ (rtl:machine-constant? (rtl:byte-offset-offset expression))
+ (let ((base (rtl:byte-offset-base expression)))
+ (and (rtl:byte-offset-address? base)
+ (rtl:detagged-index? (rtl:byte-offset-address-base base)
+ (rtl:byte-offset-address-offset base))))
+ expression))
+
+(define (with-decoded-detagged-byte-offset expression recvr)
+ (let ((base (rtl:byte-offset-base expression)))
+ (let ((base* (rtl:byte-offset-address-base base))
+ (index (rtl:byte-offset-address-offset base)))
+ (recvr (rtl:register-number (if (rtl:register? base*)
+ base*
+ (rtl:object->address-expression base*)))
+ (rtl:register-number (if (rtl:register? index)
+ index
+ (rtl:object->datum-expression index)))
+ (rtl:machine-constant-value
+ (rtl:byte-offset-offset expression))))))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/i386/rules2.scm,v 1.5 1992/02/28 20:23:57 jinx Exp $
-$MC68020-Header: rules2.scm,v 4.12 90/01/18 22:44:04 GMT cph Exp $
+$Id: rules2.scm,v 1.6 1993/07/16 19:27:54 gjr Exp $
-Copyright (c) 1992 Massachusetts Institute of Technology
+Copyright (c) 1992-1993 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(compare/register*register register-1 register-2))
(define-rule predicate
- (EQ-TEST (REGISTER (? register)) (OFFSET (REGISTER (? address)) (? offset)))
+ (EQ-TEST (REGISTER (? register)) (? expression rtl:simple-offset?))
(set-equal-branches!)
(LAP (CMP W ,(source-register-reference register)
- ,(source-indirect-reference! address offset))))
+ ,(offset->reference! expression))))
(define-rule predicate
- (EQ-TEST (OFFSET (REGISTER (? address)) (? offset)) (REGISTER (? register)))
+ (EQ-TEST (? expression rtl:simple-offset?) (REGISTER (? register)))
(set-equal-branches!)
- (LAP (CMP W ,(source-indirect-reference! address offset)
+ (LAP (CMP W ,(offset->reference! expression)
,(source-register-reference register))))
(define-rule predicate
(&U ,(non-pointer->literal constant)))))
\f
(define-rule predicate
- (EQ-TEST (CONSTANT (? constant)) (OFFSET (REGISTER (? address)) (? offset)))
+ (EQ-TEST (CONSTANT (? constant)) (? expression rtl:simple-offset?))
(QUALIFIER (non-pointer-object? constant))
(set-equal-branches!)
- (LAP (CMP W ,(source-indirect-reference! address offset)
+ (LAP (CMP W ,(offset->reference! expression)
(&U ,(non-pointer->literal constant)))))
(define-rule predicate
- (EQ-TEST (OFFSET (REGISTER (? address)) (? offset)) (CONSTANT (? constant)))
+ (EQ-TEST (? expression rtl:simple-offset?) (CONSTANT (? constant)))
(QUALIFIER (non-pointer-object? constant))
(set-equal-branches!)
- (LAP (CMP W ,(source-indirect-reference! address offset)
+ (LAP (CMP W ,(offset->reference! expression)
(&U ,(non-pointer->literal constant)))))
(define-rule predicate
(define-rule predicate
(EQ-TEST (CONS-POINTER (MACHINE-CONSTANT (? type))
(MACHINE-CONSTANT (? datum)))
- (OFFSET (REGISTER (? address)) (? offset)))
+ (? expression rtl:simple-offset?))
(set-equal-branches!)
- (LAP (CMP W ,(source-indirect-reference! address offset)
+ (LAP (CMP W ,(offset->reference! expression)
(&U ,(make-non-pointer-literal type datum)))))
(define-rule predicate
- (EQ-TEST (OFFSET (REGISTER (? address)) (? offset))
+ (EQ-TEST (? expression rtl:simple-offset?)
(CONS-POINTER (MACHINE-CONSTANT (? type))
(MACHINE-CONSTANT (? datum))))
(set-equal-branches!)
- (LAP (CMP W ,(source-indirect-reference! address offset)
+ (LAP (CMP W ,(offset->reference! expression)
(&U ,(make-non-pointer-literal type datum)))))
\ No newline at end of file
#| -*-Scheme-*-
-$Id: rules3.scm,v 1.25 1993/03/01 17:35:59 gjr Exp $
+$Id: rules3.scm,v 1.26 1993/07/16 19:27:55 gjr Exp $
Copyright (c) 1992-1993 Massachusetts Institute of Technology
(LAP))
\f
(define-rule statement
- (INVOCATION-PREFIX:MOVE-FRAME-UP (? frame-size)
- (OFFSET-ADDRESS (REGISTER 4) (? offset)))
+ (INVOCATION-PREFIX:MOVE-FRAME-UP
+ (? frame-size)
+ (OFFSET-ADDRESS (REGISTER 4)
+ (MACHINE-CONSTANT (? offset))))
(QUALIFIER (or (zero? (- offset frame-size)) (< frame-size 3)))
(let ((how-far (- offset frame-size)))
(cond ((zero? how-far)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/i386/rulfix.scm,v 1.25 1992/04/18 04:13:12 jinx Exp $
-$MC68020-Header: /scheme/src/compiler/machines/bobcat/RCS/rules1.scm,v 4.36 1991/10/25 06:49:58 cph Exp $
+$Id: rulfix.scm,v 1.26 1993/07/16 19:27:56 gjr Exp $
-Copyright (c) 1992 Massachusetts Institute of Technology
+Copyright (c) 1992-1993 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(object->fixnum (standard-move-to-temporary! register)))
(define-rule predicate
- (FIXNUM-PRED-1-ARG (? predicate) (OFFSET (REGISTER (? address)) (? offset)))
+ (FIXNUM-PRED-1-ARG (? predicate) (? expression rtl:simple-offset?))
(fixnum-branch! (fixnum-predicate/unary->binary predicate))
- (LAP (CMP W ,(source-indirect-reference! address offset) (& 0))))
+ (LAP (CMP W ,(offset->reference! expression) (& 0))))
(define-rule predicate
(FIXNUM-PRED-2-ARGS (? predicate)
(define-rule predicate
(FIXNUM-PRED-2-ARGS (? predicate)
(REGISTER (? register))
- (OFFSET (REGISTER (? address)) (? offset)))
+ (? expression rtl:simple-offset?))
(fixnum-branch! predicate)
(LAP (CMP W ,(source-register-reference register)
- ,(source-indirect-reference! address offset))))
+ ,(offset->reference! expression))))
(define-rule predicate
(FIXNUM-PRED-2-ARGS (? predicate)
- (OFFSET (REGISTER (? address)) (? offset))
+ (? expression rtl:simple-offset?)
(REGISTER (? register)))
(fixnum-branch! predicate)
- (LAP (CMP W ,(source-indirect-reference! address offset)
+ (LAP (CMP W ,(offset->reference! expression)
,(source-register-reference register))))
(define-rule predicate
\f
(define-rule predicate
(FIXNUM-PRED-2-ARGS (? predicate)
- (OFFSET (REGISTER (? address)) (? offset))
+ (? expression rtl:simple-offset?)
(OBJECT->FIXNUM (CONSTANT (? constant))))
(fixnum-branch! predicate)
- (LAP (CMP W ,(source-indirect-reference! address offset)
+ (LAP (CMP W ,(offset->reference! expression)
(& ,(* constant fixnum-1)))))
(define-rule predicate
(FIXNUM-PRED-2-ARGS (? predicate)
(OBJECT->FIXNUM (CONSTANT (? constant)))
- (OFFSET (REGISTER (? address)) (? offset)))
+ (? expression rtl:simple-offset?))
(fixnum-branch! (commute-fixnum-predicate predicate))
- (LAP (CMP W ,(source-indirect-reference! address offset)
+ (LAP (CMP W ,(offset->reference! expression)
(& ,(* constant fixnum-1)))))
;; This assumes that the immediately preceding instruction sets the
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/i386/rulflo.scm,v 1.19 1992/08/12 06:03:49 jinx Exp $
-$MC68020-Header: /scheme/src/compiler/machines/bobcat/RCS/rules1.scm,v 4.36 1991/10/25 06:49:58 cph Exp $
+$Id: rulflo.scm,v 1.20 1993/07/16 19:27:57 gjr Exp $
-Copyright (c) 1992 Massachusetts Institute of Technology
+Copyright (c) 1992-1993 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
,(offset-reference regnum:regs-pointer (1+ off)))
(MOV W (@RO B ,regnum:free-pointer 4) ,target)
(MOV W (@RO B ,regnum:free-pointer 8) ,temp)))
- (let ((sti (floreg->sti source)))
- (if (zero? sti)
- (LAP (FST D (@RO B ,regnum:free-pointer 4)))
- (LAP (FLD (ST ,(floreg->sti source)))
- (FSTP D (@RO B ,regnum:free-pointer 4))))))
+ (store-float (floreg->sti source)
+ (INST-EA (@RO B ,regnum:free-pointer 4))))
(LEA ,target
(@RO UW ,regnum:free-pointer
,(make-non-pointer-literal (ucode-type flonum) 0)))
(let* ((source (move-to-temporary-register! source 'GENERAL))
(target (flonum-target! target)))
(LAP ,@(object->address (register-reference source))
- (FLD D (@RO B ,source 4))
- (FSTP (ST ,(1+ target))))))
+ ,@(load-float (INST-EA (@RO B ,source 4)) target))))
(define-rule statement
(ASSIGN (REGISTER (? target))
- (OBJECT->FLOAT (CONSTANT (? value))))
- (QUALIFIER (or (= value 0.) (= value 1.)))
+ (OBJECT->FLOAT (CONSTANT (? value flonum-bit?))))
(let ((target (flonum-target! target)))
(LAP ,@(if (= value 0.)
(LAP (FLDZ))
(LAP (FLD1)))
(FSTP (ST ,(1+ target))))))
+
+(define (flonum-bit? value)
+ (and (or (= value 0.) (= value 1.))
+ value))
+\f
+;;;; Floating-point vector support.
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (? expression rtl:simple-float-offset?))
+ (let* ((source (float-offset->reference! expression))
+ (target (flonum-target! target)))
+ (load-float source target)))
+
+(define-rule statement
+ (ASSIGN (? expression rtl:simple-float-offset?) (REGISTER (? source)))
+ (let ((source (flonum-source! source))
+ (target (float-offset->reference! expression)))
+ (store-float source target)))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (? expression rtl:detagged-float-offset?))
+ (with-detagged-float-location expression
+ (lambda (temp)
+ (load-float temp target))))
+
+(define-rule statement
+ (ASSIGN (? expression rtl:detagged-float-offset?)
+ (REGISTER (? source)))
+ (with-detagged-float-location expression
+ (lambda (temp)
+ (store-float (flonum-source! source) temp))))
+
+(define (with-detagged-float-location rtl-expression recvr)
+ ;; Never needs to protect a register because it is a float register!
+ (with-decoded-detagged-float-offset rtl-expression
+ (lambda (base index w-offset)
+ (with-indexed-address base index 8 (* 4 w-offset) false recvr))))
+
+(define (rtl:detagged-float-offset? expression)
+ (and (rtl:float-offset? expression)
+ (let ((base (rtl:float-offset-base expression))
+ (offset (rtl:float-offset-offset expression)))
+ (and (rtl:offset-address? base)
+ (rtl:machine-constant? (rtl:offset-address-offset base))
+ (rtl:detagged-index? (rtl:offset-address-base base)
+ offset)))
+ expression))
+
+(define (with-decoded-detagged-float-offset expression recvr)
+ (let ((base (rtl:float-offset-base expression))
+ (index (rtl:float-offset-offset expression)))
+ (let ((base* (rtl:offset-address-base base)))
+ (recvr (rtl:register-number (if (rtl:register? base*)
+ base*
+ (rtl:object->address-expression base*)))
+ (rtl:register-number (if (rtl:register? index)
+ index
+ (rtl:object->datum-expression index)))
+ (rtl:machine-constant-value (rtl:offset-address-offset base))))))
+
+(define (load-float ea sti)
+ (LAP (FLD D ,ea)
+ (FSTP (ST ,(1+ sti)))))
+
+(define (store-float sti ea)
+ (if (zero? sti)
+ (LAP (FST D ,ea))
+ (LAP (FLD (ST ,sti))
+ (FSTP D ,ea))))
\f
;;;; Flonum Arithmetic
(LAP (FLD (ST ,', source))
(,opcode)
(FSTP (ST ,',(1+ target)))))))))))
- (define-flonum-operation flonum-negate FCHS)
- (define-flonum-operation flonum-abs FABS)
- (define-flonum-operation flonum-sin FSIN)
- (define-flonum-operation flonum-cos FCOS)
- (define-flonum-operation flonum-sqrt FSQRT)
- (define-flonum-operation flonum-round FRNDINT))
-
-(define-arithmetic-method 'flonum-truncate flonum-methods/1-arg
- (flonum-unary-operation/general
- (lambda (target source)
- (let ((temp (temporary-register-reference)))
- (LAP (FSTCW (@R ,regnum:free-pointer))
- ,@(if (and (zero? target) (zero? source))
- (LAP)
- (LAP (FLD (ST ,source))))
- (MOV B ,temp (@RO B ,regnum:free-pointer 1))
- (OR B (@RO B ,regnum:free-pointer 1) (&U #x0c))
- (FNLDCW (@R ,regnum:free-pointer))
- (FRNDINT)
- (MOV B (@RO B ,regnum:free-pointer 1) ,temp)
- ,@(if (and (zero? target) (zero? source))
- (LAP)
- (LAP (FSTP (ST ,(1+ target)))))
- (FNLDCW (@R ,regnum:free-pointer)))))))
+ (define-flonum-operation FLONUM-NEGATE FCHS)
+ (define-flonum-operation FLONUM-ABS FABS)
+ (define-flonum-operation FLONUM-SIN FSIN)
+ (define-flonum-operation FLONUM-COS FCOS)
+ (define-flonum-operation FLONUM-SQRT FSQRT)
+ (define-flonum-operation FLONUM-ROUND FRNDINT))
+
+;; These (and FLONUM-ROUND above) presume that the default rounding mode
+;; is round-to-nearest/even
+
+(define (define-rounding prim-name mode)
+ (define-arithmetic-method prim-name flonum-methods/1-arg
+ (flonum-unary-operation/general
+ (lambda (target source)
+ (let ((temp (temporary-register-reference)))
+ (LAP (FSTCW (@R ,regnum:free-pointer))
+ ,@(if (and (zero? target) (zero? source))
+ (LAP)
+ (LAP (FLD (ST ,source))))
+ (MOV B ,temp (@RO B ,regnum:free-pointer 1))
+ (OR B (@RO B ,regnum:free-pointer 1) (&U ,mode))
+ (FNLDCW (@R ,regnum:free-pointer))
+ (FRNDINT)
+ (MOV B (@RO B ,regnum:free-pointer 1) ,temp)
+ ,@(if (and (zero? target) (zero? source))
+ (LAP)
+ (LAP (FSTP (ST ,(1+ target)))))
+ (FNLDCW (@R ,regnum:free-pointer))))))))
+
+(define-rounding 'FLONUM-CEILING #x08)
+(define-rounding 'FLONUM-FLOOR #x04)
+(define-rounding 'FLONUM-TRUNCATE #x0c)
\f
;; This is used in order to avoid using two stack locations for
;; the remainder unary operations.
;; Perhaps this can be improved?
(rtl-target:=machine-register! target fr0)
(LAP ,@source->top
- ,@(operate 0 0)))
+ ,@(operate)))
(if (or (machine-register? source)
(not (is-alias-for-register? fr0 source))
(delete-dead-registers!)
(finish (LAP)))))
-(define-arithmetic-method 'flonum-log flonum-methods/1-arg
+(define-arithmetic-method 'FLONUM-LOG flonum-methods/1-arg
(flonum-unary-operation/stack-top
- (lambda (target source)
- (if (and (zero? target) (zero? source))
- (LAP (FLDLN2)
- (FXCH (ST 0) (ST 1))
- (FYL2X))
- (LAP (FLDLN2)
- (FLD (ST ,(1+ source)))
- (FYL2X)
- (FSTP (ST ,(1+ target))))))))
-
-(define-arithmetic-method 'flonum-exp flonum-methods/1-arg
+ (lambda ()
+ #|
+ (LAP (FLDLN2)
+ (FLD (ST ,(1+ source)))
+ (FYL2X)
+ (FSTP (ST ,(1+ target))))
+ |#
+ (LAP (FLDLN2)
+ (FXCH (ST 0) (ST 1))
+ (FYL2X)))))
+
+(define-arithmetic-method 'FLONUM-EXP flonum-methods/1-arg
(flonum-unary-operation/stack-top
- (lambda (target source)
- (if (and (zero? target) (zero? source))
- (LAP (FLDL2E)
- (FMULP (ST 1) (ST 0))
- (F2XM1)
- (FLD1)
- (FADDP (ST 1) (ST 0)))
- (LAP (FLD (ST ,source))
- (FLDL2E)
- (FMULP (ST 1) (ST 0))
- (F2XM1)
- (FLD1)
- (FADDP (ST 1) (ST 0))
- (FSTP (ST ,(1+ target))))))))
-
-(define-arithmetic-method 'flonum-tan flonum-methods/1-arg
+ (lambda ()
+ #|
+ (LAP (FLD (ST ,source))
+ (FLDL2E)
+ (FMULP (ST 1) (ST 0))
+ (F2XM1)
+ (FLD1)
+ (FADDP (ST 1) (ST 0))
+ (FSTP (ST ,(1+ target))))
+ |#
+ (LAP (FLDL2E)
+ (FMULP (ST 1) (ST 0))
+ (F2XM1)
+ (FLD1)
+ (FADDP (ST 1) (ST 0))))))
+
+(define-arithmetic-method 'FLONUM-TAN flonum-methods/1-arg
(flonum-unary-operation/stack-top
- (lambda (target source)
- (if (and (zero? target) (zero? source))
- (LAP (FPTAN)
- (FSTP (ST 0))) ; FPOP
- (LAP (FLD (ST ,source))
- (FPTAN)
- (FSTP (ST 0)) ; FPOP
- (FSTP (ST ,(1+ target))))))))
+ (lambda ()
+ #|
+ (LAP (FLD (ST ,source))
+ (FPTAN)
+ (FSTP (ST 0)) ; FPOP
+ (FSTP (ST ,(1+ target))))
+ |#
+ (LAP (FPTAN)
+ (FSTP (ST 0)) ; FPOP
+ ))))
\f
-(define-arithmetic-method 'flonum-atan flonum-methods/1-arg
+(define-arithmetic-method 'FLONUM-ATAN flonum-methods/1-arg
+ (flonum-unary-operation/stack-top
+ (lambda ()
+ #|
+ (LAP (FLD (ST ,source))
+ (FLD1)
+ (FPATAN)
+ (FSTP (ST ,(1+ target))))
+ |#
+ (LAP (FLD1)
+ (FPATAN)))))
+
+;; For now, these preserve values in memory
+;; in order to avoid flushing a stack location.
+
+(define-arithmetic-method 'FLONUM-ACOS flonum-methods/1-arg
(flonum-unary-operation/stack-top
- (lambda (target source)
- (if (and (zero? target) (zero? source))
- (LAP (FLD1)
- (FPATAN))
- (LAP (FLD (ST ,source))
- (FLD1)
- (FPATAN)
- (FSTP (ST ,(1+ target))))))))
-
-#|
-;; These really need two locations on the stack.
-;; To avoid that, they are rewritten at the RTL level into simpler operations.
-
-(define-arithmetic-method 'flonum-acos flonum-methods/1-arg
- (flonum-unary-operation/general
- (lambda (target source)
+ (lambda ()
+ #|
(LAP (FLD (ST ,source))
(FMUL (ST 0) (ST 0))
(FLD1)
(FSQRT)
(FLD (ST ,(1+ source)))
(FPATAN)
- (FSTP (ST ,(1+ target)))))))
+ (FSTP (ST ,(1+ target))))
+ |#
+ (LAP (FST D (@R ,regnum:free-pointer))
+ (FMUL (ST 0) (ST 0))
+ (FLD1)
+ (F%SUBP (ST 1) (ST 0))
+ (FSQRT)
+ (FLD D (@R ,regnum:free-pointer))
+ (FPATAN)))))
-(define-arithmetic-method 'flonum-asin flonum-methods/1-arg
- (flonum-unary-operation/general
- (lambda (target source)
+(define-arithmetic-method 'FLONUM-ASIN flonum-methods/1-arg
+ (flonum-unary-operation/stack-top
+ (lambda ()
+ #|
(LAP (FLD (ST ,source))
(FMUL (ST 0) (ST 0))
(FLD1)
(FLD (ST ,(1+ source)))
(FXCH (ST 0) (ST 1))
(FPATAN)
- (FSTP (ST ,(1+ target)))))))
-|#
+ (FSTP (ST ,(1+ target))))
+ |#
+ (LAP (FST D (@R ,regnum:free-pointer))
+ (FMUL (ST 0) (ST 0))
+ (FLD1)
+ (F%SUBP (ST 1) (ST 0))
+ (FSQRT)
+ (FLD D (@R ,regnum:free-pointer))
+ (FXCH (ST 0) (ST 1))
+ (FPATAN)))))
\f
(define-rule statement
(ASSIGN (REGISTER (? target))
(,op2%1 (ST 0) (ST ,',(1+ source)))
(FSTP (ST ,',(1+ target))))))))))))
- (define-flonum-operation flonum-add fadd faddp fadd faddp)
- (define-flonum-operation flonum-subtract f%sub f%subp f%subr f%subpr)
- (define-flonum-operation flonum-multiply fmul fmulp fmul fmulp)
- (define-flonum-operation flonum-divide f%div f%divp f%divr f%divpr))
+ (define-flonum-operation FLONUM-ADD FADD FADDP FADD FADDP)
+ (define-flonum-operation FLONUM-SUBTRACT F%SUB F%SUBP F%SUBR F%SUBPR)
+ (define-flonum-operation FLONUM-MULTIPLY FMUL FMULP FMUL FMULP)
+ (define-flonum-operation FLONUM-DIVIDE F%DIV F%DIVP F%DIVR F%DIVPR))
-(define-arithmetic-method 'flonum-atan2 flonum-methods/2-args
+(define-arithmetic-method 'FLONUM-ATAN2 flonum-methods/2-args
(lambda (target source1 source2)
- (if (or (machine-register? source1)
- (not (is-alias-for-register? fr0 source1))
- (not (dead-register? source1)))
- (let* ((source1->top (load-machine-register! source1 fr0))
- (source2 (if (= source2 source1)
- fr0
- (flonum-source! source2))))
- (rtl-target:=machine-register! target fr0)
- (LAP ,@source1->top
- (FLD (ST ,source2))
- (FPATAN)))
+ (if (and (not (machine-register? source1))
+ (is-alias-for-register? fr0 source1)
+ (dead-register? source1))
(let ((source2 (flonum-source! source2)))
(delete-dead-registers!)
(rtl-target:=machine-register! target fr0)
(LAP (FLD (ST ,source2))
- (FPATAN))))))
+ (FPATAN)))
+ (begin
+ (prefix-instructions! (load-machine-register! source1 fr0))
+ (need-register! fr0)
+ (let ((source2 (if (= source2 source1)
+ fr0
+ (flonum-source! source2))))
+ (delete-dead-registers!)
+ (rtl-target:=machine-register! target fr0)
+ (LAP (FLD (ST ,source2))
+ (FPATAN)))))))
\f
-(define-arithmetic-method 'flonum-remainder flonum-methods/2-args
+(define-arithmetic-method 'FLONUM-REMAINDER flonum-methods/2-args
(flonum-binary-operation
(lambda (target source1 source2)
(if (zero? source2)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/i386/rulrew.scm,v 1.11 1992/03/31 20:48:14 jinx Exp $
-$MC68020-Header: /scheme/src/compiler/machines/bobcat/RCS/rulrew.scm,v 1.4 1991/10/25 06:50:06 cph Exp $
+$Id: rulrew.scm,v 1.12 1993/07/16 19:27:58 gjr Exp $
-Copyright (c) 1992 Massachusetts Institute of Technology
+Copyright (c) 1992-1993 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(list 'ASSIGN target comparand))
(define-rule rewriting
- (ASSIGN (OFFSET (REGISTER (? address)) (? offset))
+ (ASSIGN (OFFSET (REGISTER (? address)) (MACHINE-CONSTANT (? offset)))
(REGISTER (? source register-known-value)))
(QUALIFIER
(and (rtl:byte-offset-address? source)
+ (rtl:machine-constant? (rtl:byte-offset-address-offset source))
(let ((base (let ((base (rtl:byte-offset-address-base source)))
(if (rtl:register? base)
(register-known-value (rtl:register-number base))
(and base
(rtl:offset? base)
(let ((base* (rtl:offset-base base))
- (offset* (rtl:offset-number base)))
- (and (= (rtl:register-number base*) address)
- (= offset* offset)))))))
+ (offset* (rtl:offset-offset base)))
+ (and (rtl:machine-constant? offset*)
+ (= (rtl:register-number base*) address)
+ (= (rtl:machine-constant-value offset*) offset)))))))
(let ((target (let ((base (rtl:byte-offset-address-base source)))
(if (rtl:register? base)
(register-known-value (rtl:register-number base))
base))))
(list 'ASSIGN
target
- (rtl:make-byte-offset-address target
- (rtl:byte-offset-address-number
- source)))))
+ (rtl:make-byte-offset-address
+ target
+ (rtl:byte-offset-address-offset source)))))
(define-rule rewriting
(EQ-TEST (? source) (REGISTER (? comparand register-known-value)))
(predicate n)))))))
(define (flo:one? value)
- (flo:= value 1.))
\ No newline at end of file
+ (flo:= value 1.))
+\f
+;;;; 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)))))
+
+
projects / mit-scheme.git / commitdiff