Added open-coding for the primitive INDEX-FIXNUM?

diff --git a/v7/src/compiler/machines/C/rules2.scm b/v7/src/compiler/machines/C/rules2.scm
index aeb18f0e314e25b6b1db505b9b9291469cf29735..8e702e0ace415245970ca485240381fc07c651b3 100644 (file)
--- 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 f52a3705a7c450869d7340d16c59302e09565a49..38a2109ce4e9d3d666459b03f9520f2821559b12 100644 (file)
--- 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 1fe38392726a992131c400ad2d4e285b63d95073..6cd9d041d79105ec188e92edf80e5b3ecf16e38c 100644 (file)
--- 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 b74ea0dd25be77cdb31d935f2592b7e6980442bb..2b3b9fae5c7e0ebb47d571e4db28c5640b4dd1a3 100644 (file)
--- 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 fa8c2507874cf4588133d659f92a0316ff33afea..b02e4c04fc4b1d3b4154af4c3d72e2a0166dd021 100644 (file)
--- 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))
 \f
 (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 18567d2ff1b49b499bac934f530eb27962e47af1..71d253626ac0a3e87abffdb4f0835cc064348cb0 100644 (file)
--- 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 706151af5bef434ed254cd6eb323ff2461766c21..ffa9da25d2766980766a83f8a0d9508c86980d30 100644 (file)
--- 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 06fbd94e1492d4668153874b463593ab855c501a..3b6125d024de0d7ecc3e20e3e1ffb36ef32e8692 100644 (file)
--- 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))
 \f
 #ifdef USE_GLOBAL_VARIABLES