From: Guillermo J. Rozas <edu/mit/csail/zurich/gjr>
Date: Sun, 23 Aug 1987 07:56:16 +0000 (+0000)
Subject: Fix immediate effective address early processing.
X-Git-Tag: 20090517-FFI~13119
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=fe4e8d81c828b73dac27dc7819ea151ddd335424;p=mit-scheme.git
Fix immediate effective address early processing.
---
diff --git a/v7/src/compiler/machines/vax/inerly.scm b/v7/src/compiler/machines/vax/inerly.scm
index 882c4863a..eee0a7af7 100644
--- a/v7/src/compiler/machines/vax/inerly.scm
+++ b/v7/src/compiler/machines/vax/inerly.scm
@@ -1,6 +1,6 @@
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/inerly.scm,v 1.1 1987/08/22 22:51:27 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/inerly.scm,v 1.2 1987/08/23 07:55:56 jinx Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
@@ -84,24 +84,16 @@ MIT in each case. |#
`(define-early-transformer ',name
(make-ea-transformer 'category 'type))))
-(define *immediate-type*)
-
(define (make-ea-transformer category type)
- (let ((kernel
- (make-database-transformer
- (mapcan (lambda (rule)
- (apply
- (lambda (pattern variables categories expression)
- (if (memq category categories)
- (list (early-make-rule pattern variables expression))
- '()))
- rule))
- early-ea-database))))
- (if (eq? type '?)
- kernel
- (lambda all
- (fluid-let ((*immediate-type* type))
- (apply kernel all))))))
+ (make-database-transformer
+ (mapcan (lambda (rule)
+ (apply
+ (lambda (pattern variables categories expression)
+ (if (memq category categories)
+ (list (early-make-rule pattern variables expression))
+ '()))
+ rule))
+ early-ea-database)))
;;;; Early effective address assembly.
@@ -125,18 +117,22 @@ MIT in each case. |#
(MAKE-EFFECTIVE-ADDRESS
',keyword
',categories
- ,(process-fields fields))))))))
+ ,(process-fields fields true))))))))
rule))
rules)))))
+
+;; This is super hairy because of immediate operands!
+;; The index 2 here is the argument number to MAKE-EFFECTIVE-ADDRESS.
-(define (make-ea-selector-expander late-name index)
+(define ea-value-expander
((access scode->scode-expander package/expansion package/scode-optimizer)
(lambda (operands if-expanded if-not-expanded)
(define (default)
- (if-expanded (scode/make-combination (scode/make-variable late-name)
- operands)))
+ (if-expanded (scode/make-combination (scode/make-variable 'EA-VALUE)
+ (cdr operands))))
- (let ((operand (car operands)))
+ (let ((operand (cadr operands))
+ (type (car operands)))
(if (not (scode/combination? operand))
(default)
(scode/combination-components
@@ -146,10 +142,34 @@ MIT in each case. |#
(not (eq? (scode/variable-name operator)
'MAKE-EFFECTIVE-ADDRESS)))
(default)
- (if-expanded (list-ref operands index))))))))))
-
-;; The indeces here are the argument number to MAKE-EFFECTIVE-ADDRESS.
-
-(define ea-keyword-expander (make-ea-selector-expander 'EA-KEYWORD 0))
-(define ea-categories-expander (make-ea-selector-expander 'EA-CATEGORIES 1))
-(define ea-value-expander (make-ea-selector-expander 'EA-VALUE 2))
+ (if-expanded
+ (scode/make-combination
+ (scode/make-lambda lambda-tag:let
+ '(*IMMEDIATE-TYPE*)
+ '()
+ false
+ '()
+ '((INTEGRATE *IMMEDIATE-TYPE*))
+ (list-ref operands 2))
+ (list type)))))))))))
+
+(define coerce-to-type-expander
+ ((access scode->scode-expander package/expansion package/scode-optimizer)
+ (lambda (operands if-expanded if-not-expanded)
+ (define (handle coercion name)
+ (if-expanded
+ (if (scode/constant? (car operands))
+ (scode/make-constant
+ (coercion (scode/constant-value (car operands))))
+ (scode/make-combination (scode/make-variable name)
+ (list (car operands))))))
+
+ (if (not (scode/constant? (cadr operands)))
+ (if-not-expanded)
+ (case (scode/constant-value (cadr operands))
+ ((b) (handle coerce-8-bit-signed 'coerce-8-bit-signed))
+ ((w) (handle coerce-16-bit-signed 'coerce-16-bit-signed))
+ ((b) (handle coerce-32-bit-signed 'coerce-32-bit-signed))
+ (else (if-not-expanded)))))))
+
+
diff --git a/v7/src/compiler/machines/vax/insmac.scm b/v7/src/compiler/machines/vax/insmac.scm
index 7cd4dba09..1cc128bec 100644
--- a/v7/src/compiler/machines/vax/insmac.scm
+++ b/v7/src/compiler/machines/vax/insmac.scm
@@ -1,6 +1,6 @@
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/insmac.scm,v 1.8 1987/08/22 22:44:15 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/insmac.scm,v 1.9 1987/08/23 07:56:16 jinx Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
@@ -82,16 +82,15 @@ MIT in each case. |#
(define (process-fields fields early?)
(if (and (null? (cdr fields))
(eq? (caar fields) 'VARIABLE-WIDTH))
- (expand-variable-width (car fields)
- (if early? 'EA-VALUE-EARLY 'EA-VALUE))
+ (expand-variable-width (car fields) early?)
(expand-fields fields
- (if early? 'EA-VALUE-EARLY 'EA-VALUE)
+ early?
(lambda (code size)
(if (not (zero? (remainder size 8)))
(error "process-fields: bad syllable size" size))
code))))
-(define (expand-variable-width field ea-value-operator)
+(define (expand-variable-width field early?)
(let ((binding (cadr field))
(clauses (cddr field)))
`(LIST
@@ -101,17 +100,17 @@ MIT in each case. |#
(map (lambda (clause)
(expand-fields
(cdr clause)
- ea-value-operator
+ early?
(lambda (code size)
(if (not (zero? (remainder size 8)))
(error "expand-variable-width: bad clause size" size))
`(,code ,size ,@(car clause)))))
clauses)))))
-(define (expand-fields fields ea-value-operator receiver)
+(define (expand-fields fields early? receiver)
(if (null? fields)
(receiver ''() 0)
- (expand-fields (cdr fields) ea-value-operator
+ (expand-fields (cdr fields) early?
(lambda (tail tail-size)
(case (caar fields)
((BYTE)
@@ -120,9 +119,13 @@ MIT in each case. |#
(lambda (code size)
(receiver code (+ size tail-size)))))
((OPERAND)
- (receiver `(APPEND-SYNTAX! (,ea-value-operator ,(caddar fields))
- ,tail)
- tail-size))
+ (receiver
+ `(APPEND-SYNTAX!
+ ,(if early?
+ `(EA-VALUE-EARLY '(cadar fields) ,(caddar fields))
+ `(EA-VALUE ,(caddar fields)))
+ ,tail)
+ tail-size))
((DISPLACEMENT)
(let ((desc (cadar fields)))
(let ((expression (cadr desc))