From 739069d4559c0f2bfe80b05bf1e438eb761653f0 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Fri, 25 Oct 1991 00:15:37 +0000 Subject: [PATCH] * Introduce new RTL expression type CONS-NON-POINTER and change appropriate instances of CONS-POINTER to use the new type. * Replace RTL expression type @ADDRESS->FLOAT with new type OBJECT->FLOAT. * Introduce new internal switch USE-PRE/POST-INCREMENT?. Change code generation of in-line consing to pay attention to this switch. * Merge common parts of "machine/make" into new file "base/make". On MIPS: * Change code sequence that assigns type codes to assume that the type field has a known value. This eliminates one instruction in every type-code assignment. It assumes that the data segment bits have a certain value, but the microcode already does this. * Cache immediate constants in registers, and remember which registers contain which constants. (This should be improved by noticing when arithmetic operations are done on known constants and cacheing the results.) * Set USE-PRE/POST-INCREMENT? to false, saving one instruction in every CONS, and multiple instructions in each call to VECTOR. --- v7/src/compiler/machines/mips/lapgen.scm | 224 ++++++++++-------- v7/src/compiler/machines/mips/machin.scm | 18 +- v7/src/compiler/machines/mips/make.scm-big | 11 +- v7/src/compiler/machines/mips/make.scm-little | 11 +- v7/src/compiler/machines/mips/rules1.scm | 98 ++++---- v7/src/compiler/machines/mips/rules2.scm | 17 +- v7/src/compiler/machines/mips/rules3.scm | 80 ++++--- v7/src/compiler/machines/mips/rules4.scm | 9 +- v7/src/compiler/machines/mips/rulfix.scm | 46 ++-- v7/src/compiler/machines/mips/rulflo.scm | 40 ++-- v7/src/compiler/machines/mips/rulrew.scm | 43 +++- v7/src/compiler/rtlbase/rtlcon.scm | 167 ++++++++----- v7/src/compiler/rtlbase/rtlexp.scm | 29 ++- v7/src/compiler/rtlbase/rtlty1.scm | 11 +- v7/src/compiler/rtlgen/opncod.scm | 41 ++-- v7/src/compiler/rtlopt/rcompr.scm | 16 +- v7/src/compiler/rtlopt/rinvex.scm | 88 ++++--- 17 files changed, 540 insertions(+), 409 deletions(-) diff --git a/v7/src/compiler/machines/mips/lapgen.scm b/v7/src/compiler/machines/mips/lapgen.scm index 8413540c6..6057a72e1 100644 --- a/v7/src/compiler/machines/mips/lapgen.scm +++ b/v7/src/compiler/machines/mips/lapgen.scm @@ -1,7 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/lapgen.scm,v 1.7 1991/08/17 00:15:34 cph Exp $ -$MC68020-Header: lapgen.scm,v 4.26 90/01/18 22:43:36 GMT cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/lapgen.scm,v 1.8 1991/10/25 00:13:08 cph Exp $ Copyright (c) 1988-91 Massachusetts Institute of Technology @@ -153,20 +152,27 @@ MIT in each case. |# ((FLOAT) (fp-store-doubleword offset base source)) (else (error "unknown register type" source)))) -(define (load-constant constant target #!optional delay-slot?) +(define (load-constant target constant delay-slot? record?) ;; Load a Scheme constant into a machine register. - (let ((delay-slot? (and (not (default-object? delay-slot?)) delay-slot?))) - (if (non-pointer-object? constant) - (load-immediate (non-pointer->literal constant) target) - (load-pc-relative target - 'CONSTANT - (constant->label constant) - delay-slot?)))) - -(define (load-non-pointer type datum target) - ;; Load a Scheme non-pointer constant, defined by type and datum, - ;; into a machine register. - (load-immediate (make-non-pointer-literal type datum) target)) + (if (non-pointer-object? constant) + (load-immediate target (non-pointer->literal constant) record?) + (load-pc-relative target + 'CONSTANT + (constant->label constant) + delay-slot?))) + +(define (deposit-type-address type source target) + (deposit-type-datum (fix:xor (quotient #x10 type-scale-factor) type) + source + target)) + +(define (deposit-type-datum type source target) + (with-values + (lambda () + (immediate->register (make-non-pointer-literal type 0))) + (lambda (prefix alias) + (LAP ,@prefix + (XOR ,target ,alias ,source))))) (define (non-pointer->literal constant) (make-non-pointer-literal (object-type constant) @@ -174,18 +180,6 @@ MIT in each case. |# (define-integrable (make-non-pointer-literal type datum) (+ (* type (expt 2 scheme-datum-width)) datum)) - -(define-integrable (deposit-type type-num target-reg) - (if (= target-reg regnum:assembler-temp) - (error "deposit-type: into register 1")) - (LAP (AND ,target-reg ,target-reg ,regnum:address-mask) - ,@(put-type type-num target-reg))) - -(define-integrable (put-type type-num target-reg) - ; Assumes that target-reg has 0 in type bits - (LAP (LUI ,regnum:assembler-temp - ,(* type-scale-factor #x100 type-num)) - (OR ,target-reg ,regnum:assembler-temp ,target-reg))) ;;;; Regularized Machine Instructions @@ -224,23 +218,6 @@ MIT in each case. |# (LAP) (LAP (ADD ,t 0 ,r)))) -(define (add-immediate value source dest) - (if (fits-in-16-bits-signed? value) - (LAP (ADDIU ,dest ,source ,value)) - (LAP ,@(load-immediate value regnum:assembler-temp) - (ADDU ,dest ,regnum:assembler-temp ,source)))) - -(define (load-immediate value dest) - (cond ((fits-in-16-bits-signed? value) - (LAP (ADDIU ,dest 0 ,value))) - ((fits-in-16-bits-unsigned? value) - (LAP (ORI ,dest 0 ,value))) - ((top-16-bits-only? value) - (LAP (LUI ,dest ,(top-16-bits value)))) - (else - (LAP (LUI ,dest ,(top-16-bits value)) - (ORI ,dest ,dest ,(bottom-16-bits value)))))) - (define (fp-copy from to) (if (= to from) (LAP) @@ -328,10 +305,15 @@ MIT in each case. |# (cond ((null? entries*) ;; If no entries of the given type, use any entry that is ;; available. - (if (null? entries) - (values false false) - (values (cdaar entries) (cadar entries)))) - ((eq? type (caaar entries*)) + (let loop ((entries entries)) + (cond ((null? entries) + (values false false)) + ((pair? (caar entries)) + (values (cdaar entries) (cadar entries))) + (else + (loop (cdr entries)))))) + ((and (pair? (caar entries*)) + (eq? type (caaar entries*))) (values (cdaar entries*) (cadar entries*))) (else (loop (cdr entries*))))))) @@ -341,47 +323,105 @@ MIT in each case. |# (set-machine-register-label *register-map* alias (cons type label))) unspecific) +(define (immediate->register immediate) + (let ((register (get-immediate-alias immediate))) + (if register + (values (LAP) register) + (let ((temporary (standard-temporary!))) + (set! *register-map* + (set-machine-register-label *register-map* + temporary + immediate)) + (values (%load-immediate temporary immediate) temporary))))) + +(define (get-immediate-alias immediate) + (let loop ((entries (register-map-labels *register-map* 'GENERAL))) + (cond ((null? entries) + false) + ((eqv? (caar entries) immediate) + (cadar entries)) + (else + (loop (cdr entries)))))) + +(define (load-immediate target immediate record?) + (let ((registers (get-immediate-aliases immediate))) + (if (memv target registers) + (LAP) + (begin + (if record? + (set! *register-map* + (set-machine-register-label *register-map* + target + immediate))) + (if (not (null? registers)) + (LAP (ADD ,target 0 ,(car registers))) + (%load-immediate target immediate)))))) + +(define (get-immediate-aliases immediate) + (let loop ((entries (register-map-labels *register-map* 'GENERAL))) + (cond ((null? entries) + '()) + ((eqv? (caar entries) immediate) + (append (cdar entries) (loop (cdr entries)))) + (else + (loop (cdr entries)))))) + +(define (%load-immediate target immediate) + (cond ((fits-in-16-bits-signed? immediate) + (LAP (ADDIU ,target 0 ,immediate))) + ((fits-in-16-bits-unsigned? immediate) + (LAP (ORI ,target 0 ,immediate))) + ((top-16-bits-only? immediate) + (LAP (LUI ,target ,(top-16-bits immediate)))) + (else + (LAP (LUI ,target ,(top-16-bits immediate)) + (ORI ,target ,target ,(bottom-16-bits immediate)))))) + +(define (add-immediate immediate source target) + (if (fits-in-16-bits-signed? immediate) + (LAP (ADDIU ,target ,source ,immediate)) + (with-values (lambda () (immediate->register immediate)) + (lambda (prefix alias) + (LAP ,@prefix + (ADDU ,target ,source ,alias)))))) + ;;;; Comparisons -(define (compare-immediate comp i r2) - ; Branch if immediate r2 +(define (compare-immediate comp immediate source) + ; Branch if immediate source (let ((cc (invert-condition-noncommutative comp))) ;; This machine does register immediate; you can ;; now think of cc in this way - (if (zero? i) + (if (zero? immediate) (begin (branch-generator! cc - `(BEQ 0 ,r2) `(BLTZ ,r2) `(BGTZ ,r2) - `(BNE 0 ,r2) `(BGEZ ,r2) `(BLEZ ,r2)) + `(BEQ 0 ,source) `(BLTZ ,source) `(BGTZ ,source) + `(BNE 0 ,source) `(BGEZ ,source) `(BLEZ ,source)) (LAP)) - (let ((temp (standard-temporary!))) - (if (fits-in-16-bits-signed? - (if (or (eq? '> cc) (eq? '<= cc)) - (+ i 1) - i)) - (begin - (branch-generator! cc - `(BEQ ,temp ,r2) `(BNE 0 ,temp) `(BEQ 0 ,temp) - `(BNE ,temp ,r2) `(BEQ 0 ,temp) `(BNE 0 ,temp)) - (case cc - ((= <>) (LAP (ADDI ,temp 0 ,i))) - ((< >=) (LAP (SLTI ,temp ,r2 ,i))) - ((> <=) (LAP (SLTI ,temp ,r2 ,(+ i 1)))))) - (LAP ,@(load-immediate i temp) - ,@(compare comp temp r2))))))) + (with-values (lambda () (immediate->register immediate)) + (lambda (prefix alias) + (LAP ,@prefix + ,@(compare comp alias source))))))) (define (compare condition r1 r2) ; Branch if r1 r2 - (let ((temp (if (memq condition '(< > <= >=)) - (standard-temporary!) - '()))) - (branch-generator! condition - `(BEQ ,r1 ,r2) `(BNE ,temp 0) `(BNE ,temp 0) - `(BNE ,r1 ,r2) `(BEQ ,temp 0) `(BEQ ,temp 0)) - (case condition - ((= <>) (LAP)) - ((< >=) (LAP (SLT ,temp ,r1 ,r2))) - ((> <=) (LAP (SLT ,temp ,r2 ,r1)))))) + (if (= r1 r2) + (let ((branch + (lambda (label) (LAP (BGEZ 0 (@PCR ,label)) (NOP)))) + (dont-branch + (lambda (label) label (LAP)))) + (if (memq condition '(< > <>)) + (set-current-branches! dont-branch branch) + (set-current-branches! branch dont-branch)) + (LAP)) + (let ((temp (and (memq condition '(< > <= >=)) (standard-temporary!)))) + (branch-generator! condition + `(BEQ ,r1 ,r2) `(BNE ,temp 0) `(BNE ,temp 0) + `(BNE ,r1 ,r2) `(BEQ ,temp 0) `(BEQ ,temp 0)) + (case condition + ((= <>) (LAP)) + ((< >=) (LAP (SLT ,temp ,r1 ,r2))) + ((> <=) (LAP (SLT ,temp ,r2 ,r1))))))) (define (branch-generator! cc = < > <> >= <=) (let ((forward @@ -422,22 +462,18 @@ MIT in each case. |# ;;;; Miscellaneous -(define-integrable (object->datum src tgt) +(define-integrable (object->type source target) + ; Type extraction + (LAP (SRL ,target ,source ,(- 32 scheme-type-width)))) + +(define-integrable (object->datum source target) ; Zero out the type field; don't put in the quad bits - (LAP (AND ,tgt ,regnum:address-mask ,src))) + (LAP (AND ,target ,source ,regnum:address-mask))) -(define-integrable (object->address reg) +(define (object->address source target) ; Drop in the segment bits - (LAP (AND ,reg ,regnum:address-mask ,reg) - ,@(put-address-bits reg))) - -(define-integrable (put-address-bits reg) - ; Drop in the segment bits, assuming they are currently 0 - (LAP (OR ,reg ,reg ,regnum:quad-bits))) - -(define-integrable (object->type src tgt) - ; Type extraction - (LAP (SRL ,tgt ,src ,(- 32 scheme-type-width)))) + (LAP (AND ,target ,source ,regnum:address-mask) + (OR ,target ,target ,regnum:quad-bits))) (define (standard-unary-conversion source target conversion) ;; `source' is any register, `target' a pseudo register. @@ -474,11 +510,11 @@ MIT in each case. |# (and (zero? (object-type object)) (zero? (object-datum object)) 0))) - ((CONS-POINTER) - (and (let ((type (rtl:cons-pointer-type expression))) + ((CONS-NON-POINTER) + (and (let ((type (rtl:cons-non-pointer-type expression))) (and (rtl:machine-constant? type) (zero? (rtl:machine-constant-value type)))) - (let ((datum (rtl:cons-pointer-datum expression))) + (let ((datum (rtl:cons-non-pointer-datum expression))) (and (rtl:machine-constant? datum) (zero? (rtl:machine-constant-value datum)))) 0)) diff --git a/v7/src/compiler/machines/mips/machin.scm b/v7/src/compiler/machines/mips/machin.scm index 0259cf505..13273b8fe 100644 --- a/v7/src/compiler/machines/mips/machin.scm +++ b/v7/src/compiler/machines/mips/machin.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/machin.scm,v 1.4 1991/08/14 20:55:14 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/machin.scm,v 1.5 1991/10/25 00:13:12 cph Exp $ $MC68020-Header: machin.scm,v 4.22 90/05/03 15:17:20 GMT jinx Exp $ Copyright (c) 1988-91 Massachusetts Institute of Technology @@ -39,17 +39,16 @@ MIT in each case. |# ;;;; Architecture Parameters +(define use-pre/post-increment? true) (define endianness 'LITTLE) (define-integrable addressing-granularity 8) (define-integrable scheme-object-width 32) (define-integrable scheme-type-width 6) ;or 8 +(define-integrable type-scale-factor (expt 2 (- 8 scheme-type-width))) (define-integrable scheme-datum-width (- scheme-object-width scheme-type-width)) -(define-integrable type-scale-factor - (expt 2 (- 8 scheme-type-width))) - (define-integrable flonum-size 2) (define-integrable float-alignment 64) @@ -372,13 +371,14 @@ MIT in each case. |# VARIABLE-CACHE OFFSET-ADDRESS) 3) - ((CONS-POINTER) - (and (rtl:machine-constant? (rtl:cons-pointer-type expression)) - (rtl:machine-constant? (rtl:cons-pointer-datum expression)) + ((CONS-NON-POINTER) + (and (rtl:machine-constant? (rtl:cons-non-pointer-type expression)) + (rtl:machine-constant? (rtl:cons-non-pointer-datum expression)) (if-synthesized-constant - (rtl:machine-constant-value (rtl:cons-pointer-type expression)) (rtl:machine-constant-value - (rtl:cons-pointer-datum expression))))) + (rtl:cons-non-pointer-type expression)) + (rtl:machine-constant-value + (rtl:cons-non-pointer-datum expression))))) (else false))))) (define compiler:open-code-floating-point-arithmetic? diff --git a/v7/src/compiler/machines/mips/make.scm-big b/v7/src/compiler/machines/mips/make.scm-big index 16a2d8703..dd15f8fdd 100644 --- a/v7/src/compiler/machines/mips/make.scm-big +++ b/v7/src/compiler/machines/mips/make.scm-big @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/make.scm-big,v 4.87 1991/07/25 02:40:47 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/make.scm-big,v 4.88 1991/10/25 00:13:15 cph Exp $ Copyright (c) 1988-91 Massachusetts Institute of Technology @@ -36,10 +36,5 @@ MIT in each case. |# (declare (usual-integrations)) -(package/system-loader "comp" '() 'QUERY) -(for-each (lambda (name) - ((package/reference (find-package name) 'INITIALIZE-PACKAGE!))) - '((COMPILER MACROS) - (COMPILER DECLARATIONS))) -(set! (access endianness (->environment '(COMPILER))) 'BIG) -(add-system! (make-system "Liar (MIPS)" 4 87 '())) \ No newline at end of file +((load "base/make") "MIPS") +(environment-assign! (->environment '(COMPILER)) 'ENDIANNESS 'BIG) \ No newline at end of file diff --git a/v7/src/compiler/machines/mips/make.scm-little b/v7/src/compiler/machines/mips/make.scm-little index 8a128508c..fe5032ee1 100644 --- a/v7/src/compiler/machines/mips/make.scm-little +++ b/v7/src/compiler/machines/mips/make.scm-little @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/make.scm-little,v 4.87 1991/07/25 02:40:58 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/make.scm-little,v 4.88 1991/10/25 00:13:19 cph Exp $ Copyright (c) 1988-91 Massachusetts Institute of Technology @@ -36,10 +36,5 @@ MIT in each case. |# (declare (usual-integrations)) -(package/system-loader "comp" '() 'QUERY) -(for-each (lambda (name) - ((package/reference (find-package name) 'INITIALIZE-PACKAGE!))) - '((COMPILER MACROS) - (COMPILER DECLARATIONS))) -(set! (access endianness (->environment '(COMPILER))) 'LITTLE) -(add-system! (make-system "Liar (MIPS)" 4 87 '())) \ No newline at end of file +((load "base/make") "MIPS") +(environment-assign! (->environment '(COMPILER)) 'ENDIANNESS 'LITTLE) \ No newline at end of file diff --git a/v7/src/compiler/machines/mips/rules1.scm b/v7/src/compiler/machines/mips/rules1.scm index f575de4f8..ff7fc3a6a 100644 --- a/v7/src/compiler/machines/mips/rules1.scm +++ b/v7/src/compiler/machines/mips/rules1.scm @@ -1,7 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/rules1.scm,v 1.4 1991/07/25 02:46:10 cph Exp $ -$MC68020-Header: rules1.scm,v 4.33 90/05/03 15:17:28 GMT jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/rules1.scm,v 1.5 1991/10/25 00:13:22 cph Exp $ Copyright (c) 1989-91 Massachusetts Institute of Technology @@ -52,7 +51,6 @@ MIT in each case. |# (LAP)) (define-rule statement - ;; tag the contents of a register (ASSIGN (REGISTER (? target)) (CONS-POINTER (REGISTER (? type)) (REGISTER (? datum)))) (let* ((type (standard-move-to-temporary! type)) @@ -62,30 +60,40 @@ MIT in each case. |# (OR ,target ,type ,target)))) (define-rule statement - ;; tag the contents of a register + (ASSIGN (REGISTER (? target)) + (CONS-NON-POINTER (REGISTER (? type)) (REGISTER (? datum)))) + (let* ((type (standard-move-to-temporary! type)) + (target (standard-move-to-target! datum target))) + (LAP (SLL ,type ,type ,(- 32 scheme-type-width)) + (OR ,target ,type ,target)))) + +(define-rule statement (ASSIGN (REGISTER (? target)) (CONS-POINTER (MACHINE-CONSTANT (? type)) (REGISTER (? source)))) - (let ((target (standard-move-to-target! source target))) - (deposit-type type target))) + (standard-unary-conversion source target + (lambda (source target) + (deposit-type-address type source target)))) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (CONS-NON-POINTER (MACHINE-CONSTANT (? type)) (REGISTER (? source)))) + (standard-unary-conversion source target + (lambda (source target) + (deposit-type-datum type source target)))) (define-rule statement - ;; extract the type part of a register's contents (ASSIGN (REGISTER (? target)) (OBJECT->TYPE (REGISTER (? source)))) (standard-unary-conversion source target object->type)) (define-rule statement - ;; extract the datum part of a register's contents (ASSIGN (REGISTER (? target)) (OBJECT->DATUM (REGISTER (? source)))) (standard-unary-conversion source target object->datum)) (define-rule statement - ;; convert the contents of a register to an address (ASSIGN (REGISTER (? target)) (OBJECT->ADDRESS (REGISTER (? source)))) - (let ((target (standard-move-to-target! source target))) - (object->address target))) + (standard-unary-conversion source target object->address)) (define-rule statement - ;; add a distance (in longwords) to a register's contents (ASSIGN (REGISTER (? target)) (OFFSET-ADDRESS (REGISTER (? source)) (? offset))) (standard-unary-conversion source target @@ -93,71 +101,62 @@ MIT in each case. |# (add-immediate (* 4 offset) source target)))) (define-rule statement - ;; add a distance (in bytes) to a register's contents (ASSIGN (REGISTER (? target)) (BYTE-OFFSET-ADDRESS (REGISTER (? source)) (? offset))) (standard-unary-conversion source target (lambda (source target) (add-immediate offset source target)))) - -(define-rule statement - ;; read an object from memory - (ASSIGN (REGISTER (? target)) (OFFSET (REGISTER (? address)) (? offset))) - (standard-unary-conversion address target - (lambda (address target) - (LAP (LW ,target (OFFSET ,(* 4 offset) ,address)) - (NOP))))) - -(define-rule statement - ;; pop an object off the stack - (ASSIGN (REGISTER (? target)) (POST-INCREMENT (REGISTER 3) 1)) - (LAP (LW ,(standard-target! target) (OFFSET 0 ,regnum:stack-pointer)) - (ADDI ,regnum:stack-pointer ,regnum:stack-pointer 4))) ;;;; Loading of Constants (define-rule statement ;; load a machine constant (ASSIGN (REGISTER (? target)) (MACHINE-CONSTANT (? source))) - (load-immediate source (standard-target! target))) + (load-immediate (standard-target! target) source #T)) (define-rule statement ;; load a Scheme constant (ASSIGN (REGISTER (? target)) (CONSTANT (? source))) - (load-constant source (standard-target! target) #T)) + (load-constant (standard-target! target) source #T #T)) (define-rule statement ;; load the type part of a Scheme constant (ASSIGN (REGISTER (? target)) (OBJECT->TYPE (CONSTANT (? constant)))) - (load-non-pointer 0 (object-type constant) (standard-target! target))) + (load-immediate (standard-target! target) + (make-non-pointer-literal 0 (object-type constant)) + #T)) (define-rule statement ;; load the datum part of a Scheme constant (ASSIGN (REGISTER (? target)) (OBJECT->DATUM (CONSTANT (? constant)))) (QUALIFIER (non-pointer-object? constant)) - (load-non-pointer 0 - (careful-object-datum constant) - (standard-target! target))) + (load-immediate (standard-target! target) + (make-non-pointer-literal 0 (careful-object-datum constant)) + #T)) (define-rule statement ;; load a synthesized constant (ASSIGN (REGISTER (? target)) - (CONS-POINTER (MACHINE-CONSTANT (? type)) - (MACHINE-CONSTANT (? datum)))) - (load-non-pointer type datum (standard-target! target))) - + (CONS-NON-POINTER (MACHINE-CONSTANT (? type)) + (MACHINE-CONSTANT (? datum)))) + (load-immediate (standard-target! target) + (make-non-pointer-literal type datum) + #T)) + (define-rule statement ;; load the address of a variable reference cache (ASSIGN (REGISTER (? target)) (VARIABLE-CACHE (? name))) (load-pc-relative (standard-target! target) - 'CONSTANT (free-reference-label name) + 'CONSTANT + (free-reference-label name) true)) (define-rule statement ;; load the address of an assignment cache (ASSIGN (REGISTER (? target)) (ASSIGNMENT-CACHE (? name))) (load-pc-relative (standard-target! target) - 'CONSTANT (free-assignment-label name) + 'CONSTANT + (free-assignment-label name) true)) (define-rule statement @@ -190,11 +189,24 @@ MIT in each case. |# ;; Loading the address into a temporary makes it more useful, ;; because it can be reused later. (LAP ,@(load-pc-relative-address temporary 'CODE label) - (AND ,target ,temporary ,regnum:address-mask) - ,@(put-type type target)))) + ,@(deposit-type-address type temporary target)))) -;;;; Transfers to Memory - +;;;; Transfers from memory + +(define-rule statement + (ASSIGN (REGISTER (? target)) (OFFSET (REGISTER (? address)) (? offset))) + (standard-unary-conversion address target + (lambda (address target) + (LAP (LW ,target (OFFSET ,(* 4 offset) ,address)) + (NOP))))) + +(define-rule statement + (ASSIGN (REGISTER (? target)) (POST-INCREMENT (REGISTER 3) 1)) + (LAP (LW ,(standard-target! target) (OFFSET 0 ,regnum:stack-pointer)) + (ADDI ,regnum:stack-pointer ,regnum:stack-pointer 4))) + +;;;; Transfers to memory + (define-rule statement ;; store an object in memory (ASSIGN (OFFSET (REGISTER (? address)) (? offset)) diff --git a/v7/src/compiler/machines/mips/rules2.scm b/v7/src/compiler/machines/mips/rules2.scm index 05b3e83fe..bf300c25c 100644 --- a/v7/src/compiler/machines/mips/rules2.scm +++ b/v7/src/compiler/machines/mips/rules2.scm @@ -1,9 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/rules2.scm,v 1.1 1990/05/07 04:16:16 jinx Rel $ -$MC68020-Header: rules2.scm,v 4.12 90/01/18 22:44:04 GMT cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/rules2.scm,v 1.2 1991/10/25 00:13:25 cph Exp $ -Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology +Copyright (c) 1988-91 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -57,21 +56,23 @@ MIT in each case. |# (if (non-pointer-object? constant) (compare-immediate '= (non-pointer->literal constant) source) (let ((temp (standard-temporary!))) - (LAP ,@(load-constant constant temp #T) + (LAP ,@(load-pc-relative temp + 'CONSTANT (constant->label constant) + #T) ,@(compare '= temp source)))))) (define-rule predicate ;; test for register EQ? to synthesized constant - (EQ-TEST (CONS-POINTER (MACHINE-CONSTANT (? type)) - (MACHINE-CONSTANT (? datum))) + (EQ-TEST (CONS-NON-POINTER (MACHINE-CONSTANT (? type)) + (MACHINE-CONSTANT (? datum))) (REGISTER (? register))) (eq-test/synthesized-constant*register type datum register)) (define-rule predicate ;; test for register EQ? to synthesized constant (EQ-TEST (REGISTER (? register)) - (CONS-POINTER (MACHINE-CONSTANT (? type)) - (MACHINE-CONSTANT (? datum)))) + (CONS-NON-POINTER (MACHINE-CONSTANT (? type)) + (MACHINE-CONSTANT (? datum)))) (eq-test/synthesized-constant*register type datum register)) (define (eq-test/synthesized-constant*register type datum source) diff --git a/v7/src/compiler/machines/mips/rules3.scm b/v7/src/compiler/machines/mips/rules3.scm index d61b72d84..e0d421c04 100644 --- a/v7/src/compiler/machines/mips/rules3.scm +++ b/v7/src/compiler/machines/mips/rules3.scm @@ -1,7 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/rules3.scm,v 1.9 1991/08/23 09:15:03 cph Exp $ -$MC68020-Header: /scheme/compiler/bobcat/RCS/rules3.scm,v 4.30 1991/05/07 13:45:31 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/rules3.scm,v 1.10 1991/10/25 00:13:29 cph Exp $ Copyright (c) 1988-91 Massachusetts Institute of Technology @@ -48,7 +47,7 @@ MIT in each case. |# (LAP ,@(clear-map!) (LW ,temp (OFFSET 0 ,regnum:stack-pointer)) (ADDI ,regnum:stack-pointer ,regnum:stack-pointer 4) - ,@(object->address temp) + ,@(object->address temp temp) (JR ,temp) (NOP)))) ; DELAY SLOT @@ -56,7 +55,7 @@ MIT in each case. |# (INVOCATION:APPLY (? frame-size) (? continuation)) continuation ;ignore (LAP ,@(clear-map!) - ,@(load-immediate frame-size regnum:third-arg) + ,@(load-immediate regnum:third-arg frame-size #F) (LW ,regnum:second-arg (OFFSET 0 ,regnum:stack-pointer)) (ADDI ,regnum:stack-pointer ,regnum:stack-pointer 4) ,@(invoke-interface code:compiler-apply))) @@ -83,7 +82,7 @@ MIT in each case. |# (LAP ,@clear-second-arg ,@load-second-arg ,@(clear-map!) - ,@(load-immediate number-pushed regnum:third-arg) + ,@(load-immediate regnum:third-arg number-pushed #F) ,@(invoke-interface code:compiler-lexpr-apply)))) (define-rule statement @@ -93,8 +92,8 @@ MIT in each case. |# (LAP ,@(clear-map!) (LW ,regnum:second-arg (OFFSET 0 ,regnum:stack-pointer)) (ADDI ,regnum:stack-pointer ,regnum:stack-pointer 4) - ,@(load-immediate number-pushed regnum:third-arg) - ,@(object->address regnum:second-arg) + ,@(object->address regnum:second-arg regnum:second-arg) + ,@(load-immediate regnum:third-arg number-pushed #F) ,@(invoke-interface code:compiler-lexpr-apply))) (define-rule statement @@ -122,7 +121,7 @@ MIT in each case. |# (LAP ,@clear-third-arg ,@load-third-arg ,@(load-interface-args! extension false false false) - ,@(load-immediate frame-size regnum:fourth-arg) + ,@(load-immediate regnum:fourth-arg frame-size #F) ,@(invoke-interface code:compiler-cache-reference-apply)))) (define-rule statement @@ -132,8 +131,8 @@ MIT in each case. |# (? name)) continuation ;ignore (LAP ,@(load-interface-args! environment false false false) - ,(load-constant name regnum:third-arg) - ,(load-immediate frame-size regnum:fourth-arg) + ,@(load-constant regnum:third-arg name #F #F) + ,@(load-immediate regnum:fourth-arg frame-size #F) ,@(invoke-interface code:compiler-lookup-apply))) (define-rule statement @@ -141,7 +140,7 @@ MIT in each case. |# continuation ;ignore (if (eq? primitive compiled-error-procedure) (LAP ,@(clear-map!) - ,@(load-immediate frame-size regnum:second-arg) + ,@(load-immediate regnum:second-arg frame-size #F) ,@(invoke-interface code:compiler-error)) (let* ((clear-second-arg (clear-registers! regnum:second-arg)) (load-second-arg @@ -156,16 +155,16 @@ MIT in each case. |# (cond ((not (negative? arity)) (invoke-interface code:compiler-primitive-apply)) ((= arity -1) - (LAP ,@(load-immediate (-1+ frame-size) - regnum:assembler-temp) - + (LAP ,@(load-immediate regnum:assembler-temp + (-1+ frame-size) + #F) (SW ,regnum:assembler-temp ,reg:lexpr-primitive-arity) ,@(invoke-interface code:compiler-primitive-lexpr-apply))) (else ;; Unknown primitive arity. Go through apply. - (LAP ,@(load-immediate frame-size regnum:third-arg) + (LAP ,@(load-immediate regnum:third-arg frame-size #F) ,@(invoke-interface code:compiler-apply))))))))) (let-syntax @@ -330,7 +329,7 @@ MIT in each case. |# (ADDI ,destination ,destination -8) ,@(loop (- n 2)))))) (let ((label (generate-label))) - (LAP ,@(load-immediate frame-size temp2) + (LAP ,@(load-immediate temp2 frame-size #F) (LABEL ,label) (LW ,temp1 (OFFSET -4 ,from)) (ADDI ,from ,from -4) @@ -476,9 +475,6 @@ MIT in each case. |# ;; Magic for compiled entries. -(define-integrable (address->entry register) - (deposit-type (ucode-type compiled-entry) register)) - (define-rule statement (CLOSURE-HEADER (? internal-label) (? nentries) (? entry)) entry ; ignored -- non-RISCs only @@ -493,10 +489,16 @@ MIT in each case. |# ,@(make-external-label (internal-procedure-code-word rtl-proc) external-label) - ; Code below here corresponds to code and count in cmpint2.h - ,@(address->entry regnum:linkage) - (SW ,regnum:linkage (OFFSET -4 ,regnum:stack-pointer)) + ;; Code below here corresponds to code and count in cmpint2.h + ,@(fluid-let ((*register-map* *register-map*)) + ;; Don't cache type constant here, because it won't be + ;; in the register if the closure is entered from the + ;; internal label. + (deposit-type-address (ucode-type compiled-entry) + regnum:linkage + regnum:linkage)) (ADDI ,regnum:stack-pointer ,regnum:stack-pointer -4) + (SW ,regnum:linkage (OFFSET 0 ,regnum:stack-pointer)) (LABEL ,internal-label) ,@(interrupt-check gc-label))))) @@ -525,7 +527,7 @@ MIT in each case. |# (LI ,regnum:first-arg (- ,(rtl-procedure/external-label (label->object label)) ,return-label)) - ,@(load-immediate (+ size closure-entry-size) 1) + ,@(load-immediate 1 (+ size closure-entry-size) #F) (LUI 25 ,(quotient gc-offset-word #x10000)) (ADDI ,dest ,regnum:scheme-to-interface -88) (JALR 31 ,dest) @@ -548,7 +550,10 @@ MIT in each case. |# (let ((dest (standard-target! target)) (temp (standard-temporary!))) (LAP (ADD ,dest 0 ,regnum:free) - ,@(load-non-pointer (ucode-type manifest-vector) size temp) + ,@(load-immediate + temp + (make-non-pointer-literal (ucode-type manifest-vector) size) + #T) (SW ,temp (OFFSET 0 ,regnum:free)) (ADDI ,regnum:free ,regnum:free ,(* 4 (+ size 1)))))) ((1) @@ -590,10 +595,20 @@ MIT in each case. |# (+ (* closure-entry-size 4) offset))))))) (LAP - ,@(load-non-pointer (ucode-type manifest-closure) total-size temp) - (SW ,temp (OFFSET 0 ,regnum:free)) - ,@(load-immediate (build-gc-offset-word 0 nentries) temp) - (SW ,temp (OFFSET 4 ,regnum:free)) + ,@(with-values + (lambda () + (immediate->register + (make-non-pointer-literal (ucode-type manifest-closure) + total-size))) + (lambda (prefix register) + (LAP ,@prefix + (SW ,register (OFFSET 0 ,regnum:free))))) + ,@(with-values + (lambda () + (immediate->register (build-gc-offset-word 0 nentries))) + (lambda (prefix register) + (LAP ,@prefix + (SW ,register (OFFSET 4 ,regnum:free))))) (ADDI ,regnum:free ,regnum:free 8) (ADDI ,dest ,regnum:free 4) ,@(generate-entries entries 12) @@ -626,7 +641,7 @@ MIT in each case. |# ;; (arg1 is return address, supplied by interface) ,@i2 ,@i3 - ,@(load-immediate n-sections regnum:first-arg) + ,@(load-immediate regnum:first-arg n-sections #F) (SW ,regnum:first-arg (OFFSET 16 ,regnum:C-stack-pointer)) ,@(link-to-interface code:compiler-link) ,@(make-external-label (continuation-code-word false) @@ -643,12 +658,13 @@ MIT in each case. |# (lambda () (LAP ,@(load-pc-relative regnum:third-arg 'CODE code-block-label false) (LW ,regnum:fourth-arg ,reg:environment) - ,@(object->address regnum:third-arg) - ,@(add-immediate environment-offset regnum:third-arg + ,@(object->address regnum:third-arg regnum:third-arg) + ,@(add-immediate environment-offset + regnum:third-arg regnum:second-arg) (SW ,regnum:fourth-arg (OFFSET 0 ,regnum:second-arg)) ,@(add-immediate free-ref-offset regnum:third-arg regnum:fourth-arg) - ,@(load-immediate n-sections regnum:first-arg) + ,@(load-immediate regnum:first-arg n-sections #F) (SW ,regnum:first-arg (OFFSET 16 ,regnum:C-stack-pointer)) ,@(link-to-interface code:compiler-link) ,@(make-external-label (continuation-code-word false) diff --git a/v7/src/compiler/machines/mips/rules4.scm b/v7/src/compiler/machines/mips/rules4.scm index aeb3a0705..0407a5025 100644 --- a/v7/src/compiler/machines/mips/rules4.scm +++ b/v7/src/compiler/machines/mips/rules4.scm @@ -1,9 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/rules4.scm,v 1.1 1990/05/07 04:16:57 jinx Rel $ -$MC68020-Header: rules4.scm,v 4.11 90/01/20 07:26:13 GMT cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/rules4.scm,v 1.2 1991/10/25 00:13:33 cph Exp $ -Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology +Copyright (c) 1988-91 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -61,7 +60,7 @@ MIT in each case. |# (define (lookup-call code environment name) (LAP ,@(load-interface-args! false environment false false) - ,@(load-constant name regnum:third-arg) + ,@(load-constant regnum:third-arg name #F #F) ,@(link-to-interface code))) (define-rule statement @@ -78,7 +77,7 @@ MIT in each case. |# (define (assignment-call code environment name value) (LAP ,@(load-interface-args! false environment false value) - ,@(load-constant name regnum:third-arg) + ,@(load-constant regnum:third-arg name #F #F) ,@(link-to-interface code))) (define-rule statement diff --git a/v7/src/compiler/machines/mips/rulfix.scm b/v7/src/compiler/machines/mips/rulfix.scm index 9f029c83f..7dafb9714 100644 --- a/v7/src/compiler/machines/mips/rulfix.scm +++ b/v7/src/compiler/machines/mips/rulfix.scm @@ -1,7 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/rulfix.scm,v 1.3 1991/08/18 14:47:31 jinx Exp $ -$MC68020-Header: rules1.scm,v 4.32 90/01/18 22:43:54 GMT cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/rulfix.scm,v 1.4 1991/10/25 00:13:36 cph Exp $ Copyright (c) 1989-91 Massachusetts Institute of Technology @@ -47,7 +46,7 @@ MIT in each case. |# (define-rule statement ;; load a fixnum constant as a "fixnum integer" (ASSIGN (REGISTER (? target)) (OBJECT->FIXNUM (CONSTANT (? constant)))) - (load-fixnum-constant constant (standard-target! target))) + (load-immediate (standard-target! target) (* constant fixnum-1) #T)) (define-rule statement ;; convert a memory address to a "fixnum integer" @@ -128,15 +127,12 @@ MIT in each case. |# (define-integrable (fixnum->object src tgt) ; Move right by type code width and put on fixnum type code (LAP (SRL ,tgt ,src ,scheme-type-width) - ,@(put-type (ucode-type fixnum) tgt))) + ,@(deposit-type-datum (ucode-type fixnum) tgt tgt))) (define (fixnum->address src tgt) ; Move right by type code width and put in address bits (LAP (SRL ,tgt ,src ,scheme-type-width) - ,@(put-address-bits tgt))) - -(define (load-fixnum-constant constant target) - (load-immediate (* constant fixnum-1) target)) + (OR ,tgt ,tgt ,regnum:quad-bits))) (define-integrable fixnum-1 (expt 2 scheme-type-width)) @@ -198,14 +194,16 @@ MIT in each case. |# (else (let ((bcc (if (> constant 0) 'BLEZ 'BGEZ))) (let ((prefix - (lambda (label) - (if (fits-in-16-bits-signed? constant) + (if (fits-in-16-bits-signed? constant) + (lambda (label) (LAP (,bcc ,src (@PCR ,label)) - (ADDIU ,tgt ,src ,constant)) - (let ((temp (if (= src tgt) regnum:first-arg tgt))) - (LAP ,@(load-immediate constant temp) - (,bcc ,src (@PCR ,label)) - (ADDU ,tgt ,src ,temp))))))) + (ADDIU ,tgt ,src ,constant))) + (with-values (lambda () (immediate->register constant)) + (lambda (prefix alias) + (lambda (label) + (LAP ,@prefix + (,bcc ,src (@PCR ,label)) + (ADDU ,tgt ,src ,alias)))))))) (if (> constant 0) (set-current-branches! (lambda (if-overflow) @@ -443,9 +441,10 @@ MIT in each case. |# (do-left-shift-overflow tgt src power-of-two) (LAP (SLL ,tgt ,src ,power-of-two))))) (else - (let ((temp (standard-temporary!))) - (LAP ,@(load-fixnum-constant constant temp) - ,@(do-multiply tgt src temp overflow?))))))) + (with-values (lambda () (immediate->register (* constant fixnum-1))) + (lambda (prefix alias) + (LAP ,@prefix + ,@(do-multiply tgt src alias overflow?)))))))) (define (do-left-shift-overflow tgt src power-of-two) (if (= tgt src) @@ -477,11 +476,12 @@ MIT in each case. |# fixnum-methods/2-args/constant*register (lambda (tgt constant src overflow?) (guarantee-signed-fixnum constant) - (let ((temp (standard-temporary!))) - (LAP ,@(load-fixnum-constant constant temp) - ,@(if overflow? - (do-overflow-subtraction tgt temp src) - (LAP (SUB ,tgt ,temp ,src))))))) + (with-values (lambda () (immediate->register (* constant fixnum-1))) + (lambda (prefix alias) + (LAP ,@prefix + ,@(if overflow? + (do-overflow-subtraction tgt alias src) + (LAP (SUB ,tgt ,alias ,src)))))))) ;;;; Predicates diff --git a/v7/src/compiler/machines/mips/rulflo.scm b/v7/src/compiler/machines/mips/rulflo.scm index 11d36c056..a275bf585 100644 --- a/v7/src/compiler/machines/mips/rulflo.scm +++ b/v7/src/compiler/machines/mips/rulflo.scm @@ -1,7 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/rulflo.scm,v 1.5 1991/07/25 02:46:19 cph Exp $ -$MC68020-Header: rules1.scm,v 4.33 90/05/03 15:17:28 GMT jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/rulflo.scm,v 1.6 1991/10/25 00:13:40 cph Exp $ Copyright (c) 1989-91 Massachusetts Institute of Technology @@ -47,38 +46,33 @@ MIT in each case. |# (define (flonum-temporary!) (float-register->fpr (allocate-temporary-register! 'FLOAT))) -(define (store-flonum offset base source) - (fp-store-doubleword offset base - (fpr->float-register source))) - -(define (load-flonum offset base target) - (fp-load-doubleword offset base - (fpr->float-register target) - #t)) ; Output NOP - (define-rule statement ;; convert a floating-point number to a flonum object (ASSIGN (REGISTER (? target)) (FLOAT->OBJECT (REGISTER (? source)))) - (let ((source (flonum-source! source))) + (let ((source (fpr->float-register (flonum-source! source)))) (let ((target (standard-target! target))) (LAP ; (SW 0 (OFFSET 0 ,regnum:free)) ; make heap parsable forwards (ORI ,regnum:free ,regnum:free #b100) ; Align to odd quad byte - (ADD ,target 0 ,regnum:free) ; Result is this address - ,@(deposit-type (ucode-type flonum) target) - ,@(load-non-pointer - (ucode-type manifest-nm-vector) 2 regnum:assembler-temp) - (SW ,regnum:assembler-temp (OFFSET 0 ,regnum:free)) - ,@(store-flonum 4 regnum:free source) + ,@(deposit-type-address (ucode-type flonum) regnum:free target) + ,@(with-values + (lambda () + (immediate->register + (make-non-pointer-literal (ucode-type manifest-nm-vector) 2))) + (lambda (prefix alias) + (LAP ,@prefix + (SW ,alias (OFFSET 0 ,regnum:free))))) + ,@(fp-store-doubleword 4 regnum:free source) (ADDI ,regnum:free ,regnum:free 12))))) (define-rule statement - ;; convert a flonum object address to a floating-point number - (ASSIGN (REGISTER (? target)) (@ADDRESS->FLOAT (REGISTER (? source)))) - (let ((source (standard-source! source))) - (let ((target (flonum-target! target))) - (load-flonum 4 source target)))) + ;; convert a flonum object to a floating-point number + (ASSIGN (REGISTER (? target)) (OBJECT->FLOAT (REGISTER (? source)))) + (let ((source (standard-move-to-temporary! source))) + (let ((target (fpr->float-register (flonum-target! target)))) + (LAP ,@(object->address source source) + ,@(fp-load-doubleword 4 source target #T))))) ;;;; Flonum Arithmetic diff --git a/v7/src/compiler/machines/mips/rulrew.scm b/v7/src/compiler/machines/mips/rulrew.scm index 2354156a5..f9efb3227 100644 --- a/v7/src/compiler/machines/mips/rulrew.scm +++ b/v7/src/compiler/machines/mips/rulrew.scm @@ -1,9 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/rulrew.scm,v 1.1 1990/05/07 04:18:00 jinx Rel $ -$MC68020-Header: rulrew.scm,v 1.1 90/01/18 22:48:52 GMT cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/rulrew.scm,v 1.2 1991/10/25 00:13:43 cph Exp $ -Copyright (c) 1990 Massachusetts Institute of Technology +Copyright (c) 1990-91 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -40,13 +39,11 @@ MIT in each case. |# ;;;; Synthesized Data (define-rule rewriting - (CONS-POINTER (REGISTER (? type register-known-value)) - (REGISTER (? datum register-known-value))) + (CONS-NON-POINTER (REGISTER (? type register-known-value)) + (REGISTER (? datum register-known-value))) (QUALIFIER (and (rtl:machine-constant? type) (rtl:machine-constant? datum))) - (rtl:make-cons-pointer type datum)) - -;; I've copied these rules from the MC68020. -- Jinx. + (rtl:make-cons-non-pointer type datum)) (define-rule rewriting (CONS-POINTER (REGISTER (? type register-known-value)) (? datum)) @@ -59,11 +56,31 @@ MIT in each case. |# datum)) (define-rule rewriting - (CONS-POINTER (? type) (REGISTER (? datum register-known-value))) + (CONS-POINTER (REGISTER (? type register-known-value)) (? datum)) + (QUALIFIER (rtl:machine-constant? type)) + (rtl:make-cons-pointer type datum)) + +(define-rule rewriting + (CONS-NON-POINTER (REGISTER (? type register-known-value)) (? datum)) + (QUALIFIER (rtl:machine-constant? type)) + (rtl:make-cons-non-pointer type datum)) + +(define-rule rewriting + (CONS-NON-POINTER (REGISTER (? type register-known-value)) (? datum)) + (QUALIFIER + (and (rtl:object->type? type) + (rtl:constant? (rtl:object->type-expression type)))) + (rtl:make-cons-non-pointer + (rtl:make-machine-constant + (object-type (rtl:object->type-expression datum))) + datum)) + +(define-rule rewriting + (CONS-NON-POINTER (? type) (REGISTER (? datum register-known-value))) (QUALIFIER (and (rtl:object->datum? datum) (rtl:constant-non-pointer? (rtl:object->datum-expression datum)))) - (rtl:make-cons-pointer + (rtl:make-cons-non-pointer type (rtl:make-machine-constant (careful-object-datum (rtl:object->datum-expression datum))))) @@ -111,11 +128,11 @@ MIT in each case. |# (and (non-pointer-object? value) (zero? (object-type value)) (zero? (careful-object-datum value))))) - ((rtl:cons-pointer? expression) - (and (let ((expression (rtl:cons-pointer-type expression))) + ((rtl:cons-non-pointer? expression) + (and (let ((expression (rtl:cons-non-pointer-type expression))) (and (rtl:machine-constant? expression) (zero? (rtl:machine-constant-value expression)))) - (let ((expression (rtl:cons-pointer-datum expression))) + (let ((expression (rtl:cons-non-pointer-datum expression))) (and (rtl:machine-constant? expression) (zero? (rtl:machine-constant-value expression)))))) (else false))) diff --git a/v7/src/compiler/rtlbase/rtlcon.scm b/v7/src/compiler/rtlbase/rtlcon.scm index 2b0395652..ed3266b53 100644 --- a/v7/src/compiler/rtlbase/rtlcon.scm +++ b/v7/src/compiler/rtlbase/rtlcon.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlcon.scm,v 4.21 1990/05/03 15:10:19 jinx Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlcon.scm,v 4.22 1991/10/25 00:14:14 cph Exp $ -Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology +Copyright (c) 1988-91 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -91,8 +91,9 @@ MIT in each case. |# (define (rtl:make-unassigned-test expression) (rtl:make-eq-test expression - (rtl:make-cons-pointer (rtl:make-machine-constant (ucode-type unassigned)) - (rtl:make-machine-constant 0)))) + (rtl:make-cons-non-pointer + (rtl:make-machine-constant (ucode-type unassigned)) + (rtl:make-machine-constant 0)))) (define (rtl:make-fixnum-pred-1-arg predicate operand) (expression-simplify-for-predicate operand @@ -141,7 +142,7 @@ MIT in each case. |# (define (rtl:make-constant value) (if (unassigned-reference-trap? value) - (rtl:make-cons-pointer + (rtl:make-cons-non-pointer (rtl:make-machine-constant type-code:unassigned) (rtl:make-machine-constant 0)) (%make-constant value))) @@ -254,6 +255,15 @@ MIT in each case. |# (cdr expression)) (assign-to-temporary expression scfg-append! receiver))))) +(define (simplify-expressions expressions scfg-append! generator) + (let loop ((expressions* expressions) (simplified-expressions '())) + (if (null? expressions*) + (generator (reverse! simplified-expressions)) + (expression-simplify (car expressions*) scfg-append! + (lambda (expression) + (loop (cdr expressions*) + (cons expression simplified-expressions))))))) + (define (assign-to-temporary expression scfg-append! receiver) (let ((pseudo (rtl:make-pseudo-register))) (scfg-append! (rtl:make-assignment-internal pseudo expression) @@ -399,6 +409,14 @@ MIT in each case. |# (expression-simplify datum scfg-append! (lambda (datum) (receiver (rtl:make-cons-pointer type datum)))))))) + +(define-expression-method 'CONS-NON-POINTER + (lambda (receiver scfg-append! type datum) + (expression-simplify type scfg-append! + (lambda (type) + (expression-simplify datum scfg-append! + (lambda (datum) + (receiver (rtl:make-cons-non-pointer type datum)))))))) (define-expression-method 'CELL-CONS (lambda (receiver scfg-append! expression) @@ -410,60 +428,103 @@ MIT in each case. |# free) scfg-append! (lambda (temporary) - (scfg-append! - (rtl:make-assignment-internal (rtl:make-post-increment free 1) - expression) - (receiver temporary))))))))) + (if use-pre/post-increment? + (scfg-append! + (rtl:make-assignment-internal + (rtl:make-post-increment free 1) + expression) + (receiver temporary)) + (scfg-append! + (rtl:make-assignment-internal (rtl:make-offset free 0) + expression) + (scfg-append! + (rtl:make-assignment-internal + free + (rtl:make-offset-address free 1)) + (receiver temporary))))))))))) (define-expression-method 'TYPED-CONS:PAIR (lambda (receiver scfg-append! type car cdr) (let ((free (interpreter-free-pointer))) - (let ((target (rtl:make-post-increment free 1))) - (expression-simplify type scfg-append! - (lambda (type) - (expression-simplify car scfg-append! - (lambda (car) - (expression-simplify cdr scfg-append! - (lambda (cdr) - (assign-to-temporary (rtl:make-cons-pointer type free) - scfg-append! - (lambda (temporary) - (scfg-append! - (rtl:make-assignment-internal target car) - (scfg-append! - (rtl:make-assignment-internal target cdr) - (receiver temporary))))))))))))))) - + (expression-simplify type scfg-append! + (lambda (type) + (expression-simplify car scfg-append! + (lambda (car) + (expression-simplify cdr scfg-append! + (lambda (cdr) + (assign-to-temporary (rtl:make-cons-pointer type free) + scfg-append! + (lambda (temporary) + (if use-pre/post-increment? + (scfg-append! + (rtl:make-assignment-internal + (rtl:make-post-increment free 1) + car) + (scfg-append! + (rtl:make-assignment-internal + (rtl:make-post-increment free 1) + cdr) + (receiver temporary))) + (scfg-append! + (rtl:make-assignment-internal + (rtl:make-offset free 0) + car) + (scfg-append! + (rtl:make-assignment-internal + (rtl:make-offset free 1) + cdr) + (scfg-append! + (rtl:make-assignment-internal + free + (rtl:make-offset-address free 2)) + (receiver temporary)))))))))))))))) + (define-expression-method 'TYPED-CONS:VECTOR (lambda (receiver scfg-append! type . elements) - (let* ((free (interpreter-free-pointer)) - (target (rtl:make-post-increment free 1))) + (let* ((free (interpreter-free-pointer))) (expression-simplify type scfg-append! (lambda (type) - (let loop ((elements* elements) (simplified-elements '())) - (if (null? elements*) - (assign-to-temporary (rtl:make-cons-pointer type free) - scfg-append! - (lambda (temporary) - (expression-simplify - (rtl:make-cons-pointer - (rtl:make-machine-constant (ucode-type manifest-vector)) - (rtl:make-machine-constant (length elements))) - scfg-append! - (lambda (header) - (scfg-append! - (rtl:make-assignment-internal target header) - (let loop ((elements (reverse! simplified-elements))) - (if (null? elements) - (receiver temporary) - (scfg-append! - (rtl:make-assignment-internal target - (car elements)) - (loop (cdr elements)))))))))) - (expression-simplify (car elements*) scfg-append! - (lambda (element) - (loop (cdr elements*) - (cons element simplified-elements))))))))))) + (simplify-expressions elements scfg-append! + (lambda (elements) + (assign-to-temporary (rtl:make-cons-pointer type free) + scfg-append! + (lambda (temporary) + (expression-simplify + (rtl:make-cons-non-pointer + (rtl:make-machine-constant (ucode-type manifest-vector)) + (rtl:make-machine-constant (length elements))) + scfg-append! + (lambda (header) + (if use-pre/post-increment? + (scfg-append! + (rtl:make-assignment-internal + (rtl:make-post-increment free 1) + header) + (let loop ((elements elements)) + (if (null? elements) + (receiver temporary) + (scfg-append! + (rtl:make-assignment-internal + (rtl:make-post-increment free 1) + (car elements)) + (loop (cdr elements)))))) + (scfg-append! + (rtl:make-assignment-internal + (rtl:make-offset free 0) + header) + (let loop ((elements elements) (offset 1)) + (if (null? elements) + (scfg-append! + (rtl:make-assignment-internal + free + (rtl:make-offset-address free offset)) + (receiver temporary)) + (scfg-append! + (rtl:make-assignment-internal + (rtl:make-offset free offset) + (car elements)) + (loop (cdr elements) + (+ offset 1)))))))))))))))))) (define-expression-method 'TYPED-CONS:PROCEDURE (lambda (receiver scfg-append! entry) @@ -536,8 +597,8 @@ MIT in each case. |# (define-expression-method 'FLOAT->OBJECT (object-selector rtl:make-float->object)) -(define-expression-method '@ADDRESS->FLOAT - (object-selector rtl:make-@address->float)) +(define-expression-method 'OBJECT->FLOAT + (object-selector rtl:make-object->float)) (define-expression-method 'FIXNUM-2-ARGS (lambda (receiver scfg-append! operator operand1 operand2 overflow?) diff --git a/v7/src/compiler/rtlbase/rtlexp.scm b/v7/src/compiler/rtlbase/rtlexp.scm index a55ccaf76..553fbee33 100644 --- a/v7/src/compiler/rtlbase/rtlexp.scm +++ b/v7/src/compiler/rtlbase/rtlexp.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlexp.scm,v 4.17 1991/05/06 22:42:58 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlexp.scm,v 4.18 1991/10/25 00:14:21 cph Exp $ -Copyright (c) 1987-1991 Massachusetts Institute of Technology +Copyright (c) 1987-91 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -60,12 +60,14 @@ MIT in each case. |# (case (rtl:expression-type expression) ((REGISTER) (register-value-class (rtl:register-number expression))) - ((CONS-POINTER CONSTANT FIXNUM->OBJECT FLOAT->OBJECT GENERIC-BINARY - GENERIC-UNARY OFFSET POST-INCREMENT PRE-INCREMENT - ;; This is a lie, but it is the only way in which it is - ;; used now! It should be moved to value-class=address, - ;; and a cast type introduced to handle current usage. - BYTE-OFFSET-ADDRESS) + ((CONS-NON-POINTER CONS-POINTER CONSTANT FIXNUM->OBJECT FLOAT->OBJECT + GENERIC-BINARY GENERIC-UNARY OFFSET POST-INCREMENT + PRE-INCREMENT + ;; This is a lie, but it is the only way that + ;; it is used now! It should be moved to + ;; value-class=address, and a cast type + ;; introduced to handle current usage. + BYTE-OFFSET-ADDRESS) value-class=object) ((FIXNUM->ADDRESS OBJECT->ADDRESS OFFSET-ADDRESS @@ -84,7 +86,7 @@ MIT in each case. |# value-class=fixnum) ((OBJECT->TYPE) value-class=type) - ((@ADDRESS->FLOAT FLONUM-1-ARG FLONUM-2-ARGS) + ((OBJECT->FLOAT FLONUM-1-ARG FLONUM-2-ARGS) value-class=float) (else (error "unknown RTL expression type" expression)))) @@ -110,7 +112,7 @@ MIT in each case. |# (define (rtl:register-assignment? rtl) (and (rtl:assign? rtl) (rtl:register? (rtl:assign-address rtl)))) - + (define (rtl:expression-cost expression) (if (rtl:register? expression) 1 @@ -122,7 +124,7 @@ MIT in each case. |# (if (pair? (car parts)) (+ cost (rtl:expression-cost (car parts))) cost))))))) - + (define (rtl:map-subexpressions expression procedure) (if (rtl:constant? expression) expression @@ -187,7 +189,7 @@ MIT in each case. |# (rtl:expression=? (car x) (car y)) (eqv? (car x) (car y))) (loop (cdr x) (cdr y))))))))) - + (define (rtl:match-subexpressions x y predicate) (let ((type (car x))) (and (eq? type (car y)) @@ -199,7 +201,7 @@ MIT in each case. |# (predicate (car x) (car y)) (eqv? (car x) (car y))) (loop (cdr x) (cdr y))))))))) - + (define (rtl:refers-to-register? rtl register) (let loop ((expression @@ -275,6 +277,7 @@ MIT in each case. |# true) ((BYTE-OFFSET-ADDRESS CHAR->ASCII + CONS-NON-POINTER CONS-POINTER FIXNUM-1-ARG FIXNUM-2-ARGS diff --git a/v7/src/compiler/rtlbase/rtlty1.scm b/v7/src/compiler/rtlbase/rtlty1.scm index 78a03c9d5..facf69d00 100644 --- a/v7/src/compiler/rtlbase/rtlty1.scm +++ b/v7/src/compiler/rtlbase/rtlty1.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlty1.scm,v 4.18 1991/05/06 22:42:42 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlty1.scm,v 4.19 1991/10/25 00:14:27 cph Exp $ -Copyright (c) 1987-1991 Massachusetts Institute of Technology +Copyright (c) 1987-91 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -92,6 +92,7 @@ MIT in each case. |# (define-rtl-expression object->datum rtl: expression) (define-rtl-expression object->type rtl: expression) (define-rtl-expression cons-pointer rtl: type datum) +(define-rtl-expression cons-non-pointer rtl: type datum) ;;; Convert a character object to an ASCII machine integer (define-rtl-expression char->ascii rtl: expression) @@ -109,16 +110,16 @@ MIT in each case. |# (define-rtl-expression fixnum-1-arg rtl: operator operand overflow?) (define-rtl-expression fixnum-2-args rtl: operator operand-1 operand-2 overflow?) - + ;;; Conversion between flonums and machine floats (define-rtl-expression float->object rtl: expression) -(define-rtl-expression @address->float rtl: expression) +(define-rtl-expression object->float rtl: expression) ;;; Floating-point arithmetic operations (define-rtl-expression flonum-1-arg rtl: operator operand overflow?) (define-rtl-expression flonum-2-args rtl: operator operand-1 operand-2 overflow?) - + (define-rtl-predicate fixnum-pred-1-arg % predicate operand) (define-rtl-predicate fixnum-pred-2-args % predicate operand-1 operand-2) diff --git a/v7/src/compiler/rtlgen/opncod.scm b/v7/src/compiler/rtlgen/opncod.scm index 3f9ed99be..0e2c21cbe 100644 --- a/v7/src/compiler/rtlgen/opncod.scm +++ b/v7/src/compiler/rtlgen/opncod.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/opncod.scm,v 4.44 1991/06/14 21:19:58 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/opncod.scm,v 4.45 1991/10/25 00:14:57 cph Exp $ -Copyright (c) 1988-1991 Massachusetts Institute of Technology +Copyright (c) 1988-91 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -497,20 +497,21 @@ MIT in each case. |# address-units-per-packed-char))) (define (rtl:length-fetch locative) - (rtl:make-cons-pointer (rtl:make-machine-constant (ucode-type fixnum)) - (rtl:make-fetch locative))) + (rtl:make-cons-non-pointer (rtl:make-machine-constant (ucode-type fixnum)) + (rtl:make-fetch locative))) (define (rtl:vector-length-fetch locative) - (rtl:make-cons-pointer (rtl:make-machine-constant (ucode-type fixnum)) - (rtl:make-object->datum (rtl:make-fetch locative)))) + (rtl:make-cons-non-pointer + (rtl:make-machine-constant (ucode-type fixnum)) + (rtl:make-object->datum (rtl:make-fetch locative)))) (define (rtl:string-fetch locative) - (rtl:make-cons-pointer (rtl:make-machine-constant (ucode-type character)) - (rtl:make-fetch locative))) + (rtl:make-cons-non-pointer (rtl:make-machine-constant (ucode-type character)) + (rtl:make-fetch locative))) (define (rtl:vector-8b-fetch locative) - (rtl:make-cons-pointer (rtl:make-machine-constant (ucode-type fixnum)) - (rtl:make-fetch locative))) + (rtl:make-cons-non-pointer (rtl:make-machine-constant (ucode-type fixnum)) + (rtl:make-fetch locative))) (define (rtl:string-assignment locative value) (rtl:make-assignment locative (rtl:make-char->ascii value))) @@ -765,7 +766,7 @@ MIT in each case. |# combination (list (open-code:type-check char (ucode-type character))) (finish - (rtl:make-cons-pointer + (rtl:make-cons-non-pointer (rtl:make-machine-constant (ucode-type fixnum)) (rtl:make-object->datum char))) finish @@ -901,8 +902,7 @@ MIT in each case. |# (finish (rtl:make-float->object (rtl:make-flonum-1-arg flonum-operator - (rtl:make-@address->float - (rtl:make-object->address argument)) + (rtl:make-object->float argument) false))) finish flonum-operator @@ -928,10 +928,8 @@ MIT in each case. |# (rtl:make-float->object (rtl:make-flonum-2-args flonum-operator - (rtl:make-@address->float - (rtl:make-object->address arg1)) - (rtl:make-@address->float - (rtl:make-object->address arg2)) + (rtl:make-object->float arg1) + (rtl:make-object->float arg2) false))) finish flonum-operator @@ -952,8 +950,7 @@ MIT in each case. |# (finish (rtl:make-flonum-pred-1-arg flonum-pred - (rtl:make-@address->float - (rtl:make-object->address argument)))) + (rtl:make-object->float argument))) (lambda (expression) (finish (rtl:make-true-test expression))) flonum-pred @@ -975,10 +972,8 @@ MIT in each case. |# (open-code:type-check arg2 (ucode-type flonum))) (finish (rtl:make-flonum-pred-2-args flonum-pred - (rtl:make-@address->float - (rtl:make-object->address arg1)) - (rtl:make-@address->float - (rtl:make-object->address arg2)))) + (rtl:make-object->float arg1) + (rtl:make-object->float arg2))) (lambda (expression) (finish (rtl:make-true-test expression))) flonum-pred diff --git a/v7/src/compiler/rtlopt/rcompr.scm b/v7/src/compiler/rtlopt/rcompr.scm index 01bb695d7..b025e0499 100644 --- a/v7/src/compiler/rtlopt/rcompr.scm +++ b/v7/src/compiler/rtlopt/rcompr.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcompr.scm,v 1.11 1991/03/21 09:42:38 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcompr.scm,v 1.12 1991/10/25 00:15:18 cph Exp $ Copyright (c) 1988-91 Massachusetts Institute of Technology @@ -167,9 +167,17 @@ MIT in each case. |# ((and (rtl:cons-pointer? expression) (rtl:machine-constant? (rtl:cons-pointer-type expression))) (recursion rtl:cons-pointer-datum - (lambda (datum) - (rtl:make-cons-pointer (rtl:cons-pointer-type expression) - datum)))) + (lambda (datum) + (rtl:make-cons-pointer (rtl:cons-pointer-type expression) + datum)))) + ((and (rtl:cons-non-pointer? expression) + (rtl:machine-constant? + (rtl:cons-non-pointer-type expression))) + (recursion rtl:cons-non-pointer-datum + (lambda (datum) + (rtl:make-cons-non-pointer + (rtl:cons-non-pointer-type expression) + datum)))) ((rtl:object->address? expression) (recursion rtl:object->address-expression rtl:make-object->address)) diff --git a/v7/src/compiler/rtlopt/rinvex.scm b/v7/src/compiler/rtlopt/rinvex.scm index 8d1dfb5a1..e5b0ff583 100644 --- a/v7/src/compiler/rtlopt/rinvex.scm +++ b/v7/src/compiler/rtlopt/rinvex.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rinvex.scm,v 1.5 1991/05/06 22:44:31 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rinvex.scm,v 1.6 1991/10/25 00:15:37 cph Exp $ -Copyright (c) 1989-1991 Massachusetts Institute of Technology +Copyright (c) 1989-91 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -113,10 +113,10 @@ MIT in each case. |# unspecific) (define (expression-update! get-expression set-expression! object) - ;; Note: The following code may cause pseudo register copies to be + ;; Note: The following code may cause pseudo-register copies to be ;; generated since it would have to propagate some of the - ;; simplifications, and then delete the now-unused registers. - ;; This is not worth it since the previous register is likely to be + ;; simplifications, and then delete the now unused registers. This + ;; is not worthwhile since the previous register is likely to be ;; dead at this point, so the lap-level register allocator will ;; reuse the alias achieving the effect of the deletion. Ultimately ;; the expression invertibility code should be integrated into the @@ -129,36 +129,40 @@ MIT in each case. |# (optimize-expression (rtl:map-subexpressions expression loop)))))) (define (optimize-expression expression) - (define (try-identity identity) - (let ((in-domain? (car identity)) - (matching-operation (cadr identity))) - (let loop ((operations (cddr identity)) - (subexpression ((cadr matching-operation) expression))) - (if (null? operations) - (and (valid-subexpression? subexpression) - (in-domain? (rtl:expression-value-class subexpression)) - subexpression) - (let ((subexpression (canonicalize-subexpression subexpression))) - (and (eq? (caar operations) (rtl:expression-type subexpression)) - (loop (cdr operations) - ((cadar operations) subexpression)))))))) - - (let loop ((rules (list-transform-positive - identities - (let ((type (rtl:expression-type expression))) - (lambda (identity) - (eq? type (car (cadr identity)))))))) - - (cond ((null? rules) expression) - ((try-identity (car rules)) => optimize-expression) - (else (loop (cdr rules)))))) + (let loop + ((identities + (list-transform-positive identities + (let ((type (rtl:expression-type expression))) + (lambda (identity) + (eq? type (car (cadr identity)))))))) + (cond ((null? identities) + expression) + ((let ((identity (car identities))) + (let ((in-domain? (car identity)) + (matching-operation (cadr identity))) + (let loop + ((operations (cddr identity)) + (subexpression ((cadr matching-operation) expression))) + (if (null? operations) + (and (valid-subexpression? subexpression) + (in-domain? + (rtl:expression-value-class subexpression)) + subexpression) + (let ((subexpression + (canonicalize-subexpression subexpression))) + (and (eq? (caar operations) + (rtl:expression-type subexpression)) + (loop (cdr operations) + ((cadar operations) subexpression)))))))) + => optimize-expression) + (else + (loop (cdr identities)))))) (define identities - ;; Each entry is composed of a value class and a sequence - ;; of operations whose composition is the identity for that - ;; value class. - ;; Each operation is described by the operator and the selector for - ;; the relevant operand. + ;; Each entry is composed of a value class and a sequence of + ;; operations whose composition is the identity for that value + ;; class. Each operation is described by the operator and the + ;; selector for the relevant operand. `((,value-class=value? (OBJECT->FIXNUM ,rtl:object->fixnum-expression) (FIXNUM->OBJECT ,rtl:fixnum->object-expression)) (,value-class=value? (FIXNUM->OBJECT ,rtl:fixnum->object-expression) @@ -173,25 +177,19 @@ MIT in each case. |# (ADDRESS->FIXNUM ,rtl:address->fixnum-expression)) (,value-class=value? (ADDRESS->FIXNUM ,rtl:address->fixnum-expression) (FIXNUM->ADDRESS ,rtl:fixnum->address-expression)) - (,value-class=value? (@ADDRESS->FLOAT ,rtl:@address->float-expression) - (OBJECT->ADDRESS ,rtl:object->address-expression) + (,value-class=value? (OBJECT->FLOAT ,rtl:object->float-expression) (FLOAT->OBJECT ,rtl:float->object-expression)) (,value-class=value? (FLOAT->OBJECT ,rtl:float->object-expression) - (@ADDRESS->FLOAT ,rtl:@address->float-expression) - (OBJECT->ADDRESS ,rtl:object->address-expression)) - #| - ;; This one, although true, is useless. - (,value-class=value? (OBJECT->ADDRESS ,rtl:object->address-expression) - (FLOAT->OBJECT ,rtl:float->object-expression) - (@ADDRESS->FLOAT ,rtl:@address->float-expression)) - |# + (OBJECT->FLOAT ,rtl:object->float-expression)) (,value-class=address? (OBJECT->ADDRESS ,rtl:object->address-expression) (CONS-POINTER ,rtl:cons-pointer-datum)) (,value-class=datum? (OBJECT->DATUM ,rtl:object->datum-expression) - (CONS-POINTER ,rtl:cons-pointer-datum)) + (CONS-NON-POINTER ,rtl:cons-non-pointer-datum)) ;; Perhaps this should be value-class=type (,value-class=immediate? (OBJECT->TYPE ,rtl:object->type-expression) - (CONS-POINTER ,rtl:cons-pointer-type)))) + (CONS-POINTER ,rtl:cons-pointer-type)) + (,value-class=immediate? (OBJECT->TYPE ,rtl:object->type-expression) + (CONS-NON-POINTER ,rtl:cons-non-pointer-type)))) (define (valid-subexpression? expression) ;; Machine registers not allowed because they are volatile. -- 2.25.1