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 882c4863a0f24ae92031140dc934d4b054554059..eee0a7af73fb28aa31182c3c4b6162a63f100154 100644 (file)
--- 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)))
 \f
 ;;;; 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)))))
+\f
+;; 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 7cd4dba09327594b60ec0c1171a35ce9ace55526..1cc128bece6bbe45aec84fab56d6305b96e71d92 100644 (file)
--- 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)))))
 \f
-(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))