Merge in vector range checking.

diff --git a/v7/src/compiler/machines/bobcat/make.scm-68040 b/v7/src/compiler/machines/bobcat/make.scm-68040
index d2c9e7bb38524758dbd99c49315708713c06b1da..427cf341e5288f791a3db9f4054073af5adbdbfa 100644 (file)
--- a/v7/src/compiler/machines/bobcat/make.scm-68040
+++ b/v7/src/compiler/machines/bobcat/make.scm-68040
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 4.17 1988/06/14 08:48:12 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 4.18 1988/06/14 09:38:11 cph Exp $
 
 Copyright (c) 1988 Massachusetts Institute of Technology
 
@@ -41,4 +41,4 @@ MIT in each case. |#
            ((package/reference (find-package name) 'INITIALIZE-PACKAGE!)))
          '((COMPILER MACROS)
            (COMPILER DECLARATIONS)))
-(add-system! (make-system "Liar" 14 17 '()))
\ No newline at end of file
+(add-system! (make-system "Liar" 14 18 '()))
\ No newline at end of file

diff --git a/v7/src/compiler/rtlgen/opncod.scm b/v7/src/compiler/rtlgen/opncod.scm
index f746b4bd886e9d0a1f40d2943504750a07bebd89..7aaee218a8808fdc7de7eda7b431cc50641c8c31 100644 (file)
--- a/v7/src/compiler/rtlgen/opncod.scm
+++ b/v7/src/compiler/rtlgen/opncod.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/opncod.scm,v 4.8 1988/06/14 08:42:24 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/opncod.scm,v 4.9 1988/06/14 09:37:08 cph Exp $
 
 Copyright (c) 1988 Massachusetts Institute of Technology
 
@@ -212,6 +212,56 @@ MIT in each case. |#
                          (positive? value)))
                   generator))
 \f
