From 18d4fa553c5d100974a9a566e0c2add61e45e58d Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 15 Dec 1986 05:48:57 +0000
Subject: [PATCH] *** empty log message ***
---
v7/src/compiler/machines/bobcat/lapgen.scm | 166 +++++++++---------
v7/src/compiler/machines/bobcat/machin.scm | 19 +-
.../compiler/machines/bobcat/make.scm-68040 | 30 ++--
3 files changed, 108 insertions(+), 107 deletions(-)
diff --git a/v7/src/compiler/machines/bobcat/lapgen.scm b/v7/src/compiler/machines/bobcat/lapgen.scm
index 474bf281a..44970dd94 100644
--- a/v7/src/compiler/machines/bobcat/lapgen.scm
+++ b/v7/src/compiler/machines/bobcat/lapgen.scm
@@ -37,6 +37,8 @@
;;;; RTL Rules for 68020
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/lapgen.scm,v 1.139 1986/12/15 05:48:37 cph Exp $
+
(declare (usual-integrations))
(using-syntax (access lap-generator-syntax-table compiler-package)
@@ -114,10 +116,10 @@
(else
`(MOVE L (& ,datum) ,target))))
-(define (test-type type expression)
- (if (and (zero? type) (TSTable-expression? expression))
+(define (test-byte n expression)
+ (if (and (zero? n) (TSTable-expression? expression))
`(TST B ,expression)
- `(CMP B (& ,type) ,expression)))
+ `(CMP B (& ,n) ,expression)))
(define (test-non-pointer type datum expression)
(if (and (zero? type) (zero? datum) (TSTable-expression? expression))
@@ -170,26 +172,14 @@
(memq (car expression) '(A D)))
(define (indirect-reference! register offset)
- (offset-reference (coerce->indirect-register! register) offset))
-
-(define (coerce->indirect-register! register)
- (cond ((memv register '(13 14 15)) register)
- ((and (pseudo-register? register)
- (dead-register? register)
- (let ((alias (register-alias register 'DATA)))
- (and alias
- (begin (prefix-instructions!
- `((AND L ,mask-reference
- ,(register-reference alias))))
- alias)))))
- (else
- (with-temporary-register! 'DATA
- (lambda (temp)
- (prefix-instructions!
- (let ((temp-ref (register-reference temp)))
- `((MOVE L ,(coerce->any register) ,temp-ref)
- (AND L ,mask-reference ,temp-ref))))
- temp)))))
+ (offset-reference
+ (if (machine-register? register)
+ register
+ (or (register-alias register false)
+ ;; This means that someone has written an address out
+ ;; to memory, something that should never happen.
+ (error "Needed to load indirect register!" register)))
+ offset))
(define (coerce->any register)
(if (machine-register? register)
@@ -216,6 +206,13 @@
(LABEL ,loop)
,instruction
(DB F (D ,counter) (@PCR ,loop))))))))
+
+(define-integrable (data-register? register)
+ (< register 8))
+
+(define (address-register? register)
+ (and (< register 16)
+ (>= register 8)))
;;;; Registers/Entries
@@ -256,26 +253,32 @@
(define-rule statement
(ASSIGN (REGISTER (? target)) (REGISTER (? source)))
(QUALIFIER (pseudo-register? target))
- (let ((source (coerce->any source)))
- (delete-dead-registers!)
- (allocate-register-for-assignment! target false
- (lambda (target)
- `((MOVE L ,source ,(register-reference target)))))))
+ (move-to-alias-register! source 'DATA target)
+ '())
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (OBJECT->ADDRESS (REGISTER (? source))))
+ (QUALIFIER (pseudo-register? target))
+ (let ((target (move-to-alias-register! source 'DATA target)))
+ `((AND L ,mask-reference ,target))))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (OBJECT->TYPE (REGISTER (? source))))
+ (QUALIFIER (pseudo-register? target))
+ (let ((target (move-to-alias-register! source 'DATA target)))
+ `((LS R (& 24) ,target))))
(define-rule statement
(ASSIGN (REGISTER (? target)) (OFFSET (REGISTER (? address)) (? offset)))
(QUALIFIER (pseudo-register? target))
- (let ((address (coerce->indirect-register! address)))
+ (let ((source (indirect-reference! address offset)))
(delete-dead-registers!)
;; The fact that the target register here is a data register is a
;; heuristic that works reasonably well since if the value is a
;; pointer, we will probably want to dereference it, which
;; requires that we first mask it.
- (allocate-register-for-assignment! target 'DATA
- (lambda (target)
- `((MOVE L
- ,(offset-reference address offset)
- ,(register-reference target)))))))
+ `((MOVE L ,source
+ ,(register-reference (allocate-alias-register! target 'DATA))))))
(define-rule statement
(ASSIGN (REGISTER (? target))
@@ -293,13 +296,6 @@
;;;; Transfers to Memory
-(define-rule statement
- (ASSIGN (OFFSET (REGISTER (? a)) (? n))
- (CONS-POINTER (CONSTANT (? type)) (REGISTER (? r))))
- (let ((target (indirect-reference! a n)))
- `((MOVE L ,(coerce->any r) ,target)
- (MOVE B (& ,type) ,target))))
-
(define-rule statement
(ASSIGN (OFFSET (REGISTER (? a)) (? n))
(CONSTANT (? object)))
@@ -310,13 +306,18 @@
(REGISTER (? r)))
`((MOVE L ,(coerce->any r) ,(indirect-reference! a n))))
+(define-rule statement
+ (ASSIGN (OFFSET (REGISTER (? a)) (? n))
+ (CONS-POINTER (CONSTANT (? type)) (REGISTER (? r))))
+ (let ((target (indirect-reference! a n)))
+ `((MOVE L ,(coerce->any r) ,target)
+ (MOVE B (& ,type) ,target))))
+
(define-rule statement
(ASSIGN (OFFSET (REGISTER (? a0)) (? n0))
(OFFSET (REGISTER (? a1)) (? n1)))
- (let ((a1 (coerce->indirect-register! a1)))
- `((MOVE L
- ,(offset-reference a1 n1)
- ,(offset-reference (coerce->indirect-register! a0) n0)))))
+ (let ((source (indirect-reference! a1 n1)))
+ `((MOVE L ,source ,(indirect-reference! a0 n0)))))
;;;; Consing
@@ -334,12 +335,11 @@
(define-rule statement
(ASSIGN (POST-INCREMENT (REGISTER 13) 1) (ENTRY:PROCEDURE (? procedure)))
- (with-temporary-register! 'ADDRESS
- (lambda (a)
- (let ((a (register-reference a)))
- `((LEA (@PCR ,(procedure-external-label procedure)) ,a)
- (MOVE L ,a (@A+ 5))
- (MOVE B (& ,type-code:return-address) (@AO 5 -4)))))))
+ (let ((temporary
+ (register-reference (allocate-temporary-register! 'ADDRESS))))
+ `((LEA (@PCR ,(procedure-external-label procedure)) ,temporary)
+ (MOVE L ,temporary (@A+ 5))
+ (MOVE B (& ,type-code:return-address) (@AO 5 -4)))))
;;;; Pushes
@@ -355,6 +355,12 @@
(ASSIGN (PRE-INCREMENT (REGISTER 15) -1) (REGISTER (? r)))
`((MOVE L ,(coerce->any r) (@-A 7))))
+(define-rule statement
+ (ASSIGN (PRE-INCREMENT (REGISTER 15) -1)
+ (CONS-POINTER (CONSTANT (? type)) (REGISTER (? r))))
+ `((MOVE L ,(coerce->any r) (@-A 7))
+ (MOVE B (& ,type) (@A 7))))
+
(define-rule statement
(ASSIGN (PRE-INCREMENT (REGISTER 15) -1) (OFFSET (REGISTER (? r)) (? n)))
`((MOVE L ,(indirect-reference! r n) (@-A 7))))
@@ -370,12 +376,6 @@
(ENTRY:CONTINUATION (? continuation)))
`((PEA (@PCR ,(continuation-label continuation)))
(MOVE B (& ,type-code:return-address) (@A 7))))
-
-(define-rule statement
- (ASSIGN (PRE-INCREMENT (REGISTER 15) -1)
- (CONS-POINTER (CONSTANT (? type)) (REGISTER (? r))))
- `((MOVE L ,(coerce->any r) (@-A 7))
- (MOVE B (& ,type) (@A 7))))
;;;; Predicates
@@ -391,26 +391,27 @@
(indirect-reference! register offset))))
(define-rule predicate
- (TRUE-TEST (TYPE-TEST (REGISTER (? register)) (? type)))
+ (TYPE-TEST (REGISTER (? register)) (? type))
+ (QUALIFIER (pseudo-register? register))
(set-standard-branches! 'EQ)
- (let ((register (coerce->any register)))
- (if (memq (car register) '(A D))
- `((MOVE L ,register ,reg:temp)
- ,(test-type type reg:temp))
- `(,(test-type type register)))))
+ `(,(test-byte type
+ (register-reference (load-alias-register! register 'DATA)))))
(define-rule predicate
- (TRUE-TEST (TYPE-TEST (OFFSET (REGISTER (? register)) (? offset)) (? type)))
+ (TYPE-TEST (OBJECT->TYPE (REGISTER (? register))) (? type))
+ (QUALIFIER (pseudo-register? register))
(set-standard-branches! 'EQ)
- `(,(test-type type (indirect-reference! register offset))))
+ (let ((reference (move-to-temporary-register! register 'DATA)))
+ `((LS R (& 24) ,reference)
+ ,(test-byte type reference))))
(define-rule predicate
- (TRUE-TEST (UNASSIGNED-TEST (REGISTER (? register))))
+ (UNASSIGNED-TEST (REGISTER (? register)))
(set-standard-branches! 'EQ)
`(,(test-non-pointer (ucode-type unassigned) 0 (coerce->any register))))
(define-rule predicate
- (TRUE-TEST (UNASSIGNED-TEST (OFFSET (REGISTER (? register)) (? offset))))
+ (UNASSIGNED-TEST (OFFSET (REGISTER (? register)) (? offset)))
(set-standard-branches! 'EQ)
`(,(test-non-pointer (ucode-type unassigned) 0
(indirect-reference! register offset))))
@@ -503,24 +504,19 @@
(let ((i `(MOVE L (@A+ 7) ,(offset-reference a7 (-1+ how-far)))))
`(,i ,i ,@(increment-anl 7 (- how-far 2))))))
(else
- (with-temporary-register! 'ADDRESS
- (lambda (a0)
- ;; If we can guarantee that interrupts will not use the user
- ;; stack, we can use A7 here rather than allocating this
- ;; second temporary register.
- (with-temporary-register! 'ADDRESS
- (lambda (a1)
- `((LEA ,(offset-reference a7 frame-size)
- ,(register-reference a0))
- (LEA ,(offset-reference a7 (+ frame-size how-far))
- ,(register-reference a1))
- ,@(generate-n-times frame-size 5
- `(MOVE L
- (@-A ,(- a0 8))
- (@-A ,(- a1 8)))
- (lambda (generator)
- (with-temporary-register! 'DATA generator)))
- (MOVE L ,(register-reference a1) (A 7))))))))))
+ (let ((temp-0 (allocate-temporary-register! 'ADDRESS))
+ (temp-1 (allocate-temporary-register! 'ADDRESS)))
+ `((LEA ,(offset-reference a7 frame-size)
+ ,(register-reference temp-0))
+ (LEA ,(offset-reference a7 (+ frame-size how-far))
+ ,(register-reference temp-1))
+ ,@(generate-n-times frame-size 5
+ `(MOVE L
+ (@-A ,(- temp-0 8))
+ (@-A ,(- temp-1 8)))
+ (lambda (generator)
+ (generator (allocate-temporary-register! 'DATA))))
+ (MOVE L ,(register-reference temp-1) (A 7)))))))
(define (generate-invocation-prefix:apply-closure frame-size receiver-offset)
(let ((label (generate-label)))
diff --git a/v7/src/compiler/machines/bobcat/machin.scm b/v7/src/compiler/machines/bobcat/machin.scm
index dd80bfc66..599a57b6c 100644
--- a/v7/src/compiler/machines/bobcat/machin.scm
+++ b/v7/src/compiler/machines/bobcat/machin.scm
@@ -37,6 +37,8 @@
;;;; Machine Model for 68020
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/machin.scm,v 1.41 1986/12/15 05:48:50 cph Exp $
+
(declare (usual-integrations))
(using-syntax (access compiler-syntax-table compiler-package)
(define (rtl:message-receiver-size:closure) 2)
@@ -68,18 +70,21 @@
(+ 30
(rtl:expression-cost (rtl:cons-pointer-type expression))
(rtl:expression-cost (rtl:cons-pointer-datum expression))))
- ;; move.l d(reg),reg = 16
- ;; and.l d7,reg = 6
- ((OBJECT->ADDRESS) 22)
+ ((OBJECT->ADDRESS OBJECT->DATUM) 6) ;and.l d7,reg
+ ;; move.l reg,d(reg) = 16
+ ;; move.b d(reg),reg = 12
+ ((OBJECT->TYPE) 28)
((OFFSET) 16) ;move.l d(reg),reg
((OFFSET-ADDRESS) 8) ;lea d(an),reg
((POST-INCREMENT) 12) ;move.l (reg)+,reg
((PRE-INCREMENT) 14) ;move.l -(reg),reg
((REGISTER) 4) ;move.l reg,reg
- ((ENTRY:CONTINUATION ENTRY:PROCEDURE UNASSIGNED) 16) ;move.l d(pc),reg
- ;; **** Random. Fix this later.
- ((TYPE-TEST UNASSIGNED-TEST)
- (+ 40 (rtl:expression-cost (rtl:test-expression expression))))
+ ((UNASSIGNED) 12) ;move.l #data,reg
+ ;; lea d(pc),reg = 8
+ ;; move.l reg,d(reg) = 16
+ ;; move.b #type,d(reg) = 16
+ ;; move.l d(reg),reg = 16
+ ((ENTRY:CONTINUATION ENTRY:PROCEDURE) 56)
(else (error "Unknown expression type" expression))))
(define (rtl:machine-register? rtl-register)
diff --git a/v7/src/compiler/machines/bobcat/make.scm-68040 b/v7/src/compiler/machines/bobcat/make.scm-68040
index 41b3e00b5..1e216fe6e 100644
--- a/v7/src/compiler/machines/bobcat/make.scm-68040
+++ b/v7/src/compiler/machines/bobcat/make.scm-68040
@@ -43,21 +43,6 @@
(load "rcs" system-global-environment)
(load "load" system-global-environment)
-(in-package compiler-package
-
- (define compiler-system
- (make-environment
- (define :name "Liar (Bobcat 68020)")
- (define :version)
- (define :modification)
-
- (parse-rcs-header "$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 1.8 1986/12/13 18:10:01 cph Exp $"
- (lambda (filename version date time author state)
- (set! :version (car version))
- (set! :modification (cadr version))))))
-
- (add-system! compiler-system))
-
(load-system system-global-environment
'COMPILER-PACKAGE
'(SYSTEM-GLOBAL-ENVIRONMENT)
@@ -132,6 +117,21 @@
))
+(in-package compiler-package
+
+ (define compiler-system
+ (make-environment
+ (define :name "Liar (Bobcat 68020)")
+ (define :version)
+ (define :modification)
+
+ (parse-rcs-header "$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 1.9 1986/12/15 05:48:57 cph Exp $"
+ (lambda (filename version date time author state)
+ (set! :version (car version))
+ (set! :modification (cadr version))))))
+
+ (add-system! compiler-system))
+
(%ge compiler-package)
(%gst (access compiler-syntax-table compiler-package))
(%gst (access compiler-syntax-table compiler-package))
\ No newline at end of file
--
2.25.1