From 2e33f2df9a6eb5a84d71726b88f06d92241e44da Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Fri, 31 Jul 2009 12:14:00 +0000 Subject: [PATCH] 1.0.30.25: deftransform for ARRAY-IN-BOUNDS-P * Patch by Leslie Polzer. * Also give notes when giving up in ARRAY-TYPE-DIMENSIONS-OR-GIVE-UP. --- NEWS | 2 ++ src/code/array.lisp | 2 +- src/compiler/array-tran.lisp | 66 ++++++++++++++++++++++++++++++++-- tests/compiler.pure.lisp | 81 ++++++++++++++++++++++++++++++++++++++++++ version.lisp-expr | 2 +- 5 files changed, 149 insertions(+), 4 deletions(-) diff --git a/NEWS b/NEWS index 838241b..d1b55bb 100644 --- a/NEWS +++ b/NEWS @@ -13,6 +13,8 @@ changes relative to sbcl-1.0.30: multiplication by reciprocal when an exact reciprocal exists. * optimization: multiplication of single- and double-floats floats by constant two has been optimized. + * optimization: ARRAY-IN-BOUNDS-P is resolved at compile-time when + sufficient type information is available. (thanks to Leslie Polzer) * improvement: a STYLE-WARNING is signalled when a generic function clobbers an earlier FTYPE proclamation. * improvement: the compiler is able to track the effective type of diff --git a/src/code/array.lisp b/src/code/array.lisp index 455d09f..4a9e054 100644 --- a/src/code/array.lisp +++ b/src/code/array.lisp @@ -531,7 +531,7 @@ of specialized arrays is supported." (defun array-in-bounds-p (array &rest subscripts) #!+sb-doc - "Return T if the SUBSCIPTS are in bounds for the ARRAY, NIL otherwise." + "Return T if the SUBSCRIPTS are in bounds for the ARRAY, NIL otherwise." (if (%array-row-major-index array subscripts nil) t)) diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp index 4c0688d..7db2e7f 100644 --- a/src/compiler/array-tran.lisp +++ b/src/compiler/array-tran.lisp @@ -112,6 +112,63 @@ (assert-array-rank array (length indices)) *universal-type*) +(deftransform array-in-bounds-p ((array &rest subscripts)) + (flet ((give-up () + (give-up-ir1-transform + "~@")) + (bound-known-p (x) + (integerp x))) ; might be NIL or * + (block nil + (let ((dimensions (array-type-dimensions-or-give-up + (lvar-conservative-type array)))) + ;; shortcut for zero dimensions + (when (some (lambda (dim) + (and (bound-known-p dim) (zerop dim))) + dimensions) + (return nil)) + ;; we first collect the subscripts LVARs' bounds and see whether + ;; we can already decide on the result of the optimization without + ;; even taking a look at the dimensions. + (flet ((subscript-bounds (subscript) + (let* ((type (lvar-type subscript)) + (low (numeric-type-low type)) + (high (numeric-type-high type))) + (cond + ((and (or (not (bound-known-p low)) (minusp low)) + (or (not (bound-known-p high)) (not (minusp high)))) + ;; can't be sure about the lower bound and the upper bound + ;; does not give us a definite clue either. + (give-up)) + ((and (bound-known-p high) (minusp high)) + (return nil)) ; definitely below lower bound (zero). + (t + (cons low high)))))) + (let* ((subscripts-bounds (mapcar #'subscript-bounds subscripts)) + (subscripts-lower-bound (mapcar #'car subscripts-bounds)) + (subscripts-upper-bound (mapcar #'cdr subscripts-bounds)) + (in-bounds 0)) + (mapcar (lambda (low high dim) + (cond + ;; first deal with infinite bounds + ((some (complement #'bound-known-p) (list low high dim)) + (when (and (bound-known-p dim) (bound-known-p low) (<= dim low)) + (return nil))) + ;; now we know all bounds + ((>= low dim) + (return nil)) + ((< high dim) + (aver (not (minusp low))) + (incf in-bounds)) + (t + (give-up)))) + subscripts-lower-bound + subscripts-upper-bound + dimensions) + (if (eql in-bounds (length dimensions)) + t + (give-up)))))))) + (defoptimizer (aref derive-type) ((array &rest indices) node) (assert-array-rank array (length indices)) (derive-aref-type array)) @@ -556,9 +613,14 @@ (let ((result (array-type-dimensions-or-give-up (car types)))) (dolist (type (cdr types) result) (unless (equal (array-type-dimensions-or-give-up type) result) - (give-up-ir1-transform)))))) + (give-up-ir1-transform + "~@" + (type-specifier type))))))) ;; FIXME: intersection type [e.g. (and (array * (*)) (satisfies foo)) ] - (t (give-up-ir1-transform)))) + (t + (give-up-ir1-transform + "~@" + (type-specifier type))))) (defun conservative-array-type-complexp (type) (typecase type diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index 089871f..1c49450 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -2949,6 +2949,87 @@ `(lambda (x y z) (make-array '3 :initial-contents `(,x ,y ,z)))))))) +;;; optimizing array-in-bounds-p +(with-test (:name :optimize-array-in-bounds-p) + (locally + (macrolet ((find-callees (&body body) + `(ctu:find-named-callees + (compile nil + '(lambda () + ,@body)) + :name 'array-in-bounds-p)) + (must-optimize (&body exprs) + `(progn + ,@(loop for expr in exprs + collect `(assert (not (find-callees + ,expr)))))) + (must-not-optimize (&body exprs) + `(progn + ,@(loop for expr in exprs + collect `(assert (find-callees + ,expr)))))) + (must-optimize + ;; in bounds + (let ((a (make-array '(1)))) + (array-in-bounds-p a 0)) + ;; exceeds upper bound (constant) + (let ((a (make-array '(1)))) + (array-in-bounds-p a 1)) + ;; exceeds upper bound (interval) + (let ((a (make-array '(1)))) + (array-in-bounds-p a (+ 1 (random 2)))) + ;; negative lower bound (constant) + (let ((a (make-array '(1)))) + (array-in-bounds-p a -1)) + ;; negative lower bound (interval) + (let ((a (make-array 3)) + (i (- (random 1) 20))) + (array-in-bounds-p a i)) + ;; multiple known dimensions + (let ((a (make-array '(1 1)))) + (array-in-bounds-p a 0 0)) + ;; union types + (let ((s (the (simple-string 10) (eval "0123456789")))) + (array-in-bounds-p s 9))) + (must-not-optimize + ;; don't trust non-simple array length in safety=1 + (let ((a (the (array * (10)) (make-array 10 :adjustable t)))) + (eval `(adjust-array ,a 0)) + (array-in-bounds-p a 9)) + ;; same for a union type + (let ((s (the (string 10) (make-array 10 + :element-type 'character + :adjustable t)))) + (eval `(adjust-array ,s 0)) + (array-in-bounds-p s 9)) + ;; single unknown dimension + (let ((a (make-array (random 20)))) + (array-in-bounds-p a 10)) + ;; multiple unknown dimensions + (let ((a (make-array (list (random 20) (random 5))))) + (array-in-bounds-p a 5 2)) + ;; some other known dimensions + (let ((a (make-array (list 1 (random 5))))) + (array-in-bounds-p a 0 2)) + ;; subscript might be negative + (let ((a (make-array 5))) + (array-in-bounds-p a (- (random 3) 2))) + ;; subscript might be too large + (let ((a (make-array 5))) + (array-in-bounds-p a (random 6))) + ;; unknown upper bound + (let ((a (make-array 5))) + (array-in-bounds-p a (get-universal-time))) + ;; unknown lower bound + (let ((a (make-array 5))) + (array-in-bounds-p a (- (get-universal-time)))) + ;; in theory we should be able to optimize + ;; the following but the current implementation + ;; doesn't cut it because the array type's + ;; dimensions get reported as (* *). + (let ((a (make-array (list (random 20) 1)))) + (array-in-bounds-p a 5 2)))))) + ;;; optimizing (EXPT -1 INTEGER) (test-util:with-test (:name (expt minus-one integer)) (dolist (x '(-1 -1.0 -1.0d0)) diff --git a/version.lisp-expr b/version.lisp-expr index b67bd8a..f70c198 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.30.24" +"1.0.30.25" -- 1.7.10.4