From: Chris Hanson Date: Tue, 14 Jun 1988 09:38:11 +0000 (+0000) Subject: Merge in vector range checking. X-Git-Tag: 20090517-FFI~12720 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=a095f251af238bd19202f0d2ec497cdb2418f88a;p=mit-scheme.git 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 d2c9e7bb3..427cf341e 100644 --- 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 f746b4bd8..7aaee218a 100644 --- 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)) +;;;; 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)) + ;;;; 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))) + +(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))))))) -(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)))))) (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