Extend fixnum and flonum operations with an overflow? flag.

diff --git a/v7/src/compiler/machines/bobcat/rules1.scm b/v7/src/compiler/machines/bobcat/rules1.scm
index 5e2918707cb6c8bae473451303ffaf894db0a9b6..7ab505a6f33a8912f5d62e9f939c7d51690e14e9 100644 (file)
--- a/v7/src/compiler/machines/bobcat/rules1.scm
+++ b/v7/src/compiler/machines/bobcat/rules1.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules1.scm,v 4.29 1989/11/15 02:40:21 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules1.scm,v 4.30 1989/12/05 20:52:00 jinx Exp $
 
 Copyright (c) 1988, 1989 Massachusetts Institute of Technology
 
@@ -404,10 +404,14 @@ MIT in each case. |#
   (QUALIFIER (pseudo-word? r))
   (LAP (MOV L ,(standard-register-reference r false true) (@A+ 5))))
 
+#|
+;; This seems like a fossil.  Removed by Jinx.
+
 (define-rule statement
   (ASSIGN (POST-INCREMENT (REGISTER 13) 1) (REGISTER (? r)))
   (QUALIFIER (pseudo-float? r))
   (LAP (FMOVE D ,(machine-register-reference r 'FLOAT) (@A+ 5))))
+|#
 
 (define-rule statement
   (ASSIGN (POST-INCREMENT (REGISTER 13) 1) (OFFSET (REGISTER (? r)) (? n)))
@@ -483,9 +487,10 @@ MIT in each case. |#
 ;;;; Fixnum Operations
 
 (define-rule statement
-  (ASSIGN (? target) (FIXNUM-1-ARG (? operator) (REGISTER (? source))))
+  (ASSIGN (? target) (FIXNUM-1-ARG (? operator) (REGISTER (? source)) (? overflow?)))
   (QUALIFIER (and (machine-operation-target? target)
                  (pseudo-register? source)))
+  overflow?                            ; ignored
   (reuse-and-load-machine-target! 'DATA
                                  target
                                  source
@@ -495,10 +500,12 @@ MIT in each case. |#
   (ASSIGN (? target)
          (FIXNUM-2-ARGS (? operator)
                         (REGISTER (? source1))
-                        (REGISTER (? source2))))
+                        (REGISTER (? source2))
+                        (? overflow?)))
   (QUALIFIER (and (machine-operation-target? target)
                  (pseudo-register? source1)
                  (pseudo-register? source2)))
+  overflow?                            ; ignored
   (two-arg-register-operation (fixnum-2-args/operate operator)
                              (fixnum-2-args/commutative? operator)
                              'DATA
@@ -515,18 +522,22 @@ MIT in each case. |#
   (ASSIGN (? target)
          (FIXNUM-2-ARGS (? operator)
                         (REGISTER (? source))
-                        (OBJECT->FIXNUM (CONSTANT (? constant)))))
+                        (OBJECT->FIXNUM (CONSTANT (? constant)))
+                        (? overflow?)))
   (QUALIFIER (and (machine-operation-target? target)
                  (pseudo-register? source)))
+  overflow?                            ; ignored
   (fixnum-2-args/register*constant operator target source constant))
 
 (define-rule statement
   (ASSIGN (? target)
          (FIXNUM-2-ARGS (? operator)
                         (OBJECT->FIXNUM (CONSTANT (? constant)))
-                        (REGISTER (? source))))
+                        (REGISTER (? source))
+                        (? overflow?)))
   (QUALIFIER (and (machine-operation-target? target)
                  (pseudo-register? source)))
+  overflow?                            ; ignored
   (if (fixnum-2-args/commutative? operator)
       (fixnum-2-args/register*constant operator target source constant)
       (fixnum-2-args/constant*register operator target constant source)))
@@ -561,34 +572,42 @@ MIT in each case. |#
   (ASSIGN (? target)
          (FIXNUM-2-ARGS MULTIPLY-FIXNUM
                         (OBJECT->FIXNUM (CONSTANT 4))
-                        (OBJECT->FIXNUM (REGISTER (? source)))))
+                        (OBJECT->FIXNUM (REGISTER (? source)))
+                        (? overflow?)))
   (QUALIFIER (and (machine-operation-target? target)
                  (pseudo-register? source)))
