From 60aaf39ee8527d3b58b1d8fa53584e371510cce3 Mon Sep 17 00:00:00 2001
From: Stephen Adams <edu/mit/csail/zurich/adams>
Date: Tue, 15 Jul 1997 03:01:26 +0000
Subject: [PATCH] Added open-coding for the primitive INDEX-FIXNUM?

---
 v7/src/compiler/machines/C/rules2.scm        | 16 +++++++++++++++-
 v7/src/compiler/machines/i386/rules2.scm     | 16 ++++++++++++++--
 v7/src/compiler/machines/spectrum/rules2.scm | 17 +++++++++++++++--
 v7/src/compiler/rtlbase/rtlcon.scm           | 14 +++++++++++++-
 v7/src/compiler/rtlgen/opncod.scm            | 10 +++++++++-
 v7/src/compiler/rtlopt/rcse1.scm             |  9 ++++++++-
 v7/src/compiler/rtlopt/rinvex.scm            | 12 +++++++++++-
 v7/src/microcode/liarc.h                     |  4 +++-
 8 files changed, 88 insertions(+), 10 deletions(-)

diff --git a/v7/src/compiler/machines/C/rules2.scm b/v7/src/compiler/machines/C/rules2.scm
index aeb18f0e3..8e702e0ac 100644
--- a/v7/src/compiler/machines/C/rules2.scm
+++ b/v7/src/compiler/machines/C/rules2.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: rules2.scm,v 1.1 1993/06/08 06:13:32 gjr Exp $
+$Id: rules2.scm,v 1.2 1997/07/15 03:01:15 adams Exp $
 
 Copyright (c) 1992 Massachusetts Institute of Technology
 
@@ -98,6 +98,20 @@ MIT in each case. |#
 	    ";\n\t")))
     (LAP)))
 
