From: Matt Birkholz <matt@birchwood-abbey.net>
Date: Tue, 31 Jan 2017 00:31:22 +0000 (-0700)
Subject: svm: Fix handling of machine-constants that are larger than 32bits.
X-Git-Tag: mit-scheme-pucked-9.2.12~227^2~12
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=fefdb393fde5ddb2b778b6f54dee60d10d54be64;p=mit-scheme.git

svm: Fix handling of machine-constants that are larger than 32bits.
---

diff --git a/src/compiler/machines/svm/lapgen.scm b/src/compiler/machines/svm/lapgen.scm
index db68e654c..811e68fb4 100644
--- a/src/compiler/machines/svm/lapgen.scm
+++ b/src/compiler/machines/svm/lapgen.scm
@@ -250,14 +250,18 @@ USA.
        (let ((base (rtl:offset-base expression))
 	     (offset (rtl:offset-offset expression)))
 	 (if (rtl:register? base)
-	     (or (rtl:machine-constant? offset)
+	     (or (rtl:immediate-machine-constant? offset)
 		 (rtl:register? offset))
 	     (and (rtl:offset-address? base)
-		  (rtl:machine-constant? offset)
+		  (rtl:immediate-machine-constant? offset)
 		  (rtl:register? (rtl:offset-address-base base))
 		  (rtl:register? (rtl:offset-address-offset base)))))
        expression))
 
+(define (rtl:immediate-machine-constant? expression)
+  (and (rtl:machine-constant? expression)
+       (immediate-integer? (rtl:machine-constant-value offset))))
+
 (define (simple-offset->ea! offset)
   (let ((base (rtl:offset-base offset))
 	(offset (rtl:offset-offset offset)))
@@ -292,6 +296,7 @@ USA.
 	(rule-matcher ((? scale offset-operator?)
 		       (REGISTER (? base))
 		       (MACHINE-CONSTANT (? offset)))
+		      (QUALIFIER (immediate-integer? offset))
 		      (values scale
 			      (ea:offset (word-source base) offset scale)))
 	(rule-matcher ((? scale offset-operator?)
@@ -299,6 +304,7 @@ USA.
 			(REGISTER (? base))
 			(REGISTER (? index)))
 		       (MACHINE-CONSTANT (? offset)))
+		      (QUALIFIER (immediate-integer? offset))
 		      (values scale
 			      (ea:indexed (word-source base)
 					  offset scale
@@ -308,6 +314,7 @@ USA.
 			(REGISTER (? base))
 			(MACHINE-CONSTANT (? offset)))
 		       (REGISTER (? index)))
+		      (QUALIFIER (immediate-integer? offset))
 		      (values scale
 			      (ea:indexed (word-source base)
 					  offset scale*
diff --git a/src/compiler/machines/svm/machine.scm b/src/compiler/machines/svm/machine.scm
index 2bfea551d..ae6cd502a 100644
--- a/src/compiler/machines/svm/machine.scm
+++ b/src/compiler/machines/svm/machine.scm
@@ -114,10 +114,13 @@ USA.
 (define-inst copy-block size size-type from to)
 
 (define (load-immediate-operand? n)
-  (or (and (exact-integer? n)
-	   (<= signed-fixnum/lower-limit n) (< n signed-fixnum/upper-limit))
+  (or (immediate-integer? n)
       (flo:flonum? n)))
 
+(define (immediate-integer? n)
+  (and (exact-integer? n)
+       (<= signed-fixnum/lower-limit n) (< n signed-fixnum/upper-limit)))
+
 ;; TYPE and DATUM can be constants or registers; address is a register.
 (define-inst load-pointer target type address)
 (define-inst load-non-pointer target type datum)
diff --git a/src/compiler/machines/svm/rules.scm b/src/compiler/machines/svm/rules.scm
index a8b495de2..f67f119e2 100644
--- a/src/compiler/machines/svm/rules.scm
+++ b/src/compiler/machines/svm/rules.scm
@@ -81,8 +81,15 @@ USA.
 (define-rule statement
   (ASSIGN (REGISTER (? target))
 	  (MACHINE-CONSTANT (? n)))
+  (QUALIFIER (load-immediate-operand? n))
   (inst:load-immediate (word-target target) n))
 
+(define-rule statement
+  (ASSIGN (REGISTER (? target))
+	  (MACHINE-CONSTANT (? n)))
+  (QUALIFIER (not (load-immediate-operand? n)))
+  (load-constant (word-target target) n))
+
 (define-rule statement
   (ASSIGN (REGISTER (? target))
 	  (ENTRY:PROCEDURE (? label)))
@@ -539,6 +546,7 @@ USA.
 			 (REGISTER (? source1))
 			 (OBJECT->FLOAT (CONSTANT (? value)))
 			 (? overflow?)))
+  (QUALIFIER (flo:flonum? value))
   (let ((source1 (float-source source1))
 	(temp (float-temporary)))
     (LAP ,@(inst:load-immediate temp value)
@@ -1402,7 +1410,7 @@ USA.
   (CONS-POINTER (? type) (REGISTER (? datum register-known-value)))
   (QUALIFIER
    (and (rtl:object->datum? datum)
-	(rtl:constant-non-pointer? (rtl:object->datum-expression datum))))
+	(rtl:immediate-datum? (rtl:object->datum-expression datum))))
   (rtl:make-cons-non-pointer
    type
    (rtl:make-machine-constant
@@ -1415,12 +1423,14 @@ USA.
 
 (define-rule rewriting
   (OBJECT->DATUM (REGISTER (? source register-known-value)))
-  (QUALIFIER (rtl:constant-non-pointer? source))
+  (QUALIFIER (rtl:immediate-datum? source))
   (rtl:make-machine-constant (object-datum (rtl:constant-value source))))
 
-(define (rtl:constant-non-pointer? expression)
+(define (rtl:immediate-datum? expression)
   (and (rtl:constant? expression)
-       (object-non-pointer? (rtl:constant-value expression))))
+       (object-non-pointer? (rtl:constant-value expression))
+	(immediate-integer? (object-datum
+			     (rtl:constant-value expression)))))
 
 ;;; These rules are losers because there's no abstract way to cons a
 ;;; statement or a predicate without also getting some CFG structure.
@@ -1486,17 +1496,17 @@ USA.
 
 (define-rule rewriting
   (OBJECT->FIXNUM (REGISTER (? source register-known-value)))
-  (QUALIFIER (rtl:constant-fixnum? source))
+  (QUALIFIER (rtl:immediate-fixnum? source))
   (rtl:make-object->fixnum source))
 
 (define-rule rewriting
   (OBJECT->FIXNUM (CONSTANT (? value)))
-  (QUALIFIER (fix:fixnum? value))
+  (QUALIFIER (immediate-integer? value))
   (rtl:make-machine-constant value))
 
-(define (rtl:constant-fixnum? expression)
+(define (rtl:immediate-fixnum? expression)
   (and (rtl:constant? expression)
-       (fix:fixnum? (rtl:constant-value expression))
+       (immediate-integer? (rtl:constant-value expression))
        (rtl:constant-value expression)))
 
 ;;;; Flonum rewriting.