(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))))))))
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
(subtypep result-type-value 'vector)
`(coerce (apply #'%map-to-simple-vector-arity-1 fun seqs)
',result-type-value))
- (t (give-up-ir1-transform
- "internal error: unexpected sequence type"))))
+ (t (bug "impossible (?) sequence type"))))
(t
(let* ((seq-args (make-gensym-list (length seqs)))
(index-bindingoids
(let ((dacc (funcall really-fun ,@values)))
(declare (ignorable dacc))
,push-dacc))))))))))
+
+;;; MAP-INTO
+(deftransform map-into ((result fun &rest seqs)
+ (vector * &rest *)
+ *)
+ "open code"
+ (let ((seqs-names (mapcar (lambda (x)
+ (declare (ignore x))
+ (gensym))
+ seqs)))
+ `(lambda (result fun ,@seqs-names)
+ (let ((length (array-dimension result 0))
+ (i 0))
+ (declare (type index i))
+ (declare (ignorable i))
+ ,(cond ((null seqs)
+ `(dotimes (j length (setq i length))
+ (setf (aref result j) (funcall fun))))
+ (t
+ `(block nil
+ (map nil
+ (lambda (,@seqs-names)
+ (when (= i length) (return))
+ (setf (aref result i)
+ (funcall fun ,@seqs-names))
+ (incf i))
+ ,@seqs-names))))
+ (when (array-has-fill-pointer-p result)
+ (setf (fill-pointer result) i))
+ result))))
+
\f
-(deftransform elt ((s i) ((simple-array * (*)) *) * :when :both)
+;;; 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 *) * :when :both)
+(deftransform elt ((s i) (list *) * :policy (< safety 3))
'(nth i s))
-(deftransform %setelt ((s i v) ((simple-array * (*)) * *) * :when :both)
+(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))
-(macrolet ((def-frob (name)
- `(deftransform ,name ((e l &key (test #'eql)) * * :node node :when :both)
+(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)
(unless (constant-continuation-p l)
(give-up-ir1-transform))
,(frob (cdr els)))
nil)))
(frob val))))))
- (def-frob member)
- (def-frob memq))
+ (def member)
+ (def memq))
;;; FIXME: We have rewritten the original code that used DOLIST to this
;;; more natural MACROLET. However, the original code suggested that when
;;; this was done, a few bytes could be saved by a call to a shared
;;; function. This remains to be done.
-(macrolet ((def-frob (fun eq-fun)
+(macrolet ((def (fun eq-fun)
`(deftransform ,fun ((item list &key test) (t list &rest t) *)
"convert to EQ test"
;; FIXME: The scope of this transformation could be
(specifier-type 'number))
(give-up-ir1-transform "Item might be a number.")))
`(,',eq-fun item list))))
- (def-frob delete delq)
- (def-frob assoc assq)
- (def-frob member memq))
+ (def delete delq)
+ (def assoc assq)
+ (def member memq))
(deftransform delete-if ((pred list) (t list))
"open code"
: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))))))
\f
;;;; utilities
;; A form that returns the current value. This may be set with SETF to set
;; the current value.
(current (error "Must specify CURRENT."))
- ;; In a :Normal iterator, a form that tests whether there is a current value.
+ ;; In a :NORMAL iterator, a form that tests whether there is a current value.
(done nil)
- ;; In a :Result iterator, a form that truncates the result at the current
+ ;; In a :RESULT iterator, a form that truncates the result at the current
;; position and returns it.
(result nil)
;; A form that returns the initial total number of values. The result is
;;; We transform the case-sensitive string predicates into a non-keyword
;;; version. This is an IR1 transform so that we don't have to worry about
;;; changing the order of evaluation.
-(macrolet ((def-frob (fun pred*)
+(macrolet ((def (fun pred*)
`(deftransform ,fun ((string1 string2 &key (start1 0) end1
(start2 0) end2)
* *)
`(,',pred* string1 string2 start1 end1 start2 end2))))
- (def-frob string< string<*)
- (def-frob string> string>*)
- (def-frob string<= string<=*)
- (def-frob string>= string>=*)
- (def-frob string= string=*)
- (def-frob string/= string/=*))
+ (def string< string<*)
+ (def string> string>*)
+ (def string<= string<=*)
+ (def string>= string>=*)
+ (def string= string=*)
+ (def string/= string/=*))
;;; Return a form that tests the free variables STRING1 and STRING2
;;; for the ordering relationship specified by LESSP and EQUALP. The
;;; start and end are also gotten from the environment. Both strings
;;; must be SIMPLE-STRINGs.
-(macrolet ((def-frob (name lessp equalp)
+(macrolet ((def (name lessp equalp)
`(deftransform ,name ((string1 string2 start1 end1 start2 end2)
(simple-string simple-string t t t t) *)
`(let* ((end1 (if (not end1) (length string1) end1))
(truly-the index
(+ index
(truly-the fixnum
- (- start2 start1))))))
+ (- start2
+ start1))))))
index)
(t nil))
,(if ',equalp 'end1 nil))))))
- (def-frob string<* t nil)
- (def-frob string<=* t t)
- (def-frob string>* nil nil)
- (def-frob string>=* nil t))
+ (def string<* t nil)
+ (def string<=* t t)
+ (def string>* nil nil)
+ (def string>=* nil t))
-(macrolet ((def-frob (name result-fun)
+(macrolet ((def (name result-fun)
`(deftransform ,name ((string1 string2 start1 end1 start2 end2)
(simple-string simple-string t t t t) *)
`(,',result-fun
(sb!impl::%sp-string-compare
string1 start1 (or end1 (length string1))
string2 start2 (or end2 (length string2)))))))
- (def-frob string=* not)
- (def-frob string/=* identity))
+ (def string=* not)
+ (def string/=* identity))
\f
;;;; string-only transforms for sequence functions
;;;; calls when all arguments are vectors with the same element type,
;;;; rather than restricting them to STRINGs only.
-;;; 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.)
+;;; Moved here from generic/vm-tran.lisp to satisfy clisp
;;;
-;;; FIXME: Also, the transform should probably be dependent on
-;;; SPEED>SPACE.
+;;; 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))
+
(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
;;; %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)
(args))
(dolist (seq sequences)
- (declare (ignore seq))
+ (declare (ignorable seq))
(let ((n-seq (gensym))
(n-length (gensym)))
(args n-seq)
(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)))))
\f
;;;; CONS accessor DERIVE-TYPE optimizers
"sequence type not known at compile time")))))
;;; %FIND-POSITION-IF and %FIND-POSITION-IF-NOT for LIST data
-(macrolet ((def-frob (name condition)
- `(deftransform ,name ((predicate sequence from-end start end key)
- (function list t t t function)
- *
- :policy (> speed space)
- :important t)
- "expand inline"
- `(let ((index 0)
- (find nil)
- (position nil))
- (declare (type index index))
- (dolist (i sequence (values find position))
- (let ((key-i (funcall key i)))
- (when (and end (>= index end))
- (return (values find position)))
- (when (>= index start)
- (,',condition (funcall predicate key-i)
- ;; This hack of dealing with non-NIL
- ;; FROM-END for list data by iterating
- ;; forward through the list and keeping
- ;; track of the last time we found a match
- ;; might be more screwy than what the user
- ;; expects, but it seems to be allowed by
- ;; the ANSI standard. (And if the user is
- ;; screwy enough to ask for FROM-END
- ;; behavior on list data, turnabout is
- ;; fair play.)
- ;;
- ;; It's also not enormously efficient,
- ;; calling PREDICATE and KEY more often
- ;; than necessary; but all the
- ;; alternatives seem to have their own
- ;; efficiency problems.
- (if from-end
- (setf find i
- position index)
- (return (values i index))))))
- (incf index))))))
- (def-frob %find-position-if when)
- (def-frob %find-position-if-not unless))
+(macrolet ((def (name condition)
+ `(deftransform ,name ((predicate sequence from-end start end key)
+ (function list t t t function)
+ *
+ :policy (> speed space)
+ :important t)
+ "expand inline"
+ `(let ((index 0)
+ (find nil)
+ (position nil))
+ (declare (type index index))
+ (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)))
+ (when (>= index start)
+ (,',condition (funcall predicate key-i)
+ ;; This hack of dealing with non-NIL
+ ;; FROM-END for list data by iterating
+ ;; forward through the list and keeping
+ ;; track of the last time we found a match
+ ;; might be more screwy than what the user
+ ;; expects, but it seems to be allowed by
+ ;; the ANSI standard. (And if the user is
+ ;; screwy enough to ask for FROM-END
+ ;; behavior on list data, turnabout is
+ ;; fair play.)
+ ;;
+ ;; It's also not enormously efficient,
+ ;; calling PREDICATE and KEY more often
+ ;; than necessary; but all the
+ ;; alternatives seem to have their own
+ ;; efficiency problems.
+ (if from-end
+ (setf find i
+ position index)
+ (return (values i index))))))
+ (incf index))))))
+ (def %find-position-if when)
+ (def %find-position-if-not unless))
;;; %FIND-POSITION for LIST data can be expanded into %FIND-POSITION-IF
;;; without loss of efficiency. (I.e., the optimizer should be able
: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
(,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)))
(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))