From: Guillermo J. Rozas Date: Fri, 16 Jul 1993 19:27:58 +0000 (+0000) Subject: Update back end to reflect changes to the RTL and to handle X-Git-Tag: 20090517-FFI~8199 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=6400d4440940fb49b31bde4be747bee09514d787;p=mit-scheme.git Update back end to reflect changes to the RTL and to handle floating-point vectors. --- diff --git a/v7/src/compiler/machines/i386/decls.scm b/v7/src/compiler/machines/i386/decls.scm index de95968f1..0ea209b85 100644 --- a/v7/src/compiler/machines/i386/decls.scm +++ b/v7/src/compiler/machines/i386/decls.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -482,6 +482,8 @@ MIT in each case. |# (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") diff --git a/v7/src/compiler/machines/i386/lapgen.scm b/v7/src/compiler/machines/i386/lapgen.scm index 3c0b3305e..750d19702 100644 --- a/v7/src/compiler/machines/i386/lapgen.scm +++ b/v7/src/compiler/machines/i386/lapgen.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -83,9 +83,13 @@ MIT in each case. |# (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 @@ -96,6 +100,10 @@ MIT in each case. |# (define (register->home-transfer source target) (machine->pseudo-register source target)) + +(define-integrable (float-register-reference? ea) + (and (pair? ea) + (eq? (car ea) 'ST))) ;;;; Linearizer interface @@ -310,10 +318,12 @@ MIT in each case. |# (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)) @@ -324,23 +334,176 @@ MIT in each case. |# (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))) - + +(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))))) + +(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))))) + +(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))))) + (define (object->type target) (LAP (SHR W ,target (& ,scheme-datum-width)))) @@ -356,8 +519,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))) @@ -372,7 +534,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 W ,target ,source-reference)))) (else diff --git a/v7/src/compiler/machines/i386/machin.scm b/v7/src/compiler/machines/i386/machin.scm index 5fe42652b..1921984fb 100644 --- a/v7/src/compiler/machines/i386/machin.scm +++ b/v7/src/compiler/machines/i386/machin.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -208,23 +208,29 @@ MIT in each case. |# (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)) @@ -248,13 +254,10 @@ MIT in each case. |# (= (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)) (define (rtl:machine-register? rtl-register) (case rtl-register @@ -336,7 +339,8 @@ MIT in each case. |# 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)) @@ -359,5 +363,4 @@ MIT in each case. |# ;; 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 diff --git a/v7/src/compiler/machines/i386/rules1.scm b/v7/src/compiler/machines/i386/rules1.scm index c533445f7..679cf16e2 100644 --- a/v7/src/compiler/machines/i386/rules1.scm +++ b/v7/src/compiler/machines/i386/rules1.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -51,25 +51,54 @@ MIT in each case. |# (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 @@ -179,8 +208,8 @@ MIT in each case. |# ;;;; 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 @@ -190,33 +219,33 @@ MIT in each case. |# ;;;; 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))))) ;;;; Consing @@ -248,9 +277,9 @@ MIT in each case. |# (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 @@ -261,44 +290,43 @@ MIT in each case. |# 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)))) ;;;; Utilities specific to rules1 @@ -331,6 +359,11 @@ MIT in each case. |# 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) @@ -348,12 +381,120 @@ MIT in each case. |# (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)) + +;;;; 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)))))) + +;;;; 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 diff --git a/v7/src/compiler/machines/i386/rules2.scm b/v7/src/compiler/machines/i386/rules2.scm index 686393be8..f74fd11e9 100644 --- a/v7/src/compiler/machines/i386/rules2.scm +++ b/v7/src/compiler/machines/i386/rules2.scm @@ -1,9 +1,8 @@ #| -*-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 @@ -55,15 +54,15 @@ MIT in each case. |# (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 @@ -81,17 +80,17 @@ MIT in each case. |# (&U ,(non-pointer->literal constant))))) (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 @@ -113,15 +112,15 @@ MIT in each case. |# (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 diff --git a/v7/src/compiler/machines/i386/rules3.scm b/v7/src/compiler/machines/i386/rules3.scm index 7f1355c39..aee3be0c8 100644 --- a/v7/src/compiler/machines/i386/rules3.scm +++ b/v7/src/compiler/machines/i386/rules3.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -265,8 +265,10 @@ MIT in each case. |# (LAP)) (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) diff --git a/v7/src/compiler/machines/i386/rulfix.scm b/v7/src/compiler/machines/i386/rulfix.scm index f916c5aab..ef49b4005 100644 --- a/v7/src/compiler/machines/i386/rulfix.scm +++ b/v7/src/compiler/machines/i386/rulfix.scm @@ -1,9 +1,8 @@ #| -*-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 @@ -153,9 +152,9 @@ MIT in each case. |# (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) @@ -167,17 +166,17 @@ MIT in each case. |# (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 @@ -198,18 +197,18 @@ MIT in each case. |# (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 diff --git a/v7/src/compiler/machines/i386/rulflo.scm b/v7/src/compiler/machines/i386/rulflo.scm index 9ba8e8ed8..6e2207900 100644 --- a/v7/src/compiler/machines/i386/rulflo.scm +++ b/v7/src/compiler/machines/i386/rulflo.scm @@ -1,9 +1,8 @@ #| -*-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 @@ -74,11 +73,8 @@ MIT in each case. |# ,(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))) @@ -90,18 +86,86 @@ MIT in each case. |# (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)) + +;;;; 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)))) ;;;; Flonum Arithmetic @@ -136,30 +200,38 @@ MIT in each case. |# (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) ;; This is used in order to avoid using two stack locations for ;; the remainder unary operations. @@ -169,7 +241,7 @@ MIT in each case. |# ;; 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)) @@ -179,64 +251,69 @@ MIT in each case. |# (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 + )))) -(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) @@ -244,11 +321,20 @@ MIT in each case. |# (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) @@ -257,8 +343,16 @@ MIT in each case. |# (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))))) (define-rule statement (ASSIGN (REGISTER (? target)) @@ -373,31 +467,33 @@ MIT in each case. |# (,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))))))) -(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) diff --git a/v7/src/compiler/machines/i386/rulrew.scm b/v7/src/compiler/machines/i386/rulrew.scm index 6d459f3d2..14c373b34 100644 --- a/v7/src/compiler/machines/i386/rulrew.scm +++ b/v7/src/compiler/machines/i386/rulrew.scm @@ -1,9 +1,8 @@ #| -*-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 @@ -102,10 +101,11 @@ MIT in each case. |# (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)) @@ -113,18 +113,19 @@ MIT in each case. |# (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))) @@ -322,4 +323,57 @@ MIT in each case. |# (predicate n))))))) (define (flo:one? value) - (flo:= value 1.)) \ No newline at end of file + (flo:= value 1.)) + +;;;; 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))))) + +