Create switch COMPILER:OPEN-CODE-FLOATING-POINT-ARITHMETIC? in order to ensure

Bobcat floating-point open-coding is only attempted for Bobcats.

diff --git a/v7/src/compiler/base/switch.scm b/v7/src/compiler/base/switch.scm
index 05136d4e321ddaae79b14e6674a20797ede3897a..a8b57ce60fc90393d0c64f63ef0f65b4101191a8 100644 (file)
--- a/v7/src/compiler/base/switch.scm
+++ b/v7/src/compiler/base/switch.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/switch.scm,v 4.11 1989/08/21 19:32:29 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/switch.scm,v 4.12 1989/09/05 22:33:50 arthur Exp $
 
 Copyright (c) 1988, 1989 Massachusetts Institute of Technology
 
@@ -57,6 +57,8 @@ MIT in each case. |#
 (define compiler:generate-range-checks? false)
 (define compiler:generate-type-checks? false)
 (define compiler:open-code-flonum-checks? false)
+;; The switch COMPILER:OPEN-CODE-FLOATING-POINT-ARITHMETIC? is in machin.scm.
+
 ;;; Nary switches
 
 (define compiler:package-optimization-level

diff --git a/v7/src/compiler/machines/bobcat/machin.scm b/v7/src/compiler/machines/bobcat/machin.scm
index 455b79c9ce823126da39d63a9351d1315ca9668d..e62b7b391f9a31bd0ec9d7695bb8be854e44f39a 100644 (file)
--- a/v7/src/compiler/machines/bobcat/machin.scm
+++ b/v7/src/compiler/machines/bobcat/machin.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/machin.scm,v 4.16 1989/08/28 18:34:05 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/machin.scm,v 4.17 1989/09/05 22:34:16 arthur Exp $
 
 Copyright (c) 1988, 1989 Massachusetts Institute of Technology
 
@@ -35,7 +35,10 @@ MIT in each case. |#
 ;;;; Machine Model for 68020
 
 (declare (usual-integrations))
-\f;;; Size of words.  Some of the stuff in "assmd.scm" might want to
+\f
+(define compiler:open-code-floating-point-arithmetic? true)
+
+;;; Size of words.  Some of the stuff in "assmd.scm" might want to
 ;;; come here.
 
 (define-integrable endianness 'BIG)

diff --git a/v7/src/compiler/machines/vax/machin.scm b/v7/src/compiler/machines/vax/machin.scm
index ec433622ecee58c8005603d23de8d0c1c25e37aa..2084fa00b3efb51b6b9c5c1e1b7750f8cad1f65d 100644 (file)
--- a/v7/src/compiler/machines/vax/machin.scm
+++ b/v7/src/compiler/machines/vax/machin.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/machin.scm,v 4.5 1989/05/17 20:30:31 jinx Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/machin.scm,v 4.6 1989/09/05 22:34:32 arthur Rel $
 $MC68020-Header: machin.scm,v 4.14 89/01/18 09:58:56 GMT cph Exp $
 
 Copyright (c) 1987, 1989 Massachusetts Institute of Technology
@@ -36,7 +36,11 @@ MIT in each case. |#
 ;;;; Machine Model for DEC Vax
 
 (declare (usual-integrations))
-\f;;; Size of words.  Some of the stuff in "assmd.scm" might want to
+\f
+;;; Floating-point open-coding not implemented for VAXen.
+(define compiler:open-code-floating-point-arithmetic? false)
+
+;;; Size of words.  Some of the stuff in "assmd.scm" might want to
 ;;; come here.
 
 (define-integrable addressing-granularity 8)

diff --git a/v7/src/compiler/rtlgen/opncod.scm b/v7/src/compiler/rtlgen/opncod.scm
index c671734914320d12edfb4643c36d6addf4f752ee..46e28f25067ad08119040603eec75c3c6dac0a9f 100644 (file)
--- a/v7/src/compiler/rtlgen/opncod.scm
+++ b/v7/src/compiler/rtlgen/opncod.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/opncod.scm,v 4.30 1989/07/25 12:32:50 arthur Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/opncod.scm,v 4.31 1989/09/05 22:34:52 arthur Exp $
 
 Copyright (c) 1988, 1989 Massachusetts Institute of Technology
 
@@ -717,92 +717,101 @@ MIT in each case. |#
 \f
 ;;; Floating Point Arithmetic
 
-(for-each (lambda (flonum-operator)
-           (define-open-coder/value flonum-operator
-             (simple-open-coder
-              (lambda (context expressions finish)
-                (let ((argument (car expressions)))
-                  (open-code:with-checks
-                   context
-                   (list (open-code:type-check argument (ucode-type flonum)))
-                   (finish (rtl:make-float->object
-                            (rtl:make-flonum-1-arg
-                             flonum-operator
-                             (rtl:make-@address->float
-                              (rtl:make-object->address argument)))))
-                   finish
-                   flonum-operator
-                   expressions)))
-              '(0))))
-         '(SINE-FLONUM COSINE-FLONUM ATAN-FLONUM EXP-FLONUM
-           LN-FLONUM SQRT-FLONUM TRUNCATE-FLONUM))
+(if compiler:open-code-floating-point-arithmetic?
+    (begin
 
-(for-each (lambda (flonum-operator)
-           (define-open-coder/value flonum-operator
-             (simple-open-coder
-              (lambda (context expressions finish)
-                (let ((arg1 (car expressions))
-                      (arg2 (cadr expressions)))
-                  (open-code:with-checks
-                   context
-                   (list (open-code:type-check arg1 (ucode-type flonum))
-                         (open-code:type-check arg2 (ucode-type flonum)))
-                   (finish
-                    (rtl:make-float->object
-                     (rtl:make-flonum-2-args
-                      flonum-operator
-                      (rtl:make-@address->float
-                        (rtl:make-object->address arg1))
-                      (rtl:make-@address->float
-                        (rtl:make-object->address arg2)))))
-                   finish
+      (for-each
+       (lambda (flonum-operator)
+        (define-open-coder/value flonum-operator
+          (simple-open-coder
+           (lambda (context expressions finish)
+             (let ((argument (car expressions)))
+               (open-code:with-checks
+                context
+                (list (open-code:type-check argument (ucode-type flonum)))
+                (finish (rtl:make-float->object
+                         (rtl:make-flonum-1-arg
+                          flonum-operator
+                          (rtl:make-@address->float
+                                    (rtl:make-object->address argument)))))
+                finish
+                flonum-operator
+                expressions)))
+           '(0))))
+       '(SINE-FLONUM COSINE-FLONUM ATAN-FLONUM EXP-FLONUM
+                    LN-FLONUM SQRT-FLONUM TRUNCATE-FLONUM))
+
+      (for-each
+       (lambda (flonum-operator)
+        (define-open-coder/value flonum-operator
+          (simple-open-coder
+           (lambda (context expressions finish)
+             (let ((arg1 (car expressions))
+                   (arg2 (cadr expressions)))
+               (open-code:with-checks
+                context
+                (list (open-code:type-check arg1 (ucode-type flonum))
+                      (open-code:type-check arg2 (ucode-type flonum)))
+                (finish
+                 (rtl:make-float->object
+                  (rtl:make-flonum-2-args
                    flonum-operator
-                   expressions)))
-              '(0 1))))
-         '(PLUS-FLONUM MINUS-FLONUM MULTIPLY-FLONUM DIVIDE-FLONUM))
+                   (rtl:make-@address->float
+                             (rtl:make-object->address arg1))
+                   (rtl:make-@address->float
+                             (rtl:make-object->address arg2)))))
+                finish
+                flonum-operator
+                expressions)))
+           '(0 1))))
+       '(PLUS-FLONUM MINUS-FLONUM MULTIPLY-FLONUM DIVIDE-FLONUM))
 
-(for-each (lambda (flonum-pred)
-           (define-open-coder/predicate flonum-pred
-             (simple-open-coder
-              (lambda (context expressions finish)
-                (let ((argument (car expressions)))
-                  (open-code:with-checks
-                   context
-                   (list (open-code:type-check argument (ucode-type flonum)))
-                   (finish
-                    (rtl:make-flonum-pred-1-arg
-                     flonum-pred
-                     (rtl:make-@address->float
-                       (rtl:make-object->address argument))))
-                   (lambda (expression)
-                     (finish (rtl:make-true-test expression)))
-                   flonum-pred
-                   expressions)))
-              '(0))))
-         '(ZERO-FLONUM? POSITIVE-FLONUM? NEGATIVE-FLONUM?))
+      (for-each
+       (lambda (flonum-pred)
+        (define-open-coder/predicate flonum-pred
+          (simple-open-coder
+           (lambda (context expressions finish)
+             (let ((argument (car expressions)))
+               (open-code:with-checks
+                context
+                (list (open-code:type-check argument (ucode-type flonum)))
+                (finish
+                 (rtl:make-flonum-pred-1-arg
+                  flonum-pred
+                  (rtl:make-@address->float
+                            (rtl:make-object->address argument))))
+                (lambda (expression)
+                  (finish (rtl:make-true-test expression)))
+                flonum-pred
+                expressions)))
+           '(0))))
+       '(ZERO-FLONUM? POSITIVE-FLONUM? NEGATIVE-FLONUM?))
 
-(for-each (lambda (flonum-pred)
-           (define-open-coder/predicate flonum-pred
-             (simple-open-coder
-              (lambda (context expressions finish)
-                (let ((arg1 (car expressions))
-                      (arg2 (cadr expressions)))
-                  (open-code:with-checks
-                   context
-                   (list (open-code:type-check arg1 (ucode-type flonum))
-                         (open-code:type-check arg2 (ucode-type flonum)))
-                   (finish (rtl:make-flonum-pred-2-args
-                            flonum-pred
-                            (rtl:make-@address->float
-                              (rtl:make-object->address arg1))
-                            (rtl:make-@address->float
-                              (rtl:make-object->address arg2))))
-                   (lambda (expression)
-                     (finish (rtl:make-true-test expression)))
-                   flonum-pred
-                   expressions)))
-              '(0 1))))
-         '(EQUAL-FLONUM? LESS-THAN-FLONUM? GREATER-THAN-FLONUM?))\f
+      (for-each
+       (lambda (flonum-pred)
+        (define-open-coder/predicate flonum-pred
+          (simple-open-coder
+           (lambda (context expressions finish)
+             (let ((arg1 (car expressions))
+                   (arg2 (cadr expressions)))
+               (open-code:with-checks
+                context
+                (list (open-code:type-check arg1 (ucode-type flonum))
+                      (open-code:type-check arg2 (ucode-type flonum)))
+                (finish (rtl:make-flonum-pred-2-args
+                         flonum-pred
+                         (rtl:make-@address->float
+                                   (rtl:make-object->address arg1))
+                         (rtl:make-@address->float
+                                   (rtl:make-object->address arg2))))
+                (lambda (expression)
+                  (finish (rtl:make-true-test expression)))
+                flonum-pred
+                expressions)))
+           '(0 1))))
+       '(EQUAL-FLONUM? LESS-THAN-FLONUM? GREATER-THAN-FLONUM?))
+      ))
+\f
 ;;; Generic arithmetic
 
 (define (generic-binary-generator generic-op is-pred?)