+  overflow?                            ; ignored
   (convert-index->fixnum/register target source))
 
 (define-rule statement
   (ASSIGN (? target)
          (FIXNUM-2-ARGS MULTIPLY-FIXNUM
                         (OBJECT->FIXNUM (REGISTER (? source)))
-                        (OBJECT->FIXNUM (CONSTANT 4))))
+                        (OBJECT->FIXNUM (CONSTANT 4))
+                        (? overflow?)))
   (QUALIFIER (and (machine-operation-target? target)
                  (pseudo-register? source)))
+  overflow?                            ; ignored
   (convert-index->fixnum/register target source))
 
 (define-rule statement
   (ASSIGN (? target)
          (FIXNUM-2-ARGS MULTIPLY-FIXNUM
                         (OBJECT->FIXNUM (CONSTANT 4))
-                        (OBJECT->FIXNUM (OFFSET (REGISTER (? r)) (? n)))))
+                        (OBJECT->FIXNUM (OFFSET (REGISTER (? r)) (? n)))
+                        (? overflow?)))
   (QUALIFIER (machine-operation-target? target))
+  overflow?                            ; ignored
   (convert-index->fixnum/offset target r n))
 
 (define-rule statement
   (ASSIGN (? target)
          (FIXNUM-2-ARGS MULTIPLY-FIXNUM
                         (OBJECT->FIXNUM (OFFSET (REGISTER (? r)) (? n)))
-                        (OBJECT->FIXNUM (CONSTANT 4))))
+                        (OBJECT->FIXNUM (CONSTANT 4))
+                        (? overflow?)))
   (QUALIFIER (machine-operation-target? target))
+  overflow?                            ; ignored
   (convert-index->fixnum/offset target r n))
 
 ;;; end (IF (<= SCHEME-TYPE-WIDTH 6) ...)
@@ -635,9 +654,10 @@ MIT in each case. |#
 
 (define-rule statement
   (ASSIGN (? target)
-         (FLONUM-1-ARG (? operator) (REGISTER (? source))))
+         (FLONUM-1-ARG (? operator) (REGISTER (? source)) (? overflow?)))
   (QUALIFIER (and (machine-operation-target? target)
                  (pseudo-float? source)))
