From: Stephen Adams <edu/mit/csail/zurich/adams>
Date: Tue, 15 Jul 1997 03:01:26 +0000 (+0000)
Subject: Added open-coding for the primitive INDEX-FIXNUM?
X-Git-Tag: 20090517-FFI~5065
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=60aaf39ee8527d3b58b1d8fa53584e371510cce3;p=mit-scheme.git
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 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