From: Stephen Adams Date: Wed, 16 Aug 1995 18:19:52 +0000 (+0000) Subject: Added checked rewrites for VECTOR-REF, VECTOR-SET!, CAR and CDR. X-Git-Tag: 20090517-FFI~6035 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=7049c1486857261325d1510af2ec6cf1b46bbf59;p=mit-scheme.git 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 7837c9f3c..ee8873637 100644 --- 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 da2b98429..5b700cc4b 100644 --- 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))