+  overflow?                            ; ignored
   (let ((operate-on-target
         (lambda (target)
           ((flonum-1-arg/operate operator)
@@ -652,10 +672,12 @@ MIT in each case. |#
   (ASSIGN (? target)
          (FLONUM-2-ARGS (? operator)
                         (REGISTER (? source1))
-                        (REGISTER (? source2))))
+                        (REGISTER (? source2))
+                        (? overflow?)))
   (QUALIFIER (and (machine-operation-target? target)
                  (pseudo-float? source1)
                  (pseudo-float? source2)))
+  overflow?                            ; ignored
   (let ((source-reference
         (lambda (source) (standard-register-reference source 'FLOAT false))))
     (two-arg-register-operation (flonum-2-args/operate operator)

diff --git a/v7/src/compiler/rtlbase/rtlcon.scm b/v7/src/compiler/rtlbase/rtlcon.scm
index afc3b02ac17994244b4512d7b71af5558b1eb186..563e9113eef36ce94628d349452b30684ca100c6 100644 (file)
--- a/v7/src/compiler/rtlbase/rtlcon.scm
+++ b/v7/src/compiler/rtlbase/rtlcon.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlcon.scm,v 4.18 1989/10/26 07:38:28 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlcon.scm,v 4.19 1989/12/05 20:52:20 jinx Exp $
 
 Copyright (c) 1988, 1989 Massachusetts Institute of Technology
 
@@ -547,19 +547,19 @@ MIT in each case. |#
            (receiver (rtl:make-cons-pointer type datum))))))))
 \f
 (define-expression-method 'FIXNUM-2-ARGS
-  (lambda (receiver scfg-append! operator operand1 operand2)
+  (lambda (receiver scfg-append! operator operand1 operand2 overflow?)
     (expression-simplify operand1 scfg-append!
       (lambda (operand1)
        (expression-simplify operand2 scfg-append!
          (lambda (operand2)
            (receiver
-            (rtl:make-fixnum-2-args operator operand1 operand2))))))))
+            (rtl:make-fixnum-2-args operator operand1 operand2 overflow?))))))))
 
 (define-expression-method 'FIXNUM-1-ARG
-  (lambda (receiver scfg-append! operator operand)
+  (lambda (receiver scfg-append! operator operand overflow?)
     (expression-simplify operand scfg-append!
       (lambda (operand)
-       (receiver (rtl:make-fixnum-1-arg operator operand))))))
+       (receiver (rtl:make-fixnum-1-arg operator operand overflow?))))))
 
 (define-expression-method 'GENERIC-BINARY
   (lambda (receiver scfg-append! operator operand1 operand2)
@@ -577,15 +577,16 @@ MIT in each case. |#
        (receiver (rtl:make-generic-unary operator operand))))))
 
 (define-expression-method 'FLONUM-1-ARG
-  (lambda (receiver scfg-append! operator operand)
+  (lambda (receiver scfg-append! operator operand overflow?)
     (expression-simplify operand scfg-append!
       (lambda (s-operand)
        (receiver (rtl:make-flonum-1-arg
                   operator
-                  s-operand))))))
+                  s-operand
+                  overflow?))))))
 
 (define-expression-method 'FLONUM-2-ARGS
-  (lambda (receiver scfg-append! operator operand1 operand2)
+  (lambda (receiver scfg-append! operator operand1 operand2 overflow?)
     (expression-simplify operand1 scfg-append!
       (lambda (s-operand1)
        (expression-simplify operand2 scfg-append!
@@ -593,7 +594,8 @@ MIT in each case. |#
            (receiver (rtl:make-flonum-2-args
                       operator
                       s-operand1
-                      s-operand2))))))))
+                      s-operand2
+                      overflow?))))))))
 
 (define-expression-method 'FLOAT->OBJECT
   (lambda (receiver scfg-append! expression)

diff --git a/v7/src/compiler/rtlbase/rtlty1.scm b/v7/src/compiler/rtlbase/rtlty1.scm
index 2f98ae855b59754847293b7dea523b4aad8ab639..459ecebd9e845568f88a57e48ec7531e80369a1e 100644 (file)
--- a/v7/src/compiler/rtlbase/rtlty1.scm
+++ b/v7/src/compiler/rtlbase/rtlty1.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlty1.scm,v 4.14 1989/07/25 12:37:01 arthur Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlty1.scm,v 4.15 1989/12/05 20:51:48 jinx Exp $
 
 Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
 
@@ -63,14 +63,16 @@ MIT in each case. |#
 (define-rtl-expression offset-address rtl: register number)
 (define-rtl-expression unassigned rtl:)
 
-(define-rtl-expression fixnum-1-arg rtl: operator operand)
-(define-rtl-expression fixnum-2-args rtl: operator operand-1 operand-2)
+(define-rtl-expression fixnum-1-arg rtl: operator operand overflow?)
+(define-rtl-expression fixnum-2-args rtl: operator operand-1 operand-2
+  overflow?)
 
 (define-rtl-predicate fixnum-pred-1-arg % predicate operand)
 (define-rtl-predicate fixnum-pred-2-args % predicate operand-1 operand-2)
 
-(define-rtl-expression flonum-1-arg rtl: operator operand)
-(define-rtl-expression flonum-2-args rtl: operator operand-1 operand-2)
+(define-rtl-expression flonum-1-arg rtl: operator operand overflow?)
+(define-rtl-expression flonum-2-args rtl: operator operand-1 operand-2
+  overflow?)
 
 (define-rtl-predicate flonum-pred-1-arg % predicate operand)
 (define-rtl-predicate flonum-pred-2-args % predicate operand-1 operand-2)