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.
#| -*-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
((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)
(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)))
\f
;;;; Regularized Machine Instructions
(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)
(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*)))))))
(set-machine-register-label *register-map* alias (cons type label)))
unspecific)
\f
+(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))))))
+\f
;;;; Comparisons
-(define (compare-immediate comp i r2)
- ; Branch if immediate <comp> r2
+(define (compare-immediate comp immediate source)
+ ; Branch if immediate <comp> source
(let ((cc (invert-condition-noncommutative comp)))
;; This machine does register <op> 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 <cc> 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
\f
;;;; 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.
(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))
#| -*-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
\f
;;;; 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)
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?
#| -*-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
(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
#| -*-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
(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
#| -*-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
(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))
(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
(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)))
\f
;;;; 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))
+\f
(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
;; 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))))
\f
-;;;; 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))
#| -*-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
(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)
#| -*-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
(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
(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)))
(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
(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)))
\f
(define-rule statement
(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
(? 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)))
\f
(define-rule statement
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
(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
(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)
;; 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
,@(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)))))
(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)
(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)
(+ (* 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)
;; (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)
(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)
#| -*-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
(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
(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
#| -*-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
(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"
(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))
(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)
(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)
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))))))))
\f
;;;; Predicates
#| -*-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
(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)))))
\f
;;;; Flonum Arithmetic
#| -*-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
;;;; 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))
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)))))
(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)))
#| -*-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
(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))))
\f
(define (rtl:make-fixnum-pred-1-arg predicate operand)
(expression-simplify-for-predicate operand
(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)))
(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)
(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))))))))
\f
(define-expression-method 'CELL-CONS
(lambda (receiver scfg-append! expression)
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))))))))))))))))
+\f
(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))))))))))))))))))
\f
(define-expression-method 'TYPED-CONS:PROCEDURE
(lambda (receiver scfg-append! entry)
(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?)
#| -*-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
(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
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))))
(define (rtl:register-assignment? rtl)
(and (rtl:assign? rtl)
(rtl:register? (rtl:assign-address rtl))))
-
+\f
(define (rtl:expression-cost expression)
(if (rtl:register? expression)
1
(if (pair? (car parts))
(+ cost (rtl:expression-cost (car parts)))
cost)))))))
-\f
+
(define (rtl:map-subexpressions expression procedure)
(if (rtl:constant? expression)
expression
(rtl:expression=? (car x) (car y))
(eqv? (car x) (car y)))
(loop (cdr x) (cdr y)))))))))
-
+\f
(define (rtl:match-subexpressions x y predicate)
(let ((type (car x)))
(and (eq? type (car y))
(predicate (car x) (car y))
(eqv? (car x) (car y)))
(loop (cdr x) (cdr y)))))))))
-\f
+
(define (rtl:refers-to-register? rtl register)
(let loop
((expression
true)
((BYTE-OFFSET-ADDRESS
CHAR->ASCII
+ CONS-NON-POINTER
CONS-POINTER
FIXNUM-1-ARG
FIXNUM-2-ARGS
#| -*-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
(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)
(define-rtl-expression fixnum-1-arg rtl: operator operand overflow?)
(define-rtl-expression fixnum-2-args rtl: operator operand-1 operand-2
overflow?)
-
+\f
;;; 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?)
-\f
+
(define-rtl-predicate fixnum-pred-1-arg % predicate operand)
(define-rtl-predicate fixnum-pred-2-args % predicate operand-1 operand-2)
#| -*-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
address-units-per-packed-char)))
\f
(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)))
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
(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
(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
(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
(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
#| -*-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
((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))
#| -*-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
unspecific)
\f
(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
(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)
(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))))
\f
(define (valid-subexpression? expression)
;; Machine registers not allowed because they are volatile.
projects / mit-scheme.git / commitdiff