X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fseqtran.lisp;h=bfea7221c7e159c72fd2925fd298b614e187e7e9;hb=40bf78b47ea89b15698adb9c550efa4cbacafeb7;hp=a1fc338a67f00825ed67dcfd0be1a49cd6a79400;hpb=740af378fef405f7d3735fd95423d90100a10beb;p=sbcl.git diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp index a1fc338..bfea722 100644 --- a/src/compiler/seqtran.lisp +++ b/src/compiler/seqtran.lisp @@ -26,25 +26,29 @@ (tests `(endp ,v)) (args-to-fn (if take-car `(car ,v) v)))) - (let ((call `(funcall ,fn . ,(args-to-fn))) - (endtest `(or ,@(tests)))) + (let* ((fn-sym (gensym)) ; for ONCE-ONLY-ish purposes + (call `(funcall ,fn-sym . ,(args-to-fn))) + (endtest `(or ,@(tests)))) (ecase accumulate (:nconc (let ((temp (gensym)) (map-result (gensym))) - `(let ((,map-result (list nil))) + `(let ((,fn-sym ,fn) + (,map-result (list nil))) (do-anonymous ((,temp ,map-result) . ,(do-clauses)) (,endtest (cdr ,map-result)) (setq ,temp (last (nconc ,temp ,call))))))) (:list (let ((temp (gensym)) (map-result (gensym))) - `(let ((,map-result (list nil))) + `(let ((,fn-sym ,fn) + (,map-result (list nil))) (do-anonymous ((,temp ,map-result) . ,(do-clauses)) (,endtest (cdr ,map-result)) (rplacd ,temp (setq ,temp (list ,call))))))) ((nil) - `(let ((,n-first ,(first arglists))) + `(let ((,fn-sym ,fn) + (,n-first ,(first arglists))) (do-anonymous ,(do-clauses) (,endtest ,n-first) ,call)))))))) @@ -87,20 +91,33 @@ result-type-arg-value))))) `(lambda (result-type-arg fun ,@seq-names) (truly-the ,result-type - ,(cond ((policy node (> speed safety)) + ,(cond ((policy node (< safety 3)) + ;; ANSI requires the length-related type check only + ;; when the SAFETY quality is 3... in other cases, we + ;; skip it, because it could be expensive. bare) ((not constant-result-type-arg-p) `(sequence-of-checked-length-given-type ,bare result-type-arg)) (t - (let ((result-ctype (specifier-type result-type))) + (let ((result-ctype (ir1-transform-specifier-type + result-type))) (if (array-type-p result-ctype) - (let* ((dims (array-type-dimensions result-ctype)) - (dim (first dims))) - (if (eq dim '*) - bare - `(vector-of-checked-length-given-length ,bare - ,dim))) + (let ((dims (array-type-dimensions result-ctype))) + (unless (and (listp dims) (= (length dims) 1)) + (give-up-ir1-transform "invalid sequence type")) + (let ((dim (first dims))) + (if (eq dim '*) + bare + `(vector-of-checked-length-given-length ,bare + ,dim)))) + ;; FIXME: this is wrong, as not all subtypes of + ;; VECTOR are ARRAY-TYPEs [consider, for + ;; example, (OR (VECTOR T 3) (VECTOR T + ;; 4))]. However, it's difficult to see what we + ;; should put here... maybe we should + ;; GIVE-UP-IR1-TRANSFORM if the type is a + ;; subtype of VECTOR but not an ARRAY-TYPE? bare)))))))) ;;; Try to compile %MAP efficiently when we can determine sequence @@ -214,18 +231,31 @@ (declare (ignorable dacc)) ,push-dacc)))))))))) +;;; FIXME: once the confusion over doing transforms with known-complex +;;; arrays is over, we should also transform the calls to (AND (ARRAY +;;; * (*)) (NOT (SIMPLE-ARRAY * (*)))) objects. (deftransform elt ((s i) ((simple-array * (*)) *) *) '(aref s i)) -(deftransform elt ((s i) (list *) *) +(deftransform elt ((s i) (list *) * :policy (< safety 3)) '(nth i s)) (deftransform %setelt ((s i v) ((simple-array * (*)) * *) *) '(%aset s i v)) -(deftransform %setelt ((s i v) (list * *)) +(deftransform %setelt ((s i v) (list * *) * :policy (< safety 3)) '(setf (car (nthcdr i s)) v)) +(deftransform %check-vector-sequence-bounds ((vector start end) + (vector * *) * + :node node) + (if (policy node (< safety speed)) + '(or end (length vector)) + '(let ((length (length vector))) + (if (<= 0 start (or end length) length) + (or end length) + (sb!impl::signal-bounding-indices-bad-error vector start end))))) + (macrolet ((def (name) `(deftransform ,name ((e l &key (test #'eql)) * * :node node) @@ -293,17 +323,22 @@ :policy (> speed space)) "open code" (let ((element-type (upgraded-element-type-specifier-or-give-up seq))) - `(with-array-data ((data seq) - (start start) - (end end)) + (values + `(with-array-data ((data seq) + (start start) + (end end)) (declare (type (simple-array ,element-type 1) data)) + (declare (type fixnum start end)) (do ((i start (1+ i))) ((= i end) seq) (declare (type index i)) ;; WITH-ARRAY-DATA did our range checks once and for all, so - ;; it'd be wasteful to check again on every AREF. + ;; it'd be wasteful to check again on every AREF... (declare (optimize (safety 0))) - (setf (aref data i) item))))) + (setf (aref data i) item))) + ;; ... though we still need to check that the new element can fit + ;; into the vector in safe code. -- CSR, 2002-07-05 + `((declare (type ,element-type item)))))) ;;;; utilities @@ -607,24 +642,24 @@ ;;; Moved here from generic/vm-tran.lisp to satisfy clisp ;;; -;;; FIXME: It would be good to implement SB!XC:DEFCONSTANT, and use -;;; use that here, so that the compiler is born knowing this value. ;;; FIXME: Add a comment telling whether this holds for all vectors ;;; or only for vectors based on simple arrays (non-adjustable, etc.). (def!constant vector-data-bit-offset (* sb!vm:vector-data-offset sb!vm:n-word-bits)) -;;; FIXME: Shouldn't we be testing for legality of -;;; * START1, START2, END1, and END2 indices? -;;; * size of copied string relative to destination string? -;;; (Either there should be tests conditional on SAFETY>=SPEED, or -;;; the transform should be conditional on SPEED>SAFETY.) -;;; -;;; FIXME: Also, the transform should probably be dependent on -;;; SPEED>SPACE. (deftransform replace ((string1 string2 &key (start1 0) (start2 0) end1 end2) - (simple-string simple-string &rest t)) + (simple-string simple-string &rest t) + * + ;; FIXME: consider replacing this policy test + ;; with some tests for the STARTx and ENDx + ;; indices being valid, conditional on high + ;; SAFETY code. + ;; + ;; FIXME: It turns out that this transform is + ;; critical for the performance of string + ;; streams. Make this more explicit. + :policy (< (max safety space) 3)) `(locally (declare (optimize (safety 0))) (bit-bash-copy string2 @@ -647,9 +682,12 @@ ;;; %CONCATENATE (with a DEFTRANSFORM to translate constant RTYPE to ;;; CTYPE before calling %CONCATENATE) which is comparably efficient, ;;; at least once DYNAMIC-EXTENT works. +;;; +;;; FIXME: currently KLUDGEed because of bug 188 (deftransform concatenate ((rtype &rest sequences) (t &rest simple-string) - simple-string) + simple-string + :policy (< safety 3)) (collect ((lets) (forms) (all-lengths) @@ -664,16 +702,19 @@ (forms `(bit-bash-copy ,n-seq ,vector-data-bit-offset res start ,n-length)) - (forms `(setq start (+ start ,n-length))))) + (forms `(setq start (opaque-identity (+ start ,n-length)))))) `(lambda (rtype ,@(args)) (declare (ignore rtype)) - (let* (,@(lets) - (res (make-string (truncate (the index (+ ,@(all-lengths))) - sb!vm:n-byte-bits))) - (start ,vector-data-bit-offset)) - (declare (type index start ,@(all-lengths))) - ,@(forms) - res)))) + ;; KLUDGE + (flet ((opaque-identity (x) x)) + (declare (notinline opaque-identity)) + (let* (,@(lets) + (res (make-string (truncate (the index (+ ,@(all-lengths))) + sb!vm:n-byte-bits))) + (start ,vector-data-bit-offset)) + (declare (type index start ,@(all-lengths))) + ,@(forms) + res))))) ;;;; CONS accessor DERIVE-TYPE optimizers @@ -726,7 +767,11 @@ (find nil) (position nil)) (declare (type index index)) - (dolist (i sequence (values find position)) + (dolist (i sequence + (if (and end (> end index)) + (sb!impl::signal-bounding-indices-bad-error + sequence start end) + (values find position))) (let ((key-i (funcall key i))) (when (and end (>= index end)) (return (values find position))) @@ -766,26 +811,10 @@ :important t) "expand inline" '(%find-position-if (let ((test-fun (%coerce-callable-to-fun test))) - ;; I'm having difficulty believing I'm - ;; reading it right, but as far as I can see, - ;; the only guidance that ANSI gives for the - ;; order of arguments to asymmetric tests is - ;; the character-set dependent example from - ;; the definition of FIND, - ;; (find #\d "here are some.." :test #'char>) - ;; => #\Space - ;; (In ASCII, we have (CHAR> #\d #\SPACE)=>T.) - ;; (Neither the POSITION definition page nor - ;; section 17.2 ("Rules about Test Functions") - ;; seem to consider the possibility of - ;; asymmetry.) - ;; - ;; So, judging from the example, we want to - ;; do (FUNCALL TEST-FUN ITEM I), because - ;; (FUNCALL #'CHAR> #\d #\SPACE)=>T. - ;; - ;; -- WHN (whose attention was drawn to it by - ;; Alexey Dejneka's bug report/fix) + ;; The order of arguments for asymmetric tests + ;; (e.g. #'<, as opposed to order-independent + ;; tests like #'=) is specified in the spec + ;; section 17.2.1 -- the O/Zi stuff there. (lambda (i) (funcall test-fun item i))) sequence @@ -815,7 +844,8 @@ (,n-end ,end-arg)) (with-array-data ((,sequence ,n-sequence :offset-var ,offset) (,start ,start) - (,end (or ,n-end (length ,n-sequence)))) + (,end (%check-vector-sequence-bounds + ,n-sequence ,start ,n-end))) (block ,block (macrolet ((maybe-return () '(let ((,element (aref ,sequence ,index))) @@ -903,3 +933,84 @@ (check-inlineability-of-find-position-if sequence from-end) '(%find-position-vector-macro item sequence from-end start end key test)) + +;;; logic to unravel :TEST, :TEST-NOT, and :KEY options in FIND, +;;; POSITION-IF, etc. +(define-source-transform effective-find-position-test (test test-not) + (once-only ((test test) + (test-not test-not)) + `(cond + ((and ,test ,test-not) + (error "can't specify both :TEST and :TEST-NOT")) + (,test (%coerce-callable-to-fun ,test)) + (,test-not + ;; (Without DYNAMIC-EXTENT, this is potentially horribly + ;; inefficient, but since the TEST-NOT option is deprecated + ;; anyway, we don't care.) + (complement (%coerce-callable-to-fun ,test-not))) + (t #'eql)))) +(define-source-transform effective-find-position-key (key) + (once-only ((key key)) + `(if ,key + (%coerce-callable-to-fun ,key) + #'identity))) + +(macrolet ((define-find-position (fun-name values-index) + `(deftransform ,fun-name ((item sequence &key + from-end (start 0) end + key test test-not)) + '(nth-value ,values-index + (%find-position item sequence + from-end start + end + (effective-find-position-key key) + (effective-find-position-test + test test-not)))))) + (define-find-position find 0) + (define-find-position position 1)) + +(macrolet ((define-find-position-if (fun-name values-index) + `(deftransform ,fun-name ((predicate sequence &key + from-end (start 0) + end key)) + '(nth-value + ,values-index + (%find-position-if (%coerce-callable-to-fun predicate) + sequence from-end + start end + (effective-find-position-key key)))))) + (define-find-position-if find-if 0) + (define-find-position-if position-if 1)) + +;;; the deprecated functions FIND-IF-NOT and POSITION-IF-NOT. We +;;; didn't bother to worry about optimizing them, except note that on +;;; Sat, Oct 06, 2001 at 04:22:38PM +0100, Christophe Rhodes wrote on +;;; sbcl-devel +;;; +;;; My understanding is that while the :test-not argument is +;;; deprecated in favour of :test (complement #'foo) because of +;;; semantic difficulties (what happens if both :test and :test-not +;;; are supplied, etc) the -if-not variants, while officially +;;; deprecated, would be undeprecated were X3J13 actually to produce +;;; a revised standard, as there are perfectly legitimate idiomatic +;;; reasons for allowing the -if-not versions equal status, +;;; particularly remove-if-not (== filter). +;;; +;;; This is only an informal understanding, I grant you, but +;;; perhaps it's worth optimizing the -if-not versions in the same +;;; way as the others? +;;; +;;; FIXME: Maybe remove uses of these deprecated functions (and +;;; definitely of :TEST-NOT) within the implementation of SBCL. +(macrolet ((define-find-position-if-not (fun-name values-index) + `(deftransform ,fun-name ((predicate sequence &key + from-end (start 0) + end key)) + '(nth-value + ,values-index + (%find-position-if-not (%coerce-callable-to-fun predicate) + sequence from-end + start end + (effective-find-position-key key)))))) + (define-find-position-if-not find-if-not 0) + (define-find-position-if-not position-if-not 1))