Change conditionalization of the open-coding of floating-point

primitives.  It was previously done statically when the compiler was
built.  It is now done at the point of the call, so the switch can be
meaningfully fluid-let around a compilation.

Add the unsafe open-coding of integer->char.
Add a couple of optimizations to plus-fixnum and minus-fixnum.

diff --git a/v7/src/compiler/rtlgen/opncod.scm b/v7/src/compiler/rtlgen/opncod.scm
index efa3201f06c29e2aba5674333b25fe6508b25858..492522272a3530fd606ac9d19432c60d8c09eeef 100644 (file)
--- a/v7/src/compiler/rtlgen/opncod.scm
+++ b/v7/src/compiler/rtlgen/opncod.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/opncod.scm,v 4.46 1992/03/11 09:30:50 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/opncod.scm,v 4.47 1992/04/13 04:44:13 jinx Exp $
 
-Copyright (c) 1988-92 Massachusetts Institute of Technology
+Copyright (c) 1988-1992 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -260,6 +260,12 @@ MIT in each case. |#
     operands
     (values generator operand-indices internal-close-coding?)))
 
+(define (conditional-open-coder predicate open-coder)
+  (lambda (operands)
+    (if (predicate operands)
+       (open-coder operands)
+       (values false '() false))))
+
 (define (constant-filter predicate)
   (lambda (generator constant-index operand-indices internal-close-coding?)
     (lambda (operands)
@@ -758,6 +764,50 @@ MIT in each case. |#
 \f
 ;;;; Character/String Primitives
 
+(let* ((careless-range-open-coder
+       (lambda (generator indices internal-close-coding?)
+         (conditional-open-coder
+          (lambda (operands)
+            operands
+            (not compiler:generate-range-checks?))
+          (simple-open-coder generator indices internal-close-coding?))))
+
+       (define-open-coder
+       (lambda (name tsource tdest)
+         (define-open-coder/value name
+           (careless-range-open-coder
+            (lambda (combination expressions finish)
+              (let ((arg (car expressions)))
+                (open-code:with-checks
+                 combination
+                 (list (open-code:type-check arg tsource))
+                 (finish
+                  (rtl:make-cons-non-pointer
+                   (rtl:make-machine-constant tdest)
+                   (rtl:make-object->datum arg)))
+                 finish
+                 name
+                 expressions)))
+            '(0)
+            internal-close-coding-for-type-checks)))))
+
+  (define-open-coder 'INTEGER->CHAR
+    (ucode-type fixnum)
+    (ucode-type character))
+
+  #|
+  ;; These do the wrong thing with control characters.
+
+  (define-open-coder 'ASCII->CHAR
+    (ucode-type fixnum)
+    (ucode-type character))
+
+  (define-open-coder 'CHAR->ASCII
+    (ucode-type character)
+    (ucode-type fixnum))
+  |#
+  )
+
 (define-open-coder/value 'CHAR->INTEGER
   (simple-open-coder
    (lambda (combination expressions finish)
@@ -774,7 +824,7 @@ MIT in each case. |#
        expressions)))
    '(0)
    internal-close-coding-for-type-checks))
-
+\f
 (define-open-coder/value 'STRING-REF
   (simple-open-coder
    (string-memory-reference 'STRING-REF (ucode-type string) false
@@ -815,6 +865,68 @@ MIT in each case. |#
 \f
 ;;;; Fixnum Arithmetic
 
+(let* ((one-operand
+       (lambda (operator operand)
+         (rtl:make-fixnum->object
+          (rtl:make-fixnum-1-arg
+           operator
+           (rtl:make-object->fixnum operand)
+           false))))
+
+       (two-operand
+       (lambda (operator comm? pos neg)
+         (define-open-coder/value operator
+           (simple-open-coder
+            (lambda (combination expressions finish)
+              (define (default)
+                (rtl:make-fixnum->object
+                 (rtl:make-fixnum-2-args
+                  operator
+                  (rtl:make-object->fixnum (car expressions))
+                  (rtl:make-object->fixnum (cadr expressions))
+                  false)))
+
+              ;; Guarantee that (fix:-1+ x) and (fix:- x 1)
+              ;; generate identical code, etc.
+              combination
+              (finish
+               (cond ((and comm? (rtl:constant? (car expressions)))
+                      (case (rtl:constant-value (car expressions))
+                        ((0) (cadr expressions))
+                        ((1) (one-operand pos (cadr expressions)))
+                        ((-1) (one-operand neg (cadr expressions)))
+                        (else (default))))
+                     ((rtl:constant? (cadr expressions))
+                      (case (rtl:constant-value (cadr expressions))
+                        ((0) (car expressions))
+                        ((1) (one-operand pos (car expressions)))
+                        ((-1) (one-operand neg (car expressions)))
+                        (else (default))))
+                     (else
+                      (default)))))
+            '(0 1)
+            false)))))
+
+  (two-operand 'PLUS-FIXNUM true 'ONE-PLUS-FIXNUM 'MINUS-ONE-PLUS-FIXNUM)
+  (two-operand 'MINUS-FIXNUM false 'MINUS-ONE-PLUS-FIXNUM 'ONE-PLUS-FIXNUM))
+
+(for-each (lambda (fixnum-operator)
+           (define-open-coder/value fixnum-operator
+             (simple-open-coder
+              (lambda (combination expressions finish)
+                combination
+                (finish
+                 (rtl:make-fixnum->object
+                  (rtl:make-fixnum-1-arg
+                   fixnum-operator
+                   (rtl:make-object->fixnum (car expressions))
+                   false))))
+              '(0)
+              false)))
+         '(ONE-PLUS-FIXNUM
+           MINUS-ONE-PLUS-FIXNUM
+           FIXNUM-NOT))
+\f
 (for-each (lambda (fixnum-operator)
            (define-open-coder/value fixnum-operator
              (simple-open-coder
@@ -829,9 +941,7 @@ MIT in each case. |#
                    false))))
               '(0 1)
               false)))
-         '(PLUS-FIXNUM
-           MINUS-FIXNUM
-           MULTIPLY-FIXNUM
+         '(MULTIPLY-FIXNUM
            ;; DIVIDE-FIXNUM
            GCD-FIXNUM
            FIXNUM-QUOTIENT
@@ -842,23 +952,6 @@ MIT in each case. |#
            FIXNUM-XOR
            FIXNUM-LSH))
 
-(for-each (lambda (fixnum-operator)
-           (define-open-coder/value fixnum-operator
-             (simple-open-coder
-              (lambda (combination expressions finish)
-                combination
-                (finish
-                 (rtl:make-fixnum->object
-                  (rtl:make-fixnum-1-arg
-                   fixnum-operator
-                   (rtl:make-object->fixnum (car expressions))
-                   false))))
-              '(0)
-              false)))
-         '(ONE-PLUS-FIXNUM
-           MINUS-ONE-PLUS-FIXNUM
-           FIXNUM-NOT))
-\f
 (for-each (lambda (fixnum-pred first-zero second-zero)
            (define-open-coder/predicate fixnum-pred
              (simple-open-coder
@@ -903,102 +996,109 @@ MIT in each case. |#
 \f
 ;;; Floating Point Arithmetic
 
-(if compiler:open-code-floating-point-arithmetic?
-    (begin
-      (for-each
-       (lambda (flonum-operator)
-        (define-open-coder/value flonum-operator
-          (simple-open-coder
-           (lambda (combination expressions finish)
-             (let ((argument (car expressions)))
-               (open-code:with-checks
-                combination
-                (list (open-code:type-check argument (ucode-type flonum)))
-                (finish (rtl:make-float->object
-                         (rtl:make-flonum-1-arg
-                          flonum-operator
-                          (rtl:make-object->float argument)
-                          false)))
-                finish
-                flonum-operator
-                expressions)))
-           '(0)
-           internal-close-coding-for-type-checks)))
-       '(FLONUM-NEGATE FLONUM-ABS FLONUM-SIN FLONUM-COS FLONUM-TAN FLONUM-ASIN
-        FLONUM-ACOS FLONUM-ATAN FLONUM-EXP FLONUM-LOG FLONUM-SQRT FLONUM-ROUND
-        FLONUM-TRUNCATE))
-
-      (for-each
-       (lambda (flonum-operator)
-        (define-open-coder/value flonum-operator
-          (simple-open-coder
-           (lambda (combination expressions finish)
-             (let ((arg1 (car expressions))
-                   (arg2 (cadr expressions)))
-               (open-code:with-checks
-                combination
-                (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-object->float arg1)
-                   (rtl:make-object->float arg2)
-                   false)))
-                finish
-                flonum-operator
-                expressions)))
-           '(0 1)
-           internal-close-coding-for-type-checks)))
-       '(FLONUM-ADD FLONUM-SUBTRACT FLONUM-MULTIPLY FLONUM-DIVIDE))
+;; On some machines, there are optional floating-point co-processors,
+;; The decision of whether to open-code floating-point arithmetic or
+;; not should be made at the last moment, not when the compiler is
+;; built.
+
+(define (floating-point-open-coder generator indices internal-close-coding?)
+  (conditional-open-coder
+   (lambda (operands)
+     operands                          ; ignored
+     compiler:open-code-floating-point-arithmetic?)
+   (simple-open-coder generator indices internal-close-coding?)))
+
+(for-each
+ (lambda (flonum-operator)
+   (define-open-coder/value flonum-operator
+     (floating-point-open-coder
+      (lambda (combination expressions finish)
+       (let ((argument (car expressions)))
+         (open-code:with-checks
+          combination
+          (list (open-code:type-check argument (ucode-type flonum)))
+          (finish (rtl:make-float->object
+                   (rtl:make-flonum-1-arg
+                    flonum-operator
+                    (rtl:make-object->float argument)
+                    false)))
+          finish
+          flonum-operator
+          expressions)))
+      '(0)
+      internal-close-coding-for-type-checks)))
+ '(FLONUM-NEGATE FLONUM-ABS FLONUM-SIN FLONUM-COS FLONUM-TAN FLONUM-ASIN
+   FLONUM-ACOS FLONUM-ATAN FLONUM-EXP FLONUM-LOG FLONUM-SQRT FLONUM-ROUND
+   FLONUM-TRUNCATE))
+
+(for-each
+ (lambda (flonum-operator)
+   (define-open-coder/value flonum-operator
+     (floating-point-open-coder
+      (lambda (combination expressions finish)
+       (let ((arg1 (car expressions))
+             (arg2 (cadr expressions)))
+         (open-code:with-checks
+          combination
+          (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-object->float arg1)
+             (rtl:make-object->float arg2)
+             false)))
+          finish
+          flonum-operator
+          expressions)))
+      '(0 1)
+      internal-close-coding-for-type-checks)))
+ '(FLONUM-ADD FLONUM-SUBTRACT FLONUM-MULTIPLY FLONUM-DIVIDE))
 \f
-      (for-each
-       (lambda (flonum-pred)
-        (define-open-coder/predicate flonum-pred
-          (simple-open-coder
-           (lambda (combination expressions finish)
-             (let ((argument (car expressions)))
-               (open-code:with-checks
-                combination
-                (list (open-code:type-check argument (ucode-type flonum)))
-                (finish
-                 (rtl:make-flonum-pred-1-arg
-                  flonum-pred
-                  (rtl:make-object->float argument)))
-                (lambda (expression)
-                  (finish (rtl:make-true-test expression)))
-                flonum-pred
-                expressions)))
-           '(0)
-           internal-close-coding-for-type-checks)))
-       '(FLONUM-ZERO? FLONUM-POSITIVE? FLONUM-NEGATIVE?))
-
-      (for-each
-       (lambda (flonum-pred)
-        (define-open-coder/predicate flonum-pred
-          (simple-open-coder
-           (lambda (combination expressions finish)
-             (let ((arg1 (car expressions))
-                   (arg2 (cadr expressions)))
-               (open-code:with-checks
-                combination
-                (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-object->float arg1)
-                         (rtl:make-object->float arg2)))
-                (lambda (expression)
-                  (finish (rtl:make-true-test expression)))
-                flonum-pred
-                expressions)))
-           '(0 1)
-           internal-close-coding-for-type-checks)))
-       '(FLONUM-EQUAL? FLONUM-LESS? FLONUM-GREATER?))
-
-      ;; end COMPILER:OPEN-CODE-FLOATING-POINT-ARITHMETIC?
-      ))
+(for-each
+ (lambda (flonum-pred)
+   (define-open-coder/predicate flonum-pred
+     (floating-point-open-coder
+      (lambda (combination expressions finish)
+       (let ((argument (car expressions)))
+         (open-code:with-checks
+          combination
+          (list (open-code:type-check argument (ucode-type flonum)))
+          (finish
+           (rtl:make-flonum-pred-1-arg
+            flonum-pred
+            (rtl:make-object->float argument)))
+          (lambda (expression)
+            (finish (rtl:make-true-test expression)))
+          flonum-pred
+          expressions)))
+      '(0)
+      internal-close-coding-for-type-checks)))
+ '(FLONUM-ZERO? FLONUM-POSITIVE? FLONUM-NEGATIVE?))
+
+(for-each
+ (lambda (flonum-pred)
+   (define-open-coder/predicate flonum-pred
+     (floating-point-open-coder
+      (lambda (combination expressions finish)
+       (let ((arg1 (car expressions))
+             (arg2 (cadr expressions)))
+         (open-code:with-checks
+          combination
+          (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-object->float arg1)
+                   (rtl:make-object->float arg2)))
+          (lambda (expression)
+            (finish (rtl:make-true-test expression)))
+          flonum-pred
+          expressions)))
+      '(0 1)
+      internal-close-coding-for-type-checks)))
+ '(FLONUM-EQUAL? FLONUM-LESS? FLONUM-GREATER?))
 \f
 ;;; Generic arithmetic