From: Guillermo J. Rozas <edu/mit/csail/zurich/gjr>
Date: Wed, 16 Dec 1992 09:20:06 +0000 (+0000)
Subject: Improve the open coder for OBJECT-TYPE?
X-Git-Tag: 20090517-FFI~8650
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=c7462c845908429849d8e461c5225e79b59f3ef6;p=mit-scheme.git

Improve the open coder for OBJECT-TYPE?
---

diff --git a/v7/src/compiler/rtlgen/opncod.scm b/v7/src/compiler/rtlgen/opncod.scm
index 9b5e2160e..b6ad72b41 100644
--- a/v7/src/compiler/rtlgen/opncod.scm
+++ b/v7/src/compiler/rtlgen/opncod.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: opncod.scm,v 4.51 1992/12/16 07:32:20 gjr Exp $
+$Id: opncod.scm,v 4.52 1992/12/16 09:20:06 gjr Exp $
 
 Copyright (c) 1988-1992 Massachusetts Institute of Technology
 
@@ -570,10 +570,7 @@ MIT in each case. |#
 	     (simple-open-coder (open-code/type-test type) '(0) false)))))
     (simple-type-test 'PAIR? (ucode-type pair))
     (simple-type-test 'STRING? (ucode-type string))
-    (simple-type-test 'BIT-STRING? (ucode-type vector-1b)))
-
-  (define-open-coder/predicate 'OBJECT-TYPE?
-    (filter/type-code open-code/type-test 0 '(1) false)))
+    (simple-type-test 'BIT-STRING? (ucode-type vector-1b))))
 
 (define-open-coder/predicate 'EQ?
   (simple-open-coder
@@ -582,6 +579,36 @@ MIT in each case. |#
      (finish (rtl:make-eq-test (car expressions) (cadr expressions))))
    '(0 1)
    false))
+
+(define-open-coder/predicate 'OBJECT-TYPE?
+  (simple-open-coder
+   (lambda (combination expressions finish)
+     (let ((type (car expressions))
+	   (object (cadr expressions)))
+       (let* ((operand (rvalue-known-value type))
+	      (ok? (and operand
+			(rvalue/constant? operand)))
+	      (tag (and ok?
+			(constant-value operand))))
+	 (if (and ok?
+		(exact-nonnegative-integer? tag)
+		(< tag (expt 2 scheme-type-width)))
+	     (finish
+	      (rtl:make-type-test (rtl:make-object->type object)
+				  tag))
+	     (open-code:with-checks
+	      combination
+	      (list
+	       (open-code:type-check type (ucode-type fixnum))
+	       (open-code:range-check type (expt 2 scheme-type-width)))
+	      (finish
+	       (rtl:make-eq-test (rtl:make-object->datum type)
+				 (rtl:make-object->type object)))
+	      finish
+	      'OBJECT-TYPE?
+	      expressions)))))
+   '(0 1)
+   false))
 
 (let ((open-code/pair-cons
        (lambda (type)