+(define-rule predicate
+  ;; Branch if virtual register contains the specified type number
+  (PRED-1-ARG INDEX-FIXNUM?
+	      (REGISTER (? source)))
+  (let ((source (standard-source! source 'ULONG)))
+    (set-current-branches!
+     (lambda (if-true-label)
+       (LAP "if (INDEX_FIXNUM_P" ,source ")\n\t  goto " ,if-true-label
+	    ";\n\t"))
+     (lambda (if-false-label)
+       (LAP "if (!(INDEX_FIXNUM_P" ,source "))\n\t  goto " ,if-false-label
+	    ";\n\t")))
+    (LAP)))
+
 (define (eq-test/constant constant source)
   (let ((source (standard-source! source 'SCHEME_OBJECT)))
     (set-current-branches!
diff --git a/v7/src/compiler/machines/i386/rules2.scm b/v7/src/compiler/machines/i386/rules2.scm
index f52a3705a..38a2109ce 100644
--- a/v7/src/compiler/machines/i386/rules2.scm
+++ b/v7/src/compiler/machines/i386/rules2.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: rules2.scm,v 1.7 1993/08/26 18:00:26 gjr Exp $
+$Id: rules2.scm,v 1.8 1997/07/15 02:59:36 adams Exp $
 
 Copyright (c) 1992-1993 Massachusetts Institute of Technology
 
@@ -137,4 +137,16 @@ MIT in each case. |#
 			 (MACHINE-CONSTANT (? datum))))
   (set-equal-branches!)
   (LAP (CMP W ,(offset->reference! expression)
-	    (&U ,(make-non-pointer-literal type datum)))))
\ No newline at end of file
+	    (&U ,(make-non-pointer-literal type datum)))))
+
+
+;; Combine tests for fixnum and non-negative by extracting the type
+;; bits and the sign bit.
+
+(define-rule predicate
+  (PRED-1-ARG INDEX-FIXNUM?
+	      (REGISTER (? register)))
+  (let ((temp (standard-move-to-temporary! register)))
+    (set-equal-branches!)
+    (LAP (SHR W ,temp (& ,(- scheme-datum-width 1)))
+	 (CMP B ,temp (&U ,(* 2 (ucode-type fixnum)))))))
diff --git a/v7/src/compiler/machines/spectrum/rules2.scm b/v7/src/compiler/machines/spectrum/rules2.scm
index 1fe383927..6cd9d041d 100644
--- a/v7/src/compiler/machines/spectrum/rules2.scm
+++ b/v7/src/compiler/machines/spectrum/rules2.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/spectrum/rules2.scm,v 4.13 1992/02/18 16:09:39 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/spectrum/rules2.scm,v 4.14 1997/07/15 03:00:59 adams Exp $
 $MC68020-Header: rules2.scm,v 4.12 90/01/18 22:44:04 GMT cph Exp $
 
 Copyright (c) 1988-1992 Massachusetts Institute of Technology
@@ -90,4 +90,17 @@ MIT in each case. |#
 (define-rule predicate
   ;; Branch if virtual register contains the specified type number
   (TYPE-TEST (REGISTER (? register)) (? type))
-  (compare-immediate '= type (standard-source! register)))
\ No newline at end of file
+  (compare-immediate '= type (standard-source! register)))
+
+
+;; Combine tests for fixnum and non-negative by extracting the type
+;; bits and the sign bit.
+
+(define-rule predicate
+  (PRED-1-ARG INDEX-FIXNUM?
+	      (REGISTER (? source)))
+  (let ((src (standard-source! source)))
+    (let ((temp (standard-temporary!)))
+      (LAP (EXTRU () ,src ,(- scheme-type-width 0) ,(+ scheme-type-width 1)
+		  ,temp)
+	   ,@(compare-immediate '= (* 2 (ucode-type fixnum)) temp)))))
diff --git a/v7/src/compiler/rtlbase/rtlcon.scm b/v7/src/compiler/rtlbase/rtlcon.scm
index b74ea0dd2..2b3b9fae5 100644
--- a/v7/src/compiler/rtlbase/rtlcon.scm
+++ b/v7/src/compiler/rtlbase/rtlcon.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: rtlcon.scm,v 4.27 1993/07/09 00:15:05 gjr Exp $
+$Id: rtlcon.scm,v 4.28 1997/07/15 03:00:32 adams Exp $
 
 Copyright (c) 1988-1993 Massachusetts Institute of Technology
 
@@ -88,6 +88,18 @@ MIT in each case. |#
     (lambda (expression)
       (%make-type-test expression type))))
 
+(define (rtl:make-pred-1-arg predicate operand)
+  (expression-simplify-for-predicate operand
+    (lambda (operand)
+      (%make-pred-1-arg predicate operand))))
+
+(define (rtl:make-pred-2-args predicate operand1 operand2)
+  (expression-simplify-for-predicate operand1
+    (lambda (operand1)
+      (expression-simplify-for-predicate operand2
+	(lambda (operand2)
+	  (%make-pred-2-args predicate operand1 operand2))))))
+
 (define (rtl:make-unassigned-test expression)
   (rtl:make-eq-test
    expression
diff --git a/v7/src/compiler/rtlgen/opncod.scm b/v7/src/compiler/rtlgen/opncod.scm
index fa8c25078..b02e4c04f 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.63 1997/03/30 23:26:29 cph Exp $
+$Id: opncod.scm,v 4.64 1997/07/15 03:00:04 adams Exp $
 
 Copyright (c) 1988-97 Massachusetts Institute of Technology
 
@@ -631,6 +631,14 @@ MIT in each case. |#
      (finish (rtl:make-eq-test (car expressions) (cadr expressions))))
    '(0 1)
    false))
+
+(define-open-coder/predicate 'INDEX-FIXNUM?
+  (simple-open-coder
+   (lambda (combination expressions finish)
+     combination
+     (finish (rtl:make-pred-1-arg 'INDEX-FIXNUM? (car expressions))))
+   '(0)
+   false))
 
 (define-open-coder/predicate 'OBJECT-TYPE?
   (lambda (operands)
diff --git a/v7/src/compiler/rtlopt/rcse1.scm b/v7/src/compiler/rtlopt/rcse1.scm
index 18567d2ff..71d253626 100644
--- a/v7/src/compiler/rtlopt/rcse1.scm
+++ b/v7/src/compiler/rtlopt/rcse1.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: rcse1.scm,v 4.22 1993/07/01 03:29:00 gjr Exp $
+$Id: rcse1.scm,v 4.23 1997/07/15 03:00:25 adams Exp $
 
 Copyright (c) 1988-1993 Massachusetts Institute of Technology
 
@@ -296,6 +296,13 @@ MIT in each case. |#
   rtl:eq-test-expression-1 rtl:set-eq-test-expression-1!
   rtl:eq-test-expression-2 rtl:set-eq-test-expression-2!)
 
+(define-trivial-one-arg-method 'PRED-1-ARG
+  rtl:pred-1-arg-operand rtl:set-pred-1-arg-operand!)
+
+(define-trivial-two-arg-method 'PRED-2-ARGS
+  rtl:pred-2-args-operand-1 rtl:set-pred-2-args-operand-1!
+  rtl:pred-2-args-operand-2 rtl:set-pred-2-args-operand-2!)
+
 (define-trivial-one-arg-method 'FIXNUM-PRED-1-ARG
   rtl:fixnum-pred-1-arg-operand rtl:set-fixnum-pred-1-arg-operand!)
 
diff --git a/v7/src/compiler/rtlopt/rinvex.scm b/v7/src/compiler/rtlopt/rinvex.scm
index 706151af5..ffa9da25d 100644
--- a/v7/src/compiler/rtlopt/rinvex.scm
+++ b/v7/src/compiler/rtlopt/rinvex.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rinvex.scm,v 1.7 1992/12/16 09:18:30 gjr Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rinvex.scm,v 1.8 1997/07/15 03:00:17 adams Exp $
 
 Copyright (c) 1989-1992 Massachusetts Institute of Technology
 
@@ -276,6 +276,10 @@ MIT in each case. |#
   rtl:type-test-expression
   rtl:set-type-test-expression!)
 
+(define-one-arg-method 'PRED-1-ARG
+  rtl:pred-1-arg-operand
+  rtl:set-pred-1-arg-operand!)
+
 (define-one-arg-method 'INVOCATION:CACHE-REFERENCE
   rtl:invocation:cache-reference-name
   rtl:set-invocation:cache-reference-name!)
@@ -324,6 +328,12 @@ MIT in each case. |#
   rtl:eq-test-expression-2
   rtl:set-eq-test-expression-2!)
 
+(define-two-arg-method 'PRED-2-ARGS
+  rtl:pred-2-args-operand-1
+  rtl:set-pred-2-args-operand-1!
+  rtl:pred-2-args-operand-2
+  rtl:set-pred-2-args-operand-2!)
+
 (define-two-arg-method 'FIXNUM-PRED-2-ARGS
   rtl:fixnum-pred-2-args-operand-1
   rtl:set-fixnum-pred-2-args-operand-1!
diff --git a/v7/src/microcode/liarc.h b/v7/src/microcode/liarc.h
index 06fbd94e1..3b6125d02 100644
--- a/v7/src/microcode/liarc.h
+++ b/v7/src/microcode/liarc.h
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Id: liarc.h,v 1.12 1993/11/13 03:46:40 gjr Exp $
+$Id: liarc.h,v 1.13 1997/07/15 03:01:26 adams Exp $
 
 Copyright (c) 1992-1993 Massachusetts Institute of Technology
 
@@ -150,6 +150,8 @@ typedef union machine_word_u machine_word;
 #define CC_BLOCK_TO_ENTRY(block,offset)					\
   (MAKE_POINTER_OBJECT (TC_COMPILED_ENTRY,				\
 			((OBJECT_ADDRESS (block)) + (offset))))
+
+#define INDEX_FIXNUM_P(arg) ((FIXNUM_P(arg)) && (FIXNUM_TO_LONG(arg)>=0))
 
 #ifdef USE_GLOBAL_VARIABLES
 
-- 
2.25.1