+;;;; Constraint Checkers
+
+(define-integrable (make-invocation operator operands)
+  `(,operator ,@operands))
+
+(define (generate-primitive name arg-list continuation-label)
+  (let loop ((args arg-list)
+            (temps '() )
+            (pushes '() ))
+    (if (null? args)
+       (scfg-append!
+        temps
+        (rtl:make-push-return continuation-label)
+        pushes
+        (rtl:make-invocation:primitive (1+ (length arg-list))
+                                       continuation-label
+                                       (make-primitive-procedure name true)))
+       (let ((temp (rtl:make-pseudo-register)))
+         (loop (cdr args)
+               (scfg*scfg->scfg! (rtl:make-assignment temp (car args)) temps)
+               (scfg*scfg->scfg! (rtl:make-push (rtl:make-fetch temp))
+                                 pushes))))))
+
+(define (range-check checkee-locative limit-locative non-error-cfg
+                    error-finish prim-invocation)
+  (if compiler:generate-range-checks?
+      (let* ((continuation-label (generate-label))
+            (error-continuation
+             (scfg*scfg->scfg!
+              (rtl:make-continuation-entry continuation-label)
+              (if error-finish
+                  (error-finish (rtl:make-fetch register:value))
+                  (make-null-cfg))))
+            (error-cfg
+             (scfg*scfg->scfg! (generate-primitive (car prim-invocation)
+                                                   (cdr prim-invocation)
+                                                   continuation-label)
+                               error-continuation)))
+       (pcfg*scfg->scfg!
+        (rtl:make-fixnum-pred-2-args 'LESS-THAN-FIXNUM?
+         (rtl:make-object->fixnum checkee-locative)
+         (rtl:make-object->fixnum limit-locative))
+        (pcfg*scfg->scfg!
+         (rtl:make-fixnum-pred-1-arg 'NEGATIVE-FIXNUM?
+          (rtl:make-object->fixnum checkee-locative))
+         error-cfg
+         non-error-cfg)
+        error-cfg))
+      non-error-cfg))
+\f
 ;;;; Open Coders
 
 (define-open-coder/predicate 'NULL?
@@ -304,51 +354,64 @@ MIT in each case. |#
     (define/length '(VECTOR-LENGTH SYSTEM-VECTOR-SIZE) 0)
     (define/length '(STRING-LENGTH BIT-STRING-LENGTH) 1)))
 
-(let ((open-code/memory-ref/constant
-       (lambda (index)
-        (lambda (expressions finish)
-          (finish
-           (rtl:make-fetch (rtl:locative-offset (car expressions) index))))))
-      (open-code/memory-ref/non-constant
+(define (generate-index-locative expressions non-error-finish error-finish
+                                prim-invocation)
+  (let* ((index (cadr expressions))
+        (vector (car expressions))
+        (temporary (rtl:make-pseudo-register))
+        (element-address-code
+         (rtl:make-assignment
+          temporary
+          (rtl:make-fixnum-2-args
+           'PLUS-FIXNUM
+           (rtl:make-object->address (car expressions))
+           (rtl:make-fixnum-2-args
+            'MULTIPLY-FIXNUM
+            (rtl:make-object->fixnum
+             (rtl:make-constant
+              (quotient scheme-object-width addressing-granularity)))
+            (rtl:make-object->fixnum (cadr expressions))))))
+        (index-locative (rtl:make-fetch temporary)))
+     (range-check index
+                 (rtl:make-fetch (rtl:locative-offset vector 0))
+                 (scfg*scfg->scfg! element-address-code
+                                   (non-error-finish index-locative))
+                 error-finish
+                 prim-invocation)))
+\f
+(let* ((open-code/memory-ref
+       (lambda (index)
          (lambda (expressions finish)
-           (let ((temporary (rtl:make-pseudo-register)))
-             (scfg-append!
-              (rtl:make-assignment
-               temporary
-               (rtl:make-fixnum-2-args
-                'PLUS-FIXNUM
-                (rtl:make-object->address (car expressions))
-                (rtl:make-fixnum-2-args
-                 'MULTIPLY-FIXNUM
-                 (rtl:make-object->fixnum
-                  (rtl:make-constant (quotient scheme-object-width
-                                               addressing-granularity)))
-                 (rtl:make-object->fixnum
-                  (cadr expressions)))))
-              (finish (rtl:make-fetch (rtl:locative-offset
-                                       (rtl:make-fetch temporary)
-                                       1))))))))
+           (finish
+            (rtl:make-fetch (rtl:locative-offset (car expressions) index))))))
+       (open-code/vector-ref
+       (lambda (name)
+         (lambda (expressions finish)
+           (generate-index-locative
+            expressions
+            (lambda (memory-locative)
+              ((open-code/memory-ref 1) (list memory-locative) finish))
+            finish
+            (make-invocation name expressions))))))
 
   (let ((define/ref
          (lambda (name index)
            (define-open-coder/value name
              (lambda (operands)
                operands
-               (return-2 (open-code/memory-ref/constant index) '(0)))))))
+               (return-2 (open-code/memory-ref index) '(0)))))))
     (define/ref '(CAR SYSTEM-PAIR-CAR CELL-CONTENTS SYSTEM-HUNK3-CXR0) 0)
     (define/ref '(CDR SYSTEM-PAIR-CDR SYSTEM-HUNK3-CXR1) 1)
     (define/ref 'SYSTEM-HUNK3-CXR2 2))
 
-  (define-open-coder/value '(VECTOR-REF SYSTEM-VECTOR-REF)
-    (lambda (operands)
-      (let ((good-constant-index
-            (filter/nonnegative-integer (cadr operands)
-              (lambda (index)
-                (return-2 (open-code/memory-ref/constant (1+ index)) '(0))))))
-       (if good-constant-index
-           good-constant-index
-           (return-2 open-code/memory-ref/non-constant
-                     '(0 1)))))))
+  (for-each (lambda (name)
+             (define-open-coder/value name
+               (lambda (operands)
+                 (or (filter/nonnegative-integer (cadr operands)
+                       (lambda (index)
+                         (return-2 (open-code/memory-ref (1+ index)) '(0))))
+                     (return-2 (open-code/vector-ref name) '(0 1))))))
+           '(VECTOR-REF SYSTEM-VECTOR-REF)))
 
 (let ((open-code/general-car-cdr
        (lambda (pattern)
@@ -369,26 +432,31 @@ MIT in each case. |#
        (lambda (pattern)
          (return-2 (open-code/general-car-cdr pattern) '(0)))))))
 \f
-(let ((open-code/memory-assignment
-       (lambda (index locative-generator)
-        (lambda (expressions finish)
-          (locative-generator
+(let* ((open-code/memory-assignment
+       (lambda (index)
+         (lambda (expressions finish)
+           (let* ((locative (rtl:locative-offset (car expressions) index))
+                  (assignment
+                   (rtl:make-assignment locative
+                                        (car (last-pair expressions)))))
+             (if finish
+                 (let ((temporary (rtl:make-pseudo-register)))
+                   (scfg-append!
+                    (rtl:make-assignment temporary (rtl:make-fetch locative))
+                    assignment
+                    (finish (rtl:make-fetch temporary))))
+                 assignment)))))
+       (open-code/vector-set
+       (lambda (name)
+         (lambda (expressions finish)
+           (generate-index-locative
             expressions
-            (lambda (lvalue-locative)
-              (let ((locative (rtl:locative-offset
-                               lvalue-locative
-                               index)))
-                (let ((assignment
-                       (rtl:make-assignment locative
-                                            (car (last-pair expressions)))))
-                  (if finish
-                      (let ((temporary (rtl:make-pseudo-register)))
-                        (scfg-append!
-                         (rtl:make-assignment temporary
-                                              (rtl:make-fetch locative))
-                         assignment
-                         (finish (rtl:make-fetch temporary))))
-                      assignment)))))))))
+            (lambda (memory-locative)
+              ((open-code/memory-assignment 1)
+               (cons memory-locative (cddr expressions))
+               finish))
+            finish
+            (make-invocation name expressions))))))
 
   ;; For now SYSTEM-XXXX side effect procedures are considered
   ;; dangerous to the garbage collector's health.  Some day we will
@@ -398,11 +466,7 @@ MIT in each case. |#
          (lambda (name index)
            (define-open-coder/effect name
              (lambda (operands)
-               operands
-               (return-2 (open-code/memory-assignment index
-                                                      (lambda (exp finish)
-                                                        (finish (car exp))))
-                         '(0 1)))))))
+               (return-2 (open-code/memory-assignment index) '(0 1)))))))
     (define/set! '(SET-CAR!
                   SET-CELL-CONTENTS!
                   #| SYSTEM-PAIR-SET-CAR! |#
@@ -419,31 +483,8 @@ MIT in each case. |#
     (lambda (operands)
       (or (filter/nonnegative-integer (cadr operands)
            (lambda (index)
-             (return-2 (open-code/memory-assignment
-                        (1+ index)
-                        (lambda (exp finish)
-                          (finish (car exp))))
-                       '(0 2))))
-         (return-2 (open-code/memory-assignment
-                    1
-                    (lambda (expressions finish)
-                      (let ((temporary (rtl:make-pseudo-register)))
-                        (scfg-append!
-                         (rtl:make-assignment
-                          temporary
-                          (rtl:make-fixnum-2-args
-                           'PLUS-FIXNUM
-                           (rtl:make-object->address (car expressions))
-                           (rtl:make-fixnum-2-args
-                            'MULTIPLY-FIXNUM
-                            (rtl:make-object->fixnum
-                             (rtl:make-constant
-                              (quotient scheme-object-width
-                                        addressing-granularity)))
-                            (rtl:make-object->fixnum
-                             (cadr expressions)))))
-                         (finish (rtl:make-fetch temporary))))))
-                   '(0 1 2))))))
+             (return-2 (open-code/memory-assignment (1+ index)) '(0 2))))
+         (return-2 (open-code/vector-set 'VECTOR-SET!) '(0 1 2))))))
 \f
 (let ((define-fixnum-2-args
        (lambda (fixnum-operator)
@@ -458,10 +499,12 @@ MIT in each case. |#
                           (rtl:make-object->fixnum (car expressions))
                           (rtl:make-object->fixnum (cadr expressions))))))
               '(0 1)))))))
-  (for-each
-   define-fixnum-2-args
-    '(PLUS-FIXNUM MINUS-FIXNUM MULTIPLY-FIXNUM
-      #| DIVIDE-FIXNUM GCD-FIXNUM |#)))
+  (for-each define-fixnum-2-args
+           '(PLUS-FIXNUM
+             MINUS-FIXNUM
+             MULTIPLY-FIXNUM
+             #| DIVIDE-FIXNUM |#
+             #| GCD-FIXNUM |#)))
 
 (let ((define-fixnum-1-arg
        (lambda (fixnum-operator)
@@ -536,7 +579,7 @@ MIT in each case. |#
       (lambda (index)
        (return-2
         (lambda (expressions finish)
-          (finish (rtl:make-cons-pointer 
+          (finish (rtl:make-cons-pointer
                    (rtl:make-constant (ucode-type character))
                    (rtl:make-fetch
                     (rtl:locative-byte-offset
@@ -547,10 +590,10 @@ MIT in each case. |#
 (define-open-coder/effect 'STRING-SET!
   (lambda (operands)
     (filter/nonnegative-integer (cadr operands)
-      (lambda (index)                          
+      (lambda (index)
        (return-2
         (lambda (expressions finish)
-          (let* ((locative 
+          (let* ((locative
                   (rtl:locative-byte-offset (car expressions)
                                             (+ string-header-size index)))
                  (assignment