From 37e9f5f9965d7bece4fe9411a9f95d3ddd223725 Mon Sep 17 00:00:00 2001 From: Arthur Gleckler Date: Tue, 5 Sep 1989 22:34:52 +0000 Subject: [PATCH] Create switch COMPILER:OPEN-CODE-FLOATING-POINT-ARITHMETIC? in order to ensure Bobcat floating-point open-coding is only attempted for Bobcats. --- v7/src/compiler/base/switch.scm | 4 +- v7/src/compiler/machines/bobcat/machin.scm | 7 +- v7/src/compiler/machines/vax/machin.scm | 8 +- v7/src/compiler/rtlgen/opncod.scm | 175 +++++++++++---------- 4 files changed, 106 insertions(+), 88 deletions(-) diff --git a/v7/src/compiler/base/switch.scm b/v7/src/compiler/base/switch.scm index 05136d4e3..a8b57ce60 100644 --- 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 455b79c9c..e62b7b391 100644 --- 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)) - ;;; Size of words. Some of the stuff in "assmd.scm" might want to + +(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 ec433622e..2084fa00b 100644 --- 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)) - ;;; Size of words. Some of the stuff in "assmd.scm" might want to + +;;; 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 c67173491..46e28f250 100644 --- 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. |# ;;; 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?)) + (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?)) + )) + ;;; Generic arithmetic (define (generic-binary-generator generic-op is-pred?) -- 2.25.1