Added checked rewrites for VECTOR-REF, VECTOR-SET!, CAR and CDR.

diff --git a/v8/src/compiler/midend/earlyrew.scm b/v8/src/compiler/midend/earlyrew.scm
index 7837c9f3cc51e0189a3b069e0099243bb8cf8b13..ee8873637d43b66a67adc48c1caf037a68ff1505 100644 (file)
--- a/v8/src/compiler/midend/earlyrew.scm
+++ b/v8/src/compiler/midend/earlyrew.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: earlyrew.scm,v 1.11 1995/08/10 21:52:53 adams Exp $
+$Id: earlyrew.scm,v 1.12 1995/08/16 18:16:35 adams Exp $
 
 Copyright (c) 1994-1995 Massachusetts Institute of Technology
 
@@ -556,6 +556,80 @@ MIT in each case. |#
            (else
             (default))))))
 
+(define (early/indexed-reference primitive object-tag-name
+                                %check/full %check/index
+                                %unchecked)
+  (let ((object-tag (machine-tag object-tag-name)))
+    (lambda (vec index #!optional value)
+      
+      (define (bind+ name value body)
+       (if name (bind name value body) body))
+
+      (let ((vec-name  (earlyrew/new-name object-tag-name))
+           (idx-name  (earlyrew/new-name 'INDEX))
+           (val-name  (and (not (default-object? value))
+                           (earlyrew/new-name 'VALUE))))
+       (let ((extra
+              (if (default-object? value) '() (list `(LOOKUP ,val-name)))))
+         (let ((test
+                (cond ((and compiler:generate-range-checks?
+                            compiler:generate-type-checks?)
+                       `(CALL (QUOTE ,%check/full) '#F
+                              (LOOKUP ,vec-name) (LOOKUP ,idx-name)))
+                      (compiler:generate-range-checks?
+                       `(CALL (QUOTE ,%check/index) '#F
+                              (LOOKUP ,vec-name) (LOOKUP ,idx-name)))
+                      (compiler:generate-type-checks?
+                       `(CALL (QUOTE ,object-type?) '#F
+                              (QUOTE ,object-tag) (LOOKUP ,vec-name)))
+                      (else #F)))
+               (unchecked
+                (lambda ()
+                  `(CALL (QUOTE ,%unchecked) (QUOTE #F)
+                         (LOOKUP ,vec-name)
+                         (LOOKUP ,idx-name)
+                         ,@extra)))
+               (primitive-call
+                (lambda ()
+                  `(CALL (QUOTE ,primitive) (QUOTE #F)
+                         (LOOKUP ,vec-name)
+                         (LOOKUP ,idx-name)
+                         ,@extra))))
+           (bind vec-name vec
+                 (bind idx-name index
+                       (bind+ val-name (or (default-object? value) value)
+                              (if test
+                                  `(IF ,test
+                                       ,(unchecked)
+                                       ,(primitive-call))
+                                  (unchecked)))))))))))
+
+(define-rewrite/early 'VECTOR-REF
+  (early/indexed-reference (make-primitive-procedure 'VECTOR-REF) 'VECTOR
+                          %vector-check %vector-check/index
+                          %vector-ref))
+
+(define-rewrite/early 'VECTOR-SET!
+  (early/indexed-reference (make-primitive-procedure 'VECTOR-SET!) 'VECTOR
+                          %vector-check %vector-check/index
+                          %vector-set!))
+
+(define (early/make-cxr primitive %unchecked)
+  (let ((prim-pair? (make-primitive-procedure 'PAIR?)))
+    (lambda (text)
+      (if compiler:generate-type-checks?
+         (let ((text-name  (earlyrew/new-name 'OBJECT)))
+           (bind text-name text
+                 `(IF (CALL ',prim-pair? '#F (LOOKUP ,text-name))
+                      (CALL ',%unchecked '#F (LOOKUP ,text-name))
+                      (CALL ',primitive  '#F (LOOKUP ,text-name)))))
+         `(CALL ',%unchecked '#F ,text)))))
+
+(define early/car (early/make-cxr (make-primitive-procedure 'CAR) %car))
+(define early/cdr (early/make-cxr (make-primitive-procedure 'CDR) %cdr))
+
+(define-rewrite/early 'CAR early/car)
+(define-rewrite/early 'CDR early/cdr)
 
 (define-rewrite/early 'GENERAL-CAR-CDR
   (let ((prim-general-car-cdr (make-primitive-procedure 'GENERAL-CAR-CDR))
@@ -572,11 +646,8 @@ MIT in each case. |#
                        (if (= num 1)
                            text
                            (walk-bits (quotient num 2)
-                                      `(CALL (QUOTE ,(if (odd? num)
-                                                         prim-car
-                                                         prim-cdr))
-                                             (QUOTE #f)
-                                             ,text))))
+                                      ((if (odd? num) early/car early/cdr)
+                                       text))))
                      (default))))
            (else (default))))))
 

diff --git a/v8/src/compiler/midend/rtlgen.scm b/v8/src/compiler/midend/rtlgen.scm
index da2b984291b383e2908fdfc90904c29518d31e1e..5b700cc4b41c614921e46608c2484578558c8969 100644 (file)
--- a/v8/src/compiler/midend/rtlgen.scm
+++ b/v8/src/compiler/midend/rtlgen.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: rtlgen.scm,v 1.36 1995/08/14 15:11:24 adams Exp $
+$Id: rtlgen.scm,v 1.37 1995/08/16 18:19:52 adams Exp $
 
 Copyright (c) 1994-1995 Massachusetts Institute of Technology
 
@@ -3218,6 +3218,15 @@ MIT in each case. |#
   (define-fixnum-predicate fix:> 'GREATER-THAN-FIXNUM?
     rtlgen/branch/unpredictable))
 
+(define-open-coder/pred %word-less-than-unsigned? 2
+  (lambda (state rands open-coder)
+    open-coder                         ; ignored
+    (let* ((rand1 (rtlgen/->register (first rands)))
+          (rand2 (rtlgen/->register (second rands))))
+      (rtlgen/branch/likely
+       state
+       `(PRED-2-ARGS WORD-LESS-THAN-UNSIGNED? ,rand1 ,rand2)))))
+
 (let ((define-flonum-predicate
        (lambda (proc name rtlgen/branch)
          (define-open-coder/pred proc 2
@@ -3501,8 +3510,8 @@ MIT in each case. |#
   (define-fixed-selector %cell-ref          (machine-tag 'CELL) 0 2)
   (define-fixed-selector %car               (machine-tag 'PAIR) 0 1)
   (define-fixed-selector %cdr               (machine-tag 'PAIR) 1 1)
-  (define-fixed-selector 'CAR               (machine-tag 'PAIR) 0 1)
-  (define-fixed-selector 'CDR               (machine-tag 'PAIR) 1 1)
+  ;;(define-fixed-selector 'CAR               (machine-tag 'PAIR) 0 1)
+  ;;(define-fixed-selector 'CDR               (machine-tag 'PAIR) 1 1)
   (define-fixed-selector 'SYSTEM-PAIR-CAR   false 0 1)
   (define-fixed-selector 'SYSTEM-PAIR-CDR   false 1 1)
   (define-fixed-selector 'SYSTEM-HUNK3-CXR0 false 0 1)
@@ -3545,7 +3554,7 @@ MIT in each case. |#
                         (rtlgen/value-assignment
                          state
                          `(OFFSET ,ptr (MACHINE-CONSTANT ,offset))))))))))))
-  (define-indexed-selector 'VECTOR-REF (machine-tag 'VECTOR) 1 2)
+  ;;(define-indexed-selector 'VECTOR-REF (machine-tag 'VECTOR) 1 2)
   (define-indexed-selector %vector-ref (machine-tag 'VECTOR) 1 2)
   (define-indexed-selector '%RECORD-REF (machine-tag 'RECORD) 1 2)
   ;; NOTE: This assumes that the result of the following two is always
@@ -3986,7 +3995,7 @@ MIT in each case. |#
                         (rtlgen/emit!/1
                          `(ASSIGN (OFFSET ,ptr (MACHINE-CONSTANT ,offset))
                                   ,value)))))))))))
-  (define-indexed-mutator 'VECTOR-SET!  (machine-tag 'VECTOR) 1 3)
+  ;(define-indexed-mutator 'VECTOR-SET!  (machine-tag 'VECTOR) 1 3)
   (define-indexed-mutator %vector-set!  (machine-tag 'VECTOR) 1 3)
   (define-indexed-mutator '%RECORD-SET! (machine-tag 'RECORD) 1 3)
   (define-indexed-mutator 'PRIMITIVE-OBJECT-SET! false 0 3))