1 ;;;; optimizers for list and sequence functions
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
14 ;;;; mapping onto lists: the MAPFOO functions
16 (defun mapfoo-transform (fn arglists accumulate take-car
)
17 (collect ((do-clauses)
20 (let ((n-first (gensym)))
21 (dolist (a (if accumulate
23 `(,n-first
,@(rest arglists
))))
25 (do-clauses `(,v
,a
(cdr ,v
)))
27 (args-to-fn (if take-car
`(car ,v
) v
))))
29 (let* ((fn-sym (gensym)) ; for ONCE-ONLY-ish purposes
30 (call `(%funcall
,fn-sym .
,(args-to-fn)))
31 (endtest `(or ,@(tests))))
33 `(let ((,fn-sym
(%coerce-callable-to-fun
,fn
)))
37 (map-result (gensym)))
38 `(let ((,map-result
(list nil
)))
39 (do-anonymous ((,temp
,map-result
) .
,(do-clauses))
40 (,endtest
(cdr ,map-result
))
41 (setq ,temp
(last (nconc ,temp
,call
)))))))
44 (map-result (gensym)))
45 `(let ((,map-result
(list nil
)))
46 (do-anonymous ((,temp
,map-result
) .
,(do-clauses))
47 (,endtest
(truly-the list
(cdr ,map-result
)))
48 (rplacd ,temp
(setq ,temp
(list ,call
)))))))
50 `(let ((,n-first
,(first arglists
)))
51 (do-anonymous ,(do-clauses)
52 (,endtest
(truly-the list
,n-first
))
55 (define-source-transform mapc
(function list
&rest more-lists
)
56 (mapfoo-transform function
(cons list more-lists
) nil t
))
58 (define-source-transform mapcar
(function list
&rest more-lists
)
59 (mapfoo-transform function
(cons list more-lists
) :list t
))
61 (define-source-transform mapcan
(function list
&rest more-lists
)
62 (mapfoo-transform function
(cons list more-lists
) :nconc t
))
64 (define-source-transform mapl
(function list
&rest more-lists
)
65 (mapfoo-transform function
(cons list more-lists
) nil nil
))
67 (define-source-transform maplist
(function list
&rest more-lists
)
68 (mapfoo-transform function
(cons list more-lists
) :list nil
))
70 (define-source-transform mapcon
(function list
&rest more-lists
)
71 (mapfoo-transform function
(cons list more-lists
) :nconc nil
))
73 ;;;; mapping onto sequences: the MAP function
75 ;;; MAP is %MAP plus a check to make sure that any length specified in
76 ;;; the result type matches the actual result. We also wrap it in a
77 ;;; TRULY-THE for the most specific type we can determine.
78 (deftransform map
((result-type-arg fun seq
&rest seqs
) * * :node node
)
79 (let* ((seq-names (make-gensym-list (1+ (length seqs
))))
80 (bare `(%map result-type-arg fun
,@seq-names
))
81 (constant-result-type-arg-p (constant-lvar-p result-type-arg
))
82 ;; what we know about the type of the result. (Note that the
83 ;; "result type" argument is not necessarily the type of the
84 ;; result, since NIL means the result has NULL type.)
85 (result-type (if (not constant-result-type-arg-p
)
87 (let ((result-type-arg-value
88 (lvar-value result-type-arg
)))
89 (if (null result-type-arg-value
)
91 result-type-arg-value
)))))
92 `(lambda (result-type-arg fun
,@seq-names
)
93 (truly-the ,result-type
94 ,(cond ((policy node
(< safety
3))
95 ;; ANSI requires the length-related type check only
96 ;; when the SAFETY quality is 3... in other cases, we
97 ;; skip it, because it could be expensive.
99 ((not constant-result-type-arg-p
)
100 `(sequence-of-checked-length-given-type ,bare
103 (let ((result-ctype (ir1-transform-specifier-type
105 (if (array-type-p result-ctype
)
106 (let ((dims (array-type-dimensions result-ctype
)))
107 (unless (and (listp dims
) (= (length dims
) 1))
108 (give-up-ir1-transform "invalid sequence type"))
109 (let ((dim (first dims
)))
112 `(vector-of-checked-length-given-length ,bare
114 ;; FIXME: this is wrong, as not all subtypes of
115 ;; VECTOR are ARRAY-TYPEs [consider, for
116 ;; example, (OR (VECTOR T 3) (VECTOR T
117 ;; 4))]. However, it's difficult to see what we
118 ;; should put here... maybe we should
119 ;; GIVE-UP-IR1-TRANSFORM if the type is a
120 ;; subtype of VECTOR but not an ARRAY-TYPE?
123 ;;; Return a DO loop, mapping a function FUN to elements of
124 ;;; sequences. SEQS is a list of lvars, SEQ-NAMES - list of variables,
125 ;;; bound to sequences, INTO - a variable, which is used in
126 ;;; MAP-INTO. RESULT and BODY are forms, which can use variables
127 ;;; FUNCALL-RESULT, containing the result of application of FUN, and
128 ;;; INDEX, containing the current position in sequences.
129 (defun build-sequence-iterator (seqs seq-names
&key result into body fast
)
130 (declare (type list seqs seq-names
)
138 (let ((found-vector-p nil
))
139 (flet ((process-vector (length)
140 (unless found-vector-p
141 (setq found-vector-p t
)
142 (bindings `(index 0 (1+ index
)))
143 (declarations `(type index index
)))
144 (vector-lengths length
)))
145 (loop for seq of-type lvar in seqs
146 for seq-name in seq-names
147 for type
= (lvar-type seq
)
148 do
(cond ((csubtypep type
(specifier-type 'list
))
149 (with-unique-names (index)
150 (bindings `(,index
,seq-name
(cdr ,index
)))
151 (declarations `(type list
,index
))
152 (places `(car ,index
))
153 (tests `(endp ,index
))))
154 ((or (csubtypep type
(specifier-type '(simple-array * 1)))
156 (csubtypep type
(specifier-type 'vector
))))
157 (process-vector `(length ,seq-name
))
158 (places `(locally (declare (optimize (insert-array-bounds-checks 0)))
159 (aref ,seq-name index
))))
160 ((csubtypep type
(specifier-type 'vector
))
161 (let ((data (gensym "DATA"))
162 (start (gensym "START"))
163 (end (gensym "END")))
164 (around `(with-array-data ((,data
,seq-name
)
166 (,end
(length ,seq-name
)))))
167 (process-vector `(- ,end
,start
))
168 (places `(locally (declare (optimize (insert-array-bounds-checks 0)))
169 (aref ,data
(truly-the index
(+ index
,start
)))))))
171 (give-up-ir1-transform
172 "can't determine sequence argument type"))))
174 (process-vector `(array-dimension ,into
0))))
176 (bindings `(length (min ,@(vector-lengths))))
177 (tests `(>= index length
)))
178 (let ((body `(do (,@(bindings))
179 ((or ,@(tests)) ,result
)
180 (declare ,@(declarations))
181 (let ((funcall-result (funcall fun
,@(places))))
182 (declare (ignorable funcall-result
))
185 (reduce (lambda (wrap body
) (append wrap
(list body
)))
191 ;;; Try to compile %MAP efficiently when we can determine sequence
192 ;;; argument types at compile time.
194 ;;; Note: This transform was written to allow open coding of
195 ;;; quantifiers by expressing them in terms of (MAP NIL ..). For
196 ;;; non-NIL values of RESULT-TYPE, it's still useful, but not
197 ;;; necessarily as efficient as possible. In particular, it will be
198 ;;; inefficient when RESULT-TYPE is a SIMPLE-ARRAY with specialized
199 ;;; numeric element types. It should be straightforward to make it
200 ;;; handle that case more efficiently, but it's left as an exercise to
201 ;;; the reader, because the code is complicated enough already and I
202 ;;; don't happen to need that functionality right now. -- WHN 20000410
203 (deftransform %map
((result-type fun seq
&rest seqs
) * *
204 :node node
:policy
(>= speed space
))
206 (unless (constant-lvar-p result-type
)
207 (give-up-ir1-transform "RESULT-TYPE argument not constant"))
208 (labels ( ;; 1-valued SUBTYPEP, fails unless second value of SUBTYPEP is true
209 (fn-1subtypep (fn x y
)
210 (multiple-value-bind (subtype-p valid-p
) (funcall fn x y
)
213 (give-up-ir1-transform
214 "can't analyze sequence type relationship"))))
215 (1subtypep (x y
) (fn-1subtypep #'sb
!xc
:subtypep x y
)))
216 (let* ((result-type-value (lvar-value result-type
))
217 (result-supertype (cond ((null result-type-value
) 'null
)
218 ((1subtypep result-type-value
'vector
)
220 ((1subtypep result-type-value
'list
)
223 (give-up-ir1-transform
224 "result type unsuitable")))))
225 (cond ((and result-type-value
(null seqs
))
226 ;; The consing arity-1 cases can be implemented
227 ;; reasonably efficiently as function calls, and the cost
228 ;; of consing should be significantly larger than
229 ;; function call overhead, so we always compile these
230 ;; cases as full calls regardless of speed-versus-space
231 ;; optimization policy.
232 (cond ((subtypep result-type-value
'list
)
233 '(%map-to-list-arity-1 fun seq
))
234 ( ;; (This one can be inefficient due to COERCE, but
235 ;; the current open-coded implementation has the
237 (subtypep result-type-value
'vector
)
238 `(coerce (%map-to-simple-vector-arity-1 fun seq
)
239 ',result-type-value
))
240 (t (bug "impossible (?) sequence type"))))
242 (let* ((seqs (cons seq seqs
))
243 (seq-args (make-gensym-list (length seqs
))))
244 (multiple-value-bind (push-dacc result
)
245 (ecase result-supertype
246 (null (values nil nil
))
247 (list (values `(push funcall-result acc
)
249 (vector (values `(push funcall-result acc
)
250 `(coerce (nreverse acc
)
251 ',result-type-value
))))
252 ;; (We use the same idiom, of returning a LAMBDA from
253 ;; DEFTRANSFORM, as is used in the DEFTRANSFORMs for
254 ;; FUNCALL and ALIEN-FUNCALL, and for the same
255 ;; reason: we need to get the runtime values of each
256 ;; of the &REST vars.)
257 `(lambda (result-type fun
,@seq-args
)
258 (declare (ignore result-type
))
259 (let ((fun (%coerce-callable-to-fun fun
))
261 (declare (type list acc
))
262 (declare (ignorable acc
))
263 ,(build-sequence-iterator
267 :fast
(policy node
(> speed space
))))))))))))
270 (deftransform map-into
((result fun
&rest seqs
)
274 (let ((seqs-names (mapcar (lambda (x)
278 `(lambda (result fun
,@seqs-names
)
279 ,(if (and (policy node
(> speed space
))
280 (not (csubtypep (lvar-type result
)
281 (specifier-type '(simple-array * 1)))))
282 (let ((data (gensym "DATA"))
283 (start (gensym "START"))
284 (end (gensym "END")))
285 `(with-array-data ((,data result
)
288 (declare (ignore ,end
))
289 ,(build-sequence-iterator
291 :result
'(when (array-has-fill-pointer-p result
)
292 (setf (fill-pointer result
) index
))
294 :body
`(locally (declare (optimize (insert-array-bounds-checks 0)))
295 (setf (aref ,data
(truly-the index
(+ index
,start
)))
298 (build-sequence-iterator
300 :result
'(when (array-has-fill-pointer-p result
)
301 (setf (fill-pointer result
) index
))
303 :body
'(locally (declare (optimize (insert-array-bounds-checks 0)))
304 (setf (aref result index
) funcall-result
))))
308 ;;; FIXME: once the confusion over doing transforms with known-complex
309 ;;; arrays is over, we should also transform the calls to (AND (ARRAY
310 ;;; * (*)) (NOT (SIMPLE-ARRAY * (*)))) objects.
311 (deftransform elt
((s i
) ((simple-array * (*)) *) *)
314 (deftransform elt
((s i
) (list *) * :policy
(< safety
3))
317 (deftransform %setelt
((s i v
) ((simple-array * (*)) * *) *)
320 (deftransform %setelt
((s i v
) (list * *) * :policy
(< safety
3))
321 '(setf (car (nthcdr i s
)) v
))
323 (deftransform %check-vector-sequence-bounds
((vector start end
)
326 (if (policy node
(= 0 insert-array-bounds-checks
))
327 '(or end
(length vector
))
328 '(let ((length (length vector
)))
329 (if (<= 0 start
(or end length
) length
)
331 (sequence-bounding-indices-bad-error vector start end
)))))
333 (def!type eq-comparable-type
()
334 '(or fixnum
(not number
)))
336 ;;; True if EQL comparisons involving type can be simplified to EQ.
337 (defun eq-comparable-type-p (type)
338 (csubtypep type
(specifier-type 'eq-comparable-type
)))
340 (defun specialized-list-seek-function-name (function-name key-functions
&optional variant
)
341 (or (find-symbol (with-output-to-string (s)
342 ;; Write "%NAME-FUN1-FUN2-FUN3", etc. Not only is
343 ;; this ever so slightly faster then FORMAT, this
344 ;; way we are also proof against *PRINT-CASE*
345 ;; frobbing and such.
347 (write-string (symbol-name function-name
) s
)
348 (dolist (f key-functions
)
350 (write-string (symbol-name f
) s
))
353 (write-string (symbol-name variant
) s
)))
354 (load-time-value (find-package "SB!KERNEL")))
355 (bug "Unknown list item seek transform: name=~S, key-functions=~S variant=~S"
356 function-name key-functions variant
)))
358 (defparameter *list-open-code-limit
* 128)
360 (defun transform-list-item-seek (name item list key test test-not node
)
361 (when (and test test-not
)
362 (abort-ir1-transform "Both ~S and ~S supplied to ~S." :test
:test-not name
))
363 ;; If TEST is EQL, drop it.
364 (when (and test
(lvar-fun-is test
'(eql)))
366 ;; Ditto for KEY IDENTITY.
367 (when (and key
(lvar-fun-is key
'(identity)))
369 ;; Key can legally be NIL, but if it's NIL for sure we pretend it's
370 ;; not there at all. If it might be NIL, make up a form to that
371 ;; ensures it is a function.
372 (multiple-value-bind (key key-form
)
374 (let ((key-type (lvar-type key
))
375 (null-type (specifier-type 'null
)))
376 (cond ((csubtypep key-type null-type
)
378 ((csubtypep null-type key-type
)
380 (%coerce-callable-to-fun key
)
383 (values key
(ensure-lvar-fun-form key
'key
))))))
384 (let* ((c-test (cond ((and test
(lvar-fun-is test
'(eq)))
387 ((and (not test
) (not test-not
))
388 (when (eq-comparable-type-p (lvar-type item
))
390 (funs (delete nil
(list (when key
(list key
'key
))
391 (when test
(list test
'test
))
392 (when test-not
(list test-not
'test-not
)))))
393 (target-expr (if key
'(%funcall key target
) 'target
))
394 (test-expr (cond (test `(%funcall test item
,target-expr
))
395 (test-not `(not (%funcall test-not item
,target-expr
)))
396 (c-test `(,c-test item
,target-expr
))
397 (t `(eql item
,target-expr
)))))
398 (labels ((open-code (tail)
400 `(if (let ((this ',(car tail
)))
403 (let ((cxx (if (eq name
'assoc
) 'car
'cdr
)))
404 `(and this
(let ((target (,cxx this
)))
407 `(let ((target this
))
410 ((assoc rassoc
) (car tail
))
412 ,(open-code (cdr tail
)))))
414 (if (eq 'key
(second args
))
416 (apply #'ensure-lvar-fun-form args
))))
417 (let* ((cp (constant-lvar-p list
))
418 (c-list (when cp
(lvar-value list
))))
419 (cond ((and cp c-list
(member name
'(assoc rassoc member
))
420 (policy node
(>= speed space
))
421 (not (nthcdr *list-open-code-limit
* c-list
)))
422 `(let ,(mapcar (lambda (fun) `(,(second fun
) ,(ensure-fun fun
))) funs
)
423 ,(open-code c-list
)))
424 ((and cp
(not c-list
))
426 (if (eq name
'adjoin
)
430 ;; specialized out-of-line version
431 `(,(specialized-list-seek-function-name name
(mapcar #'second funs
) c-test
)
432 item list
,@(mapcar #'ensure-fun funs
)))))))))
434 (defun transform-list-pred-seek (name pred list key node
)
435 ;; If KEY is IDENTITY, drop it.
436 (when (and key
(lvar-fun-is key
'(identity)))
438 ;; Key can legally be NIL, but if it's NIL for sure we pretend it's
439 ;; not there at all. If it might be NIL, make up a form to that
440 ;; ensures it is a function.
441 (multiple-value-bind (key key-form
)
443 (let ((key-type (lvar-type key
))
444 (null-type (specifier-type 'null
)))
445 (cond ((csubtypep key-type null-type
)
447 ((csubtypep null-type key-type
)
449 (%coerce-callable-to-fun key
)
452 (values key
(ensure-lvar-fun-form key
'key
))))))
453 (let ((test-expr `(%funcall pred
,(if key
'(%funcall key target
) 'target
)))
454 (pred-expr (ensure-lvar-fun-form pred
'pred
)))
455 (when (member name
'(member-if-not assoc-if-not rassoc-if-not
))
456 (setf test-expr
`(not ,test-expr
)))
457 (labels ((open-code (tail)
459 `(if (let ((this ',(car tail
)))
461 ((assoc-if assoc-if-not rassoc-if rassoc-if-not
)
462 (let ((cxx (if (member name
'(assoc-if assoc-if-not
)) 'car
'cdr
)))
463 `(and this
(let ((target (,cxx this
)))
465 ((member-if member-if-not
)
466 `(let ((target this
))
469 ((assoc-if assoc-if-not rassoc-if rassoc-if-not
)
471 ((member-if member-if-not
)
473 ,(open-code (cdr tail
))))))
474 (let* ((cp (constant-lvar-p list
))
475 (c-list (when cp
(lvar-value list
))))
476 (cond ((and cp c-list
(policy node
(>= speed space
))
477 (not (nthcdr *list-open-code-limit
* c-list
)))
478 `(let ((pred ,pred-expr
)
479 ,@(when key
`((key ,key-form
))))
480 ,(open-code c-list
)))
481 ((and cp
(not c-list
))
482 ;; constant nil list -- nothing to find!
485 ;; specialized out-of-line version
486 `(,(specialized-list-seek-function-name name
(when key
'(key)))
487 ,pred-expr list
,@(when key
(list key-form
))))))))))
489 (macrolet ((def (name &optional if
/if-not
)
490 (let ((basic (symbolicate "%" name
))
491 (basic-eq (symbolicate "%" name
"-EQ"))
492 (basic-key (symbolicate "%" name
"-KEY"))
493 (basic-key-eq (symbolicate "%" name
"-KEY-EQ")))
495 (deftransform ,name
((item list
&key key test test-not
) * * :node node
)
496 (transform-list-item-seek ',name item list key test test-not node
))
497 (deftransform ,basic
((item list
) (eq-comparable-type t
))
498 `(,',basic-eq item list
))
499 (deftransform ,basic-key
((item list
) (eq-comparable-type t
))
500 `(,',basic-key-eq item list
))
502 (let ((if-name (symbolicate name
"-IF"))
503 (if-not-name (symbolicate name
"-IF-NOT")))
504 `((deftransform ,if-name
((pred list
&key key
) * * :node node
)
505 (transform-list-pred-seek ',if-name pred list key node
))
506 (deftransform ,if-not-name
((pred list
&key key
) * * :node node
)
507 (transform-list-pred-seek ',if-not-name pred list key node
)))))))))
513 (deftransform memq
((item list
) (t (constant-arg list
)))
516 `(if (eq item
',(car tail
))
520 (rec (lvar-value list
))))
522 ;;; A similar transform used to apply to MEMBER and ASSOC, but since
523 ;;; TRANSFORM-LIST-ITEM-SEEK now takes care of them those transform
524 ;;; would never fire, and (%MEMBER-TEST ITEM LIST #'EQ) should be
525 ;;; almost as fast as MEMQ.
526 (deftransform delete
((item list
&key test
) (t list
&rest t
) *)
528 (let ((type (lvar-type item
)))
529 (unless (or (and test
(lvar-fun-is test
'(eq)))
530 (and (eq-comparable-type-p type
)
531 (or (not test
) (lvar-fun-is test
'(eql)))))
532 (give-up-ir1-transform)))
535 (deftransform delete-if
((pred list
) (t list
))
537 '(do ((x list
(cdr x
))
540 (cond ((funcall pred
(car x
))
543 (rplacd splice
(cdr x
))))
544 (t (setq splice x
)))))
546 (deftransform fill
((seq item
&key
(start 0) (end nil
))
547 (list t
&key
(:start t
) (:end t
)))
548 '(list-fill* seq item start end
))
550 (deftransform fill
((seq item
&key
(start 0) (end nil
))
551 (vector t
&key
(:start t
) (:end t
))
554 (let* ((type (lvar-type seq
))
555 (element-ctype (array-type-upgraded-element-type type
))
556 (element-type (type-specifier element-ctype
))
557 (saetp (unless (eq *wild-type
* element-ctype
)
558 (find-saetp-by-ctype element-ctype
))))
559 (cond ((eq *wild-type
* element-ctype
)
560 (delay-ir1-transform node
:constraint
)
561 `(vector-fill* seq item start end
))
562 ((and saetp
(sb!vm
::valid-bit-bash-saetp-p saetp
))
563 (let* ((n-bits (sb!vm
:saetp-n-bits saetp
))
564 (basher-name (format nil
"UB~D-BASH-FILL" n-bits
))
565 (basher (or (find-symbol basher-name
566 (load-time-value (find-package :sb
!kernel
)))
568 "Unknown fill basher, please report to sbcl-devel: ~A"
570 (kind (cond ((sb!vm
:saetp-fixnum-p saetp
) :tagged
)
571 ((member element-type
'(character base-char
)) :char
)
572 ((eq element-type
'single-float
) :single-float
)
573 #!+#.
(cl:if
(cl:= 64 sb
!vm
:n-word-bits
) '(and) '(or))
574 ((eq element-type
'double-float
) :double-float
)
575 #!+#.
(cl:if
(cl:= 64 sb
!vm
:n-word-bits
) '(and) '(or))
576 ((equal element-type
'(complex single-float
))
577 :complex-single-float
)
579 (aver (integer-type-p element-ctype
))
581 ;; BASH-VALUE is a word that we can repeatedly smash
582 ;; on the array: for less-than-word sized elements it
583 ;; contains multiple copies of the fill item.
585 (if (constant-lvar-p item
)
586 (let ((tmp (lvar-value item
)))
587 (unless (ctypep tmp element-ctype
)
588 (abort-ir1-transform "~S is not ~S" tmp element-type
))
593 (ash tmp sb
!vm
:n-fixnum-tag-bits
))
599 (single-float-bits tmp
))
600 #!+#.
(cl:if
(cl:= 64 sb
!vm
:n-word-bits
) '(and) '(or))
602 (logior (ash (double-float-high-bits tmp
) 32)
603 (double-float-low-bits tmp
)))
604 #!+#.
(cl:if
(cl:= 64 sb
!vm
:n-word-bits
) '(and) '(or))
605 (:complex-single-float
606 (logior (ash (single-float-bits (imagpart tmp
)) 32)
608 (single-float-bits (realpart tmp
))))))))
610 (loop for i of-type sb
!vm
:word from n-bits by n-bits
611 until
(= i sb
!vm
:n-word-bits
)
612 do
(setf res
(ldb (byte sb
!vm
:n-word-bits
0)
613 (logior res
(ash bits i
)))))
616 (delay-ir1-transform node
:constraint
)
617 `(let* ((bits (ldb (byte ,n-bits
0)
620 `(ash item
,sb
!vm
:n-fixnum-tag-bits
))
626 `(single-float-bits item
))
627 #!+#.
(cl:if
(cl:= 64 sb
!vm
:n-word-bits
) '(and) '(or))
629 `(logior (ash (double-float-high-bits item
) 32)
630 (double-float-low-bits item
)))
631 #!+#.
(cl:if
(cl:= 64 sb
!vm
:n-word-bits
) '(and) '(or))
632 (:complex-single-float
633 `(logior (ash (single-float-bits (imagpart item
)) 32)
635 (single-float-bits (realpart item
))))))))
637 (declare (type sb
!vm
:word res
))
638 ,@(unless (= sb
!vm
:n-word-bits n-bits
)
639 `((loop for i of-type sb
!vm
:word from
,n-bits by
,n-bits
640 until
(= i sb
!vm
:n-word-bits
)
642 (ldb (byte ,sb
!vm
:n-word-bits
0)
643 (logior res
(ash bits
(truly-the (integer 0 ,(- sb
!vm
:n-word-bits n-bits
)) i
))))))))
646 ;; KLUDGE: WITH-ARRAY data in its full glory is going to mess up
647 ;; dynamic-extent for MAKE-ARRAY :INITIAL-ELEMENT initialization.
648 (if (csubtypep (lvar-type seq
) (specifier-type '(simple-array * (*))))
649 `(let* ((len (length seq
))
652 ;; Minor abuse %CHECK-BOUND for bounds checking.
653 ;; (- END START) may still end up negative, but
654 ;; the basher handle that.
655 (,basher
,bash-value seq
656 (%check-bound seq bound start
)
657 (- (if end
(%check-bound seq bound end
) len
)
659 `(with-array-data ((data seq
)
662 :check-fill-pointer t
)
663 (declare (type (simple-array ,element-type
1) data
))
664 (declare (type index start end
))
665 (declare (optimize (safety 0) (speed 3)))
666 (,basher
,bash-value data start
(- end start
))
668 `((declare (type ,element-type item
))))))
669 ((policy node
(> speed space
))
671 `(with-array-data ((data seq
)
674 :check-fill-pointer t
)
675 (declare (type (simple-array ,element-type
1) data
))
676 (declare (type index start end
))
677 ;; WITH-ARRAY-DATA did our range checks once and for all, so
678 ;; it'd be wasteful to check again on every AREF...
679 (declare (optimize (safety 0) (speed 3)))
680 (do ((i start
(1+ i
)))
682 (declare (type index i
))
683 (setf (aref data i
) item
)))
684 ;; ... though we still need to check that the new element can fit
685 ;; into the vector in safe code. -- CSR, 2002-07-05
686 `((declare (type ,element-type item
)))))
687 ((csubtypep type
(specifier-type 'string
))
688 '(string-fill* seq item start end
))
690 '(vector-fill* seq item start end
)))))
692 (deftransform fill
((seq item
&key
(start 0) (end nil
))
693 ((and sequence
(not vector
) (not list
)) t
&key
(:start t
) (:end t
)))
694 `(sb!sequence
:fill seq item
696 :end
(%check-generic-sequence-bounds seq start end
)))
698 ;;;; hairy sequence transforms
700 ;;; FIXME: no hairy sequence transforms in SBCL?
702 ;;; There used to be a bunch of commented out code about here,
703 ;;; containing the (apparent) beginning of hairy sequence transform
704 ;;; infrastructure. People interested in implementing better sequence
705 ;;; transforms might want to look at it for inspiration, even though
706 ;;; the actual code is ancient CMUCL -- and hence bitrotted. The code
707 ;;; was deleted in 1.0.7.23.
709 ;;;; string operations
711 ;;; We transform the case-sensitive string predicates into a non-keyword
712 ;;; version. This is an IR1 transform so that we don't have to worry about
713 ;;; changing the order of evaluation.
714 (macrolet ((def (fun pred
*)
715 `(deftransform ,fun
((string1 string2
&key
(start1 0) end1
718 `(,',pred
* string1 string2 start1 end1 start2 end2
))))
719 (def string
< string
<*)
720 (def string
> string
>*)
721 (def string
<= string
<=*)
722 (def string
>= string
>=*)
723 (def string
= string
=*)
724 (def string
/= string
/=*))
726 ;;; Return a form that tests the free variables STRING1 and STRING2
727 ;;; for the ordering relationship specified by LESSP and EQUALP. The
728 ;;; start and end are also gotten from the environment. Both strings
729 ;;; must be SIMPLE-BASE-STRINGs.
730 (macrolet ((def (name lessp equalp
)
731 `(deftransform ,name
((string1 string2 start1 end1 start2 end2
)
732 (simple-base-string simple-base-string t t t t
) *)
733 `(let* ((end1 (if (not end1
) (length string1
) end1
))
734 (end2 (if (not end2
) (length string2
) end2
))
735 (index (sb!impl
::%sp-string-compare
736 string1 start1 end1 string2 start2 end2
)))
738 (cond ((= index end1
)
739 ,(if ',lessp
'index nil
))
740 ((= (+ index
(- start2 start1
)) end2
)
741 ,(if ',lessp nil
'index
))
742 ((,(if ',lessp
'char
< 'char
>)
743 (schar string1 index
)
752 ,(if ',equalp
'end1 nil
))))))
755 (def string
>* nil nil
)
756 (def string
>=* nil t
))
758 (macrolet ((def (name result-fun
)
759 `(deftransform ,name
((string1 string2 start1 end1 start2 end2
)
760 (simple-base-string simple-base-string t t t t
) *)
762 (sb!impl
::%sp-string-compare
763 string1 start1
(or end1
(length string1
))
764 string2 start2
(or end2
(length string2
)))))))
766 (def string
/=* identity
))
769 ;;;; transforms for sequence functions
771 ;;; Moved here from generic/vm-tran.lisp to satisfy clisp. Only applies
772 ;;; to vectors based on simple arrays.
773 (def!constant vector-data-bit-offset
774 (* sb
!vm
:vector-data-offset sb
!vm
:n-word-bits
))
776 ;;; FIXME: In the copy loops below, we code the loops in a strange
779 ;;; (do ((i (+ src-offset length) (1- i)))
781 ;;; (... (aref foo (1- i)) ...))
783 ;;; rather than the more natural (and seemingly more efficient):
785 ;;; (do ((i (1- (+ src-offset length)) (1- i)))
787 ;;; (... (aref foo i) ...))
789 ;;; (more efficient because we don't have to do the index adjusting on
790 ;;; every iteration of the loop)
792 ;;; We do this to avoid a suboptimality in SBCL's backend. In the
793 ;;; latter case, the backend thinks I is a FIXNUM (which it is), but
794 ;;; when used as an array index, the backend thinks I is a
795 ;;; POSITIVE-FIXNUM (which it is). However, since the backend thinks of
796 ;;; these as distinct storage classes, it cannot coerce a move from a
797 ;;; FIXNUM TN to a POSITIVE-FIXNUM TN. The practical effect of this
798 ;;; deficiency is that we have two extra moves and increased register
799 ;;; pressure, which can lead to some spectacularly bad register
800 ;;; allocation. (sub-FIXME: the register allocation even with the
801 ;;; strangely written loops is not always excellent, either...). Doing
802 ;;; it the first way, above, means that I is always thought of as a
803 ;;; POSITIVE-FIXNUM and there are no issues.
805 ;;; Besides, the *-WITH-OFFSET machinery will fold those index
806 ;;; adjustments in the first version into the array addressing at no
807 ;;; performance penalty!
809 ;;; This transform is critical to the performance of string streams. If
810 ;;; you tweak it, make sure that you compare the disassembly, if not the
811 ;;; performance of, the functions implementing string streams
812 ;;; (e.g. SB!IMPL::STRING-OUCH).
813 (eval-when (#-sb-xc
:compile-toplevel
:load-toplevel
:execute
)
814 (defun make-replace-transform (saetp sequence-type1 sequence-type2
)
815 `(deftransform replace
((seq1 seq2
&key
(start1 0) (start2 0) end1 end2
)
816 (,sequence-type1
,sequence-type2
&rest t
)
819 `(let* ((len1 (length seq1
))
821 (end1 (or end1 len1
))
822 (end2 (or end2 len2
))
823 (replace-len (min (- end1 start1
) (- end2 start2
))))
824 ,(unless (policy node
(= insert-array-bounds-checks
0))
826 (unless (<= 0 start1 end1 len1
)
827 (sequence-bounding-indices-bad-error seq1 start1 end1
))
828 (unless (<= 0 start2 end2 len2
)
829 (sequence-bounding-indices-bad-error seq2 start2 end2
))))
831 ((and saetp
(sb!vm
:valid-bit-bash-saetp-p saetp
))
832 (let* ((n-element-bits (sb!vm
:saetp-n-bits saetp
))
833 (bash-function (intern (format nil
"UB~D-BASH-COPY"
835 (find-package "SB!KERNEL"))))
836 `(funcall (function ,bash-function
) seq2 start2
837 seq1 start1 replace-len
)))
840 ;; If the sequence types are different, SEQ1 and
841 ;; SEQ2 must be distinct arrays.
842 ,(eql sequence-type1 sequence-type2
)
843 (eq seq1 seq2
) (> start1 start2
))
844 (do ((i (truly-the index
(+ start1 replace-len -
1))
846 (j (truly-the index
(+ start2 replace-len -
1))
849 (declare (optimize (insert-array-bounds-checks 0)))
850 (setf (aref seq1 i
) (aref seq2 j
)))
851 (do ((i start1
(1+ i
))
853 (end (+ start1 replace-len
)))
855 (declare (optimize (insert-array-bounds-checks 0)))
856 (setf (aref seq1 i
) (aref seq2 j
))))))
860 ((define-replace-transforms ()
861 (loop for saetp across sb
!vm
:*specialized-array-element-type-properties
*
862 for sequence-type
= `(simple-array ,(sb!vm
:saetp-specifier saetp
) (*))
863 unless
(= (sb!vm
:saetp-typecode saetp
) sb
!vm
::simple-array-nil-widetag
)
864 collect
(make-replace-transform saetp sequence-type sequence-type
)
866 finally
(return `(progn ,@forms
))))
867 (define-one-transform (sequence-type1 sequence-type2
)
868 (make-replace-transform nil sequence-type1 sequence-type2
)))
869 (define-replace-transforms)
872 (define-one-transform (simple-array base-char
(*)) (simple-array character
(*)))
873 (define-one-transform (simple-array character
(*)) (simple-array base-char
(*)))))
875 ;;; Expand simple cases of UB<SIZE>-BASH-COPY inline. "simple" is
876 ;;; defined as those cases where we are doing word-aligned copies from
877 ;;; both the source and the destination and we are copying from the same
878 ;;; offset from both the source and the destination. (The last
879 ;;; condition is there so we can determine the direction to copy at
880 ;;; compile time rather than runtime. Remember that UB<SIZE>-BASH-COPY
881 ;;; acts like memmove, not memcpy.) These conditions may seem rather
882 ;;; restrictive, but they do catch common cases, like allocating a (* 2
883 ;;; N)-size buffer and blitting in the old N-size buffer in.
885 (defun frob-bash-transform (src src-offset
887 length n-elems-per-word
)
888 (declare (ignore src dst length
))
889 (let ((n-bits-per-elem (truncate sb
!vm
:n-word-bits n-elems-per-word
)))
890 (multiple-value-bind (src-word src-elt
)
891 (truncate (lvar-value src-offset
) n-elems-per-word
)
892 (multiple-value-bind (dst-word dst-elt
)
893 (truncate (lvar-value dst-offset
) n-elems-per-word
)
894 ;; Avoid non-word aligned copies.
895 (unless (and (zerop src-elt
) (zerop dst-elt
))
896 (give-up-ir1-transform))
897 ;; Avoid copies where we would have to insert code for
898 ;; determining the direction of copying.
899 (unless (= src-word dst-word
)
900 (give-up-ir1-transform))
901 ;; FIXME: The cross-compiler doesn't optimize TRUNCATE properly,
902 ;; so we have to do its work here.
903 `(let ((end (+ ,src-word
,(if (= n-elems-per-word
1)
905 `(truncate (the index length
) ,n-elems-per-word
)))))
906 (declare (type index end
))
907 ;; Handle any bits at the end.
908 (when (logtest length
(1- ,n-elems-per-word
))
909 (let* ((extra (mod length
,n-elems-per-word
))
910 ;; FIXME: The shift amount on this ASH is
911 ;; *always* negative, but the backend doesn't
912 ;; have a NEGATIVE-FIXNUM primitive type, so we
913 ;; wind up with a pile of code that tests the
914 ;; sign of the shift count prior to shifting when
915 ;; all we need is a simple negate and shift
917 (mask (ash #.
(1- (ash 1 sb
!vm
:n-word-bits
))
918 (* (- extra
,n-elems-per-word
)
920 (setf (sb!kernel
:%vector-raw-bits dst end
)
922 (logandc2 (sb!kernel
:%vector-raw-bits dst end
)
924 ,(ecase sb
!c
:*backend-byte-order
*
926 (:big-endian
`(* (- ,n-elems-per-word extra
)
927 ,n-bits-per-elem
)))))
928 (logand (sb!kernel
:%vector-raw-bits src end
)
930 ,(ecase sb
!c
:*backend-byte-order
*
932 (:big-endian
`(* (- ,n-elems-per-word extra
)
933 ,n-bits-per-elem
)))))))))
934 ;; Copy from the end to save a register.
937 (setf (sb!kernel
:%vector-raw-bits dst
(1- i
))
938 (sb!kernel
:%vector-raw-bits src
(1- i
))))
941 #.
(loop for i
= 1 then
(* i
2)
942 collect
`(deftransform ,(intern (format nil
"UB~D-BASH-COPY" i
)
947 ((simple-unboxed-array (*))
949 (simple-unboxed-array (*))
953 (frob-bash-transform src src-offset
954 dst dst-offset length
955 ,(truncate sb
!vm
:n-word-bits i
))) into forms
956 until
(= i sb
!vm
:n-word-bits
)
957 finally
(return `(progn ,@forms
)))
959 ;;; We expand copy loops inline in SUBSEQ and COPY-SEQ if we're copying
960 ;;; arrays with elements of size >= the word size. We do this because
961 ;;; we know the arrays cannot alias (one was just consed), therefore we
962 ;;; can determine at compile time the direction to copy, and for
963 ;;; word-sized elements, UB<WORD-SIZE>-BASH-COPY will do a bit of
964 ;;; needless checking to figure out what's going on. The same
965 ;;; considerations apply if we are copying elements larger than the word
966 ;;; size, with the additional twist that doing it inline is likely to
967 ;;; cons far less than calling REPLACE and letting generic code do the
970 ;;; However, we do not do this for elements whose size is < than the
971 ;;; word size because we don't want to deal with any alignment issues
972 ;;; inline. The UB*-BASH-COPY transforms might fix things up later
975 (defun maybe-expand-copy-loop-inline (src src-offset dst dst-offset length
977 (let ((saetp (find-saetp element-type
)))
979 (if (>= (sb!vm
:saetp-n-bits saetp
) sb
!vm
:n-word-bits
)
980 (expand-aref-copy-loop src src-offset dst dst-offset length
)
981 `(locally (declare (optimize (safety 0)))
982 (replace ,dst
,src
:start1
,dst-offset
:start2
,src-offset
:end1
,length
)))))
984 (defun expand-aref-copy-loop (src src-offset dst dst-offset length
)
985 (if (eql src-offset dst-offset
)
986 `(do ((i (+ ,src-offset
,length
) (1- i
)))
988 (declare (optimize (insert-array-bounds-checks 0)))
989 (setf (aref ,dst
(1- i
)) (aref ,src
(1- i
))))
990 ;; KLUDGE: The compiler is not able to derive that (+ offset
991 ;; length) must be a fixnum, but arrives at (unsigned-byte 29).
992 ;; We, however, know it must be so, as by this point the bounds
993 ;; have already been checked.
994 `(do ((i (truly-the fixnum
(+ ,src-offset
,length
)) (1- i
))
995 (j (+ ,dst-offset
,length
) (1- j
)))
997 (declare (optimize (insert-array-bounds-checks 0))
998 (type (integer 0 #.sb
!xc
:array-dimension-limit
) j i
))
999 (setf (aref ,dst
(1- j
)) (aref ,src
(1- i
))))))
1001 ;;; SUBSEQ, COPY-SEQ
1003 (deftransform subseq
((seq start
&optional end
)
1004 (vector t
&optional t
)
1007 (let ((type (lvar-type seq
)))
1009 ((and (array-type-p type
)
1010 (csubtypep type
(specifier-type '(or (simple-unboxed-array (*)) simple-vector
)))
1011 (policy node
(> speed space
)))
1012 (let ((element-type (type-specifier (array-type-specialized-element-type type
))))
1013 `(let* ((length (length seq
))
1014 (end (or end length
)))
1015 ,(unless (policy node
(zerop insert-array-bounds-checks
))
1017 (unless (<= 0 start end length
)
1018 (sequence-bounding-indices-bad-error seq start end
))))
1019 (let* ((size (- end start
))
1020 (result (make-array size
:element-type
',element-type
)))
1021 ,(maybe-expand-copy-loop-inline 'seq
(if (constant-lvar-p start
)
1024 'result
0 'size element-type
)
1027 '(vector-subseq* seq start end
)))))
1029 (deftransform subseq
((seq start
&optional end
)
1030 (list t
&optional t
))
1031 `(list-subseq* seq start end
))
1033 (deftransform subseq
((seq start
&optional end
)
1034 ((and sequence
(not vector
) (not list
)) t
&optional t
))
1035 '(sb!sequence
:subseq seq start end
))
1037 (deftransform copy-seq
((seq) (vector))
1038 (let ((type (lvar-type seq
)))
1039 (cond ((and (array-type-p type
)
1040 (csubtypep type
(specifier-type '(or (simple-unboxed-array (*)) simple-vector
))))
1041 (let ((element-type (type-specifier (array-type-specialized-element-type type
))))
1042 `(let* ((length (length seq
))
1043 (result (make-array length
:element-type
',element-type
)))
1044 ,(maybe-expand-copy-loop-inline 'seq
0 'result
0 'length element-type
)
1047 '(vector-subseq* seq
0 nil
)))))
1049 (deftransform copy-seq
((seq) (list))
1050 '(list-copy-seq* seq
))
1052 (deftransform copy-seq
((seq) ((and sequence
(not vector
) (not list
))))
1053 '(sb!sequence
:copy-seq seq
))
1055 ;;; FIXME: it really should be possible to take advantage of the
1056 ;;; macros used in code/seq.lisp here to avoid duplication of code,
1057 ;;; and enable even funkier transformations.
1058 (deftransform search
((pattern text
&key
(start1 0) (start2 0) end1 end2
1062 (vector vector
&rest t
)
1065 :policy
(> speed
(max space safety
)))
1069 (if (constant-lvar-p x
)
1070 (when (lvar-value x
)
1073 (let ((from-end (when (lvar-p from-end
)
1074 (unless (constant-lvar-p from-end
)
1075 (give-up-ir1-transform ":FROM-END is not constant."))
1076 (lvar-value from-end
)))
1078 (test?
(maybe test
))
1079 (check-bounds-p (policy node
(plusp insert-array-bounds-checks
))))
1081 (flet ((oops (vector start end
)
1082 (sequence-bounding-indices-bad-error vector start end
)))
1083 (let* ((len1 (length pattern
))
1084 (len2 (length text
))
1085 (end1 (or end1 len1
))
1086 (end2 (or end2 len2
))
1088 (:yes
`((key (%coerce-callable-to-fun key
))))
1089 (:maybe
`((key (when key
1090 (%coerce-callable-to-fun key
))))))
1092 `((test (%coerce-callable-to-fun test
)))))
1093 (declare (type index start1 start2 end1 end2
))
1094 ,@(when check-bounds-p
1095 `((unless (<= start1 end1 len1
)
1096 (oops pattern start1 end1
))
1097 (unless (<= start2 end2 len2
)
1098 (oops pattern start2 end2
))))
1099 (when (= end1 start1
)
1100 (return-from search
(if from-end
1104 '(index2 (- end2
(- end1 start1
)) (1- index2
))
1105 '(index2 start2
(1+ index2
))))
1110 ;; INDEX2 is FIXNUM, not an INDEX, as right before the loop
1111 ;; terminates is hits -1 when :FROM-END is true and :START2
1113 (declare (type fixnum index2
))
1114 (when (do ((index1 start1
(1+ index1
))
1115 (index2 index2
(1+ index2
)))
1116 ((>= index1 end1
) t
)
1117 (declare (type index index1 index2
)
1118 (optimize (insert-array-bounds-checks 0)))
1120 '((when (= index2 end2
)
1121 (return-from search nil
))))
1122 (unless (,@(if test?
1126 (:yes
`(funcall key
(aref pattern index1
)))
1127 (:maybe
`(let ((elt (aref pattern index1
)))
1131 (otherwise `(aref pattern index1
)))
1133 (:yes
`(funcall key
(aref text index2
)))
1134 (:maybe
`(let ((elt (aref text index2
)))
1138 (otherwise `(aref text index2
))))
1140 (return index2
)))))))))
1143 ;;; Open-code CONCATENATE for strings. It would be possible to extend
1144 ;;; this transform to non-strings, but I chose to just do the case that
1145 ;;; should cover 95% of CONCATENATE performance complaints for now.
1146 ;;; -- JES, 2007-11-17
1148 ;;; Only handle the simple result type cases. If somebody does (CONCATENATE
1149 ;;; '(STRING 6) ...) their code won't be optimized, but nobody does that in
1152 ;;; Limit full open coding based on length of constant sequences. Default
1153 ;;; value is chosen so that other parts of the compiler (constraint propagation
1154 ;;; mainly) won't go nonlinear too badly. It's not an exact number -- but
1155 ;;; in the right ballpark.
1156 (defvar *concatenate-open-code-limit
* 129)
1158 (deftransform concatenate
((result-type &rest lvars
)
1160 (member string simple-string base-string simple-base-string
))
1163 (let ((vars (loop for x in lvars collect
(gensym)))
1164 (type (lvar-value result-type
)))
1165 (if (policy node
(<= speed space
))
1167 `(lambda (.dummy.
,@vars
)
1168 (declare (ignore .dummy.
))
1170 ((string simple-string
)
1171 `(%concatenate-to-string
,@vars
))
1172 ((base-string simple-base-string
)
1173 `(%concatenate-to-base-string
,@vars
))))
1175 (let* ((element-type (ecase type
1176 ((string simple-string
) 'character
)
1177 ((base-string simple-base-string
) 'base-char
)))
1178 (lvar-values (loop for lvar in lvars
1179 collect
(when (constant-lvar-p lvar
)
1180 (lvar-value lvar
))))
1182 (loop for value in lvar-values
1186 `(sb!impl
::string-dispatch
((simple-array * (*))
1189 (declare (muffle-conditions compiler-note
))
1193 (declare (ignorable ,@vars
))
1194 (declare (optimize (insert-array-bounds-checks 0)))
1195 (let* ((.length.
(+ ,@lengths
))
1197 (.string.
(make-string .length.
:element-type
',element-type
)))
1198 (declare (type index .length. .pos.
)
1199 (muffle-conditions compiler-note
))
1200 ,@(loop for value in lvar-values
1202 collect
(if (and (stringp value
)
1203 (< (length value
) *concatenate-open-code-limit
*))
1204 ;; Fold the array reads for constant arguments
1206 ,@(loop for c across value
1209 ;; Without truly-the we get massive numbers
1210 ;; of pointless error traps.
1211 `(setf (aref .string.
1212 (truly-the index
(+ .pos.
,i
)))
1214 (incf .pos.
,(length value
)))
1215 `(sb!impl
::string-dispatch
1217 (simple-array character
(*))
1218 (simple-array base-char
(*))
1221 (replace .string.
,var
:start1 .pos.
)
1222 (incf .pos.
(length ,var
)))))
1226 ;;;; CONS accessor DERIVE-TYPE optimizers
1228 (defoptimizer (car derive-type
) ((cons))
1229 ;; This and CDR needs to use LVAR-CONSERVATIVE-TYPE because type inference
1230 ;; gets confused by things like (SETF CAR).
1231 (let ((type (lvar-conservative-type cons
))
1232 (null-type (specifier-type 'null
)))
1233 (cond ((eq type null-type
)
1236 (cons-type-car-type type
)))))
1238 (defoptimizer (cdr derive-type
) ((cons))
1239 (let ((type (lvar-conservative-type cons
))
1240 (null-type (specifier-type 'null
)))
1241 (cond ((eq type null-type
)
1244 (cons-type-cdr-type type
)))))
1246 ;;;; FIND, POSITION, and their -IF and -IF-NOT variants
1248 ;;; We want to make sure that %FIND-POSITION is inline-expanded into
1249 ;;; %FIND-POSITION-IF only when %FIND-POSITION-IF has an inline
1250 ;;; expansion, so we factor out the condition into this function.
1251 (defun check-inlineability-of-find-position-if (sequence from-end
)
1252 (let ((ctype (lvar-type sequence
)))
1253 (cond ((csubtypep ctype
(specifier-type 'vector
))
1254 ;; It's not worth trying to inline vector code unless we
1255 ;; know a fair amount about it at compile time.
1256 (upgraded-element-type-specifier-or-give-up sequence
)
1257 (unless (constant-lvar-p from-end
)
1258 (give-up-ir1-transform
1259 "FROM-END argument value not known at compile time")))
1260 ((csubtypep ctype
(specifier-type 'list
))
1261 ;; Inlining on lists is generally worthwhile.
1264 (give-up-ir1-transform
1265 "sequence type not known at compile time")))))
1267 ;;; %FIND-POSITION-IF and %FIND-POSITION-IF-NOT for LIST data
1268 (macrolet ((def (name condition
)
1269 `(deftransform ,name
((predicate sequence from-end start end key
)
1270 (function list t t t function
)
1272 :policy
(> speed space
))
1276 (flet ((bounds-error ()
1277 (sequence-bounding-indices-bad-error sequence start end
)))
1278 (if (and end
(> start end
))
1280 (do ((slow sequence
(cdr slow
))
1281 (fast (cdr sequence
) (cddr fast
))
1282 (index 0 (+ index
1)))
1284 (if (and end
(> end index
))
1286 (return (values find position
))))
1287 ((and end
(>= index end
))
1288 (return (values find position
)))
1290 (circular-list-error sequence
)))
1292 (declare (list slow fast
))
1293 (when (>= index start
)
1294 (let* ((element (car slow
))
1295 (key-i (funcall key element
)))
1296 (,',condition
(funcall predicate key-i
)
1297 ;; This hack of dealing with non-NIL
1298 ;; FROM-END for list data by iterating
1299 ;; forward through the list and keeping
1300 ;; track of the last time we found a
1301 ;; match might be more screwy than what
1302 ;; the user expects, but it seems to be
1303 ;; allowed by the ANSI standard. (And
1304 ;; if the user is screwy enough to ask
1305 ;; for FROM-END behavior on list data,
1306 ;; turnabout is fair play.)
1308 ;; It's also not enormously efficient,
1309 ;; calling PREDICATE and KEY more often
1310 ;; than necessary; but all the
1311 ;; alternatives seem to have their own
1312 ;; efficiency problems.
1316 (return (values element index
)))))))))))))
1317 (def %find-position-if when
)
1318 (def %find-position-if-not unless
))
1320 ;;; %FIND-POSITION for LIST data can be expanded into %FIND-POSITION-IF
1321 ;;; without loss of efficiency. (I.e., the optimizer should be able
1322 ;;; to straighten everything out.)
1323 (deftransform %find-position
((item sequence from-end start end key test
)
1326 :policy
(> speed space
))
1328 '(%find-position-if
(let ((test-fun (%coerce-callable-to-fun test
)))
1329 ;; The order of arguments for asymmetric tests
1330 ;; (e.g. #'<, as opposed to order-independent
1331 ;; tests like #'=) is specified in the spec
1332 ;; section 17.2.1 -- the O/Zi stuff there.
1334 (funcall test-fun item i
)))
1339 (%coerce-callable-to-fun key
)))
1341 ;;; The inline expansions for the VECTOR case are saved as macros so
1342 ;;; that we can share them between the DEFTRANSFORMs and the default
1343 ;;; cases in the DEFUNs. (This isn't needed for the LIST case, because
1344 ;;; the DEFTRANSFORMs for LIST are less choosy about when to expand.)
1345 (defun %find-position-or-find-position-if-vector-expansion
(sequence-arg
1351 (with-unique-names (offset block index n-sequence sequence end
)
1352 `(let* ((,n-sequence
,sequence-arg
))
1353 (with-array-data ((,sequence
,n-sequence
:offset-var
,offset
)
1356 :check-fill-pointer t
)
1358 (macrolet ((maybe-return ()
1359 ;; WITH-ARRAY-DATA has already performed bounds
1360 ;; checking, so we can safely elide the checks
1361 ;; in the inner loop.
1362 '(let ((,element
(locally (declare (optimize (insert-array-bounds-checks 0)))
1363 (aref ,sequence
,index
))))
1367 (- ,index
,offset
)))))))
1370 ;; (If we aren't fastidious about declaring that
1371 ;; INDEX might be -1, then (FIND 1 #() :FROM-END T)
1372 ;; can send us off into never-never land, since
1373 ;; INDEX is initialized to -1.)
1374 of-type index-or-minus-1
1375 from
(1- ,end
) downto
,start do
1377 (loop for
,index of-type index from
,start below
,end do
1379 (values nil nil
))))))
1381 (def!macro %find-position-vector-macro
(item sequence
1382 from-end start end key test
)
1383 (with-unique-names (element)
1384 (%find-position-or-find-position-if-vector-expansion
1390 ;; (See the LIST transform for a discussion of the correct
1391 ;; argument order, i.e. whether the searched-for ,ITEM goes before
1392 ;; or after the checked sequence element.)
1393 `(funcall ,test
,item
(funcall ,key
,element
)))))
1395 (def!macro %find-position-if-vector-macro
(predicate sequence
1396 from-end start end key
)
1397 (with-unique-names (element)
1398 (%find-position-or-find-position-if-vector-expansion
1404 `(funcall ,predicate
(funcall ,key
,element
)))))
1406 (def!macro %find-position-if-not-vector-macro
(predicate sequence
1407 from-end start end key
)
1408 (with-unique-names (element)
1409 (%find-position-or-find-position-if-vector-expansion
1415 `(not (funcall ,predicate
(funcall ,key
,element
))))))
1417 ;;; %FIND-POSITION, %FIND-POSITION-IF and %FIND-POSITION-IF-NOT for
1419 (deftransform %find-position-if
((predicate sequence from-end start end key
)
1420 (function vector t t t function
)
1422 :policy
(> speed space
))
1424 (check-inlineability-of-find-position-if sequence from-end
)
1425 '(%find-position-if-vector-macro predicate sequence
1426 from-end start end key
))
1428 (deftransform %find-position-if-not
((predicate sequence from-end start end key
)
1429 (function vector t t t function
)
1431 :policy
(> speed space
))
1433 (check-inlineability-of-find-position-if sequence from-end
)
1434 '(%find-position-if-not-vector-macro predicate sequence
1435 from-end start end key
))
1437 (deftransform %find-position
((item sequence from-end start end key test
)
1438 (t vector t t t function function
)
1440 :policy
(> speed space
))
1442 (check-inlineability-of-find-position-if sequence from-end
)
1443 '(%find-position-vector-macro item sequence
1444 from-end start end key test
))
1446 (deftransform %find-position
((item sequence from-end start end key test
)
1447 (t bit-vector t t t t t
)
1449 (when (and test
(lvar-fun-is test
'(eq eql equal
)))
1451 (when (and key
(lvar-fun-is key
'(identity)))
1454 (delay-ir1-transform node
:optimize
)
1455 (give-up-ir1-transform "non-trivial :KEY or :TEST"))
1457 `(with-array-data ((bits sequence
:offset-var offset
)
1460 :check-fill-pointer t
)
1461 (let ((p ,(if (constant-lvar-p item
)
1462 (case (lvar-value item
)
1463 (0 `(%bit-position
/0 bits from-end start end
))
1464 (1 `(%bit-position
/1 bits from-end start end
))
1465 (otherwise (throw 'not-a-bit
`(values nil nil
))))
1466 `(%bit-position item bits from-end start end
))))
1468 (values item
(the index
(- (truly-the index p
) offset
)))
1469 (values nil nil
))))))
1471 (deftransform %find-position
((item sequence from-end start end key test
)
1472 (character string t t t function function
)
1474 :policy
(> speed space
))
1475 (if (eq '* (upgraded-element-type-specifier sequence
))
1477 `(sb!impl
::string-dispatch
((simple-array character
(*))
1478 (simple-array base-char
(*))
1479 (simple-array nil
(*)))
1481 (%find-position item sequence from-end start end key test
))))
1482 (if (csubtypep (lvar-type sequence
) (specifier-type 'simple-string
))
1484 ;; Otherwise we'd get three instances of WITH-ARRAY-DATA from
1486 `(with-array-data ((sequence sequence
:offset-var offset
)
1489 :check-fill-pointer t
)
1490 (multiple-value-bind (elt index
) ,form
1491 (values elt
(when (fixnump index
) (- index offset
)))))))
1492 ;; The type is known exactly, other transforms will take care of it.
1493 (give-up-ir1-transform)))
1495 ;;; logic to unravel :TEST, :TEST-NOT, and :KEY options in FIND,
1496 ;;; POSITION-IF, etc.
1497 (define-source-transform effective-find-position-test
(test test-not
)
1498 (once-only ((test test
)
1499 (test-not test-not
))
1501 ((and ,test
,test-not
)
1502 (error "can't specify both :TEST and :TEST-NOT"))
1503 (,test
(%coerce-callable-to-fun
,test
))
1505 ;; (Without DYNAMIC-EXTENT, this is potentially horribly
1506 ;; inefficient, but since the TEST-NOT option is deprecated
1507 ;; anyway, we don't care.)
1508 (complement (%coerce-callable-to-fun
,test-not
)))
1510 (define-source-transform effective-find-position-key
(key)
1511 (once-only ((key key
))
1513 (%coerce-callable-to-fun
,key
)
1516 (macrolet ((define-find-position (fun-name values-index
)
1517 `(deftransform ,fun-name
((item sequence
&key
1518 from-end
(start 0) end
1520 (t (or list vector
) &rest t
))
1521 '(nth-value ,values-index
1522 (%find-position item sequence
1525 (effective-find-position-key key
)
1526 (effective-find-position-test
1528 (define-find-position find
0)
1529 (define-find-position position
1))
1531 (macrolet ((define-find-position-if (fun-name values-index
)
1532 `(deftransform ,fun-name
((predicate sequence
&key
1535 (t (or list vector
) &rest t
))
1538 (%find-position-if
(%coerce-callable-to-fun predicate
)
1541 (effective-find-position-key key
))))))
1542 (define-find-position-if find-if
0)
1543 (define-find-position-if position-if
1))
1545 ;;; the deprecated functions FIND-IF-NOT and POSITION-IF-NOT. We
1546 ;;; didn't bother to worry about optimizing them, except note that on
1547 ;;; Sat, Oct 06, 2001 at 04:22:38PM +0100, Christophe Rhodes wrote on
1550 ;;; My understanding is that while the :test-not argument is
1551 ;;; deprecated in favour of :test (complement #'foo) because of
1552 ;;; semantic difficulties (what happens if both :test and :test-not
1553 ;;; are supplied, etc) the -if-not variants, while officially
1554 ;;; deprecated, would be undeprecated were X3J13 actually to produce
1555 ;;; a revised standard, as there are perfectly legitimate idiomatic
1556 ;;; reasons for allowing the -if-not versions equal status,
1557 ;;; particularly remove-if-not (== filter).
1559 ;;; This is only an informal understanding, I grant you, but
1560 ;;; perhaps it's worth optimizing the -if-not versions in the same
1561 ;;; way as the others?
1563 ;;; FIXME: Maybe remove uses of these deprecated functions within the
1564 ;;; implementation of SBCL.
1565 (macrolet ((define-find-position-if-not (fun-name values-index
)
1566 `(deftransform ,fun-name
((predicate sequence
&key
1569 (t (or list vector
) &rest t
))
1572 (%find-position-if-not
(%coerce-callable-to-fun predicate
)
1575 (effective-find-position-key key
))))))
1576 (define-find-position-if-not find-if-not
0)
1577 (define-find-position-if-not position-if-not
1))
1579 (macrolet ((define-trimmer-transform (fun-name leftp rightp
)
1580 `(deftransform ,fun-name
((char-bag string
)
1583 (if (constant-lvar-p char-bag
)
1584 ;; If the bag is constant, use MEMBER
1585 ;; instead of FIND, since we have a
1586 ;; deftransform for MEMBER that can
1587 ;; open-code all of the comparisons when
1588 ;; the list is constant. -- JES, 2007-12-10
1589 `(not (member (schar string index
)
1590 ',(coerce (lvar-value char-bag
) 'list
)
1592 '(not (find (schar string index
) char-bag
:test
#'char
=)))))
1593 `(flet ((char-not-in-bag (index)
1595 (let* ((end (length string
))
1596 (left-end (if ,',leftp
1597 (do ((index 0 (1+ index
)))
1598 ((or (= index
(the fixnum end
))
1599 (char-not-in-bag index
))
1601 (declare (fixnum index
)))
1603 (right-end (if ,',rightp
1604 (do ((index (1- end
) (1- index
)))
1605 ((or (< index left-end
)
1606 (char-not-in-bag index
))
1608 (declare (fixnum index
)))
1610 (if (and (eql left-end
0)
1611 (eql right-end
(length string
)))
1613 (subseq string left-end right-end
))))))))
1614 (define-trimmer-transform string-left-trim t nil
)
1615 (define-trimmer-transform string-right-trim nil t
)
1616 (define-trimmer-transform string-trim t t
))
1619 ;;; (partially) constant-fold backq-* functions, or convert to their
1620 ;;; plain CL equivalent (now that they're not needed for pprinting).
1622 ;; Pop constant values from the end, list/list* them if any, and link
1623 ;; the remainder with list* at runtime.
1624 (defun transform-backq-list-or-list* (function values
)
1625 (let ((gensyms (make-gensym-list (length values
)))
1626 (reverse (reverse values
))
1628 (loop while
(and reverse
1629 (constant-lvar-p (car reverse
)))
1630 do
(push (lvar-value (pop reverse
))
1632 (if (null constants
)
1634 (,function
,@gensyms
))
1635 (let ((tail (apply function constants
)))
1638 (let* ((nvariants (length reverse
))
1639 (variants (subseq gensyms
0 nvariants
)))
1641 (declare (ignore ,@(subseq gensyms nvariants
)))
1643 `(list* ,@variants
',tail
)
1644 `(list ,@variants
)))))))))
1646 (deftransform sb
!impl
::backq-list
((&rest elts
))
1647 (transform-backq-list-or-list* 'list elts
))
1649 (deftransform sb
!impl
::backq-list
* ((&rest elts
))
1650 (transform-backq-list-or-list* 'list
* elts
))
1652 ;; Merge adjacent constant values
1653 (deftransform sb
!impl
::backq-append
((&rest elts
))
1654 (let ((gensyms (make-gensym-list (length elts
)))
1658 (flet ((convert-accumulator ()
1659 (let ((constant (apply 'append
(nreverse (shiftf acc nil
)))))
1661 (push `',constant arguments
)))))
1662 (loop for gensym in gensyms
1663 for
(elt . next
) on elts by
#'cdr
1664 do
(cond ((constant-lvar-p elt
)
1665 (let ((elt (lvar-value elt
)))
1666 (when (and next
(not (proper-list-p elt
)))
1667 (abort-ir1-transform
1668 "Non-list or improper list spliced in ~
1669 the middle of a backquoted list."))
1670 (push gensym ignored
)
1673 (convert-accumulator)
1674 (push gensym arguments
)))
1675 finally
(convert-accumulator)))
1676 (let ((arguments (nreverse arguments
)))
1678 (declare (ignore ,@ignored
))
1679 (append ,@arguments
)))))
1681 ;; Nothing special for nconc
1682 (define-source-transform sb
!impl
::backq-nconc
(&rest elts
)
1685 ;; cons and vector are handled with regular constant folding...
1686 ;; but we still want to convert backq-cons into cl:cons.
1687 (deftransform sb
!impl
::backq-cons
((x y
))