;;; MAP-INTO. RESULT and BODY are forms, which can use variables
;;; FUNCALL-RESULT, containing the result of application of FUN, and
;;; INDEX, containing the current position in sequences.
-(defun build-sequence-iterator (seqs seq-names &key result into body)
+(defun build-sequence-iterator (seqs seq-names &key result into body fast)
(declare (type list seqs seq-names)
(type symbol into))
(collect ((bindings)
(declarations)
(vector-lengths)
(tests)
- (places))
+ (places)
+ (around))
(let ((found-vector-p nil))
(flet ((process-vector (length)
(unless found-vector-p
(declarations `(type list ,index))
(places `(car ,index))
(tests `(endp ,index))))
- ((csubtypep type (specifier-type 'vector))
+ ((or (csubtypep type (specifier-type '(simple-array * 1)))
+ (and (not fast)
+ (csubtypep type (specifier-type 'vector))))
(process-vector `(length ,seq-name))
(places `(locally (declare (optimize (insert-array-bounds-checks 0)))
(aref ,seq-name index))))
+ ((csubtypep type (specifier-type 'vector))
+ (let ((data (gensym "DATA"))
+ (start (gensym "START"))
+ (end (gensym "END")))
+ (around `(with-array-data ((,data ,seq-name)
+ (,start)
+ (,end (length ,seq-name)))))
+ (process-vector `(- ,end ,start))
+ (places `(locally (declare (optimize (insert-array-bounds-checks 0)))
+ (aref ,data (truly-the index (+ index ,start)))))))
(t
(give-up-ir1-transform
"can't determine sequence argument type"))))
(when found-vector-p
(bindings `(length (min ,@(vector-lengths))))
(tests `(>= index length)))
- `(do (,@(bindings))
- ((or ,@(tests)) ,result)
- (declare ,@(declarations))
- (let ((funcall-result (funcall fun ,@(places))))
- (declare (ignorable funcall-result))
- ,body)))))
+ (let ((body `(do (,@(bindings))
+ ((or ,@(tests)) ,result)
+ (declare ,@(declarations))
+ (let ((funcall-result (funcall fun ,@(places))))
+ (declare (ignorable funcall-result))
+ ,body))))
+ (if (around)
+ (reduce (lambda (wrap body) (append wrap (list body)))
+ (around)
+ :from-end t
+ :initial-value body)
+ body)))))
;;; Try to compile %MAP efficiently when we can determine sequence
;;; argument types at compile time.
;;; the reader, because the code is complicated enough already and I
;;; don't happen to need that functionality right now. -- WHN 20000410
(deftransform %map ((result-type fun seq &rest seqs) * *
- :policy (>= speed space))
+ :node node :policy (>= speed space))
"open code"
(unless (constant-lvar-p result-type)
(give-up-ir1-transform "RESULT-TYPE argument not constant"))
,(build-sequence-iterator
seqs seq-args
:result result
- :body push-dacc))))))))))
+ :body push-dacc
+ :fast (policy node (> speed space))))))))))))
;;; MAP-INTO
(deftransform map-into ((result fun &rest seqs)
(vector * &rest *)
- *)
+ * :node node)
"open code"
(let ((seqs-names (mapcar (lambda (x)
(declare (ignore x))
(gensym))
seqs)))
`(lambda (result fun ,@seqs-names)
- ,(build-sequence-iterator
- seqs seqs-names
- :result '(when (array-has-fill-pointer-p result)
- (setf (fill-pointer result) index))
- :into 'result
- :body '(locally (declare (optimize (insert-array-bounds-checks 0)))
- (setf (aref result index) funcall-result)))
+ ,(if (and (policy node (> speed space))
+ (not (csubtypep (lvar-type result)
+ (specifier-type '(simple-array * 1)))))
+ (let ((data (gensym "DATA"))
+ (start (gensym "START"))
+ (end (gensym "END")))
+ `(with-array-data ((,data result)
+ (,start)
+ (,end))
+ (declare (ignore ,end))
+ ,(build-sequence-iterator
+ seqs seqs-names
+ :result '(when (array-has-fill-pointer-p result)
+ (setf (fill-pointer result) index))
+ :into 'result
+ :body `(locally (declare (optimize (insert-array-bounds-checks 0)))
+ (setf (aref ,data (truly-the index (+ index ,start)))
+ funcall-result))
+ :fast t)))
+ (build-sequence-iterator
+ seqs seqs-names
+ :result '(when (array-has-fill-pointer-p result)
+ (setf (fill-pointer result) index))
+ :into 'result
+ :body '(locally (declare (optimize (insert-array-bounds-checks 0)))
+ (setf (aref result index) funcall-result))))
result)))
\f
'(nth i s))
(deftransform %setelt ((s i v) ((simple-array * (*)) * *) *)
- '(%aset s i v))
+ '(setf (aref s i) v))
(deftransform %setelt ((s i v) (list * *) * :policy (< safety 3))
'(setf (car (nthcdr i s)) v))
(or end length)
(sequence-bounding-indices-bad-error vector start end)))))
+(def!type eq-comparable-type ()
+ '(or fixnum (not number)))
+
+;;; True if EQL comparisons involving type can be simplified to EQ.
+(defun eq-comparable-type-p (type)
+ (csubtypep type (specifier-type 'eq-comparable-type)))
+
(defun specialized-list-seek-function-name (function-name key-functions &optional variant)
(or (find-symbol (with-output-to-string (s)
;; Write "%NAME-FUN1-FUN2-FUN3", etc. Not only is
(bug "Unknown list item seek transform: name=~S, key-functions=~S variant=~S"
function-name key-functions variant)))
+(defparameter *list-open-code-limit* 128)
+
(defun transform-list-item-seek (name item list key test test-not node)
+ (when (and test test-not)
+ (abort-ir1-transform "Both ~S and ~S supplied to ~S." :test :test-not name))
;; If TEST is EQL, drop it.
(when (and test (lvar-fun-is test '(eql)))
(setf test nil))
(%coerce-callable-to-fun key)
#'identity)))
(t
- (values key '(%coerce-callable-to-fun key))))))
+ (values key (ensure-lvar-fun-form key 'key))))))
(let* ((c-test (cond ((and test (lvar-fun-is test '(eq)))
(setf test nil)
'eq)
((and (not test) (not test-not))
(when (eq-comparable-type-p (lvar-type item))
'eq))))
- (funs (remove nil (list (and key 'key) (cond (test 'test)
- (test-not 'test-not)))))
+ (funs (delete nil (list (when key (list key 'key))
+ (when test (list test 'test))
+ (when test-not (list test-not 'test-not)))))
(target-expr (if key '(%funcall key target) 'target))
(test-expr (cond (test `(%funcall test item ,target-expr))
(test-not `(not (%funcall test-not item ,target-expr)))
((assoc rassoc) (car tail))
(member tail))
,(open-code (cdr tail)))))
- (ensure-fun (fun)
- (if (eq 'key fun)
+ (ensure-fun (args)
+ (if (eq 'key (second args))
key-form
- `(%coerce-callable-to-fun ,fun))))
+ (apply #'ensure-lvar-fun-form args))))
(let* ((cp (constant-lvar-p list))
(c-list (when cp (lvar-value list))))
(cond ((and cp c-list (member name '(assoc rassoc member))
- (policy node (>= speed space)))
- `(let ,(mapcar (lambda (fun) `(,fun ,(ensure-fun fun))) funs)
+ (policy node (>= speed space))
+ (not (nthcdr *list-open-code-limit* c-list)))
+ `(let ,(mapcar (lambda (fun) `(,(second fun) ,(ensure-fun fun))) funs)
,(open-code c-list)))
((and cp (not c-list))
;; constant nil list
nil))
(t
;; specialized out-of-line version
- `(,(specialized-list-seek-function-name name funs c-test)
+ `(,(specialized-list-seek-function-name name (mapcar #'second funs) c-test)
item list ,@(mapcar #'ensure-fun funs)))))))))
(defun transform-list-pred-seek (name pred list key node)
(%coerce-callable-to-fun key)
#'identity)))
(t
- (values key '(%coerce-callable-to-fun key))))))
+ (values key (ensure-lvar-fun-form key 'key))))))
(let ((test-expr `(%funcall pred ,(if key '(%funcall key target) 'target)))
- (pred-expr (if (csubtypep (lvar-type pred) (specifier-type 'function))
- 'pred
- '(%coerce-callable-to-fun pred))))
+ (pred-expr (ensure-lvar-fun-form pred 'pred)))
(when (member name '(member-if-not assoc-if-not rassoc-if-not))
(setf test-expr `(not ,test-expr)))
(labels ((open-code (tail)
,(open-code (cdr tail))))))
(let* ((cp (constant-lvar-p list))
(c-list (when cp (lvar-value list))))
- (cond ((and cp c-list (policy node (>= speed space)))
+ (cond ((and cp c-list (policy node (>= speed space))
+ (not (nthcdr *list-open-code-limit* c-list)))
`(let ((pred ,pred-expr)
,@(when key `((key ,key-form))))
,(open-code c-list)))
,pred-expr list ,@(when key (list key-form))))))))))
(macrolet ((def (name &optional if/if-not)
- `(progn
- (deftransform ,name ((item list &key key test test-not) * * :node node)
- (transform-list-item-seek ',name item list key test test-not node))
- ,@(when if/if-not
- (let ((if-name (symbolicate name "-IF"))
- (if-not-name (symbolicate name "-IF-NOT")))
- `((deftransform ,if-name ((pred list &key key) * * :node node)
- (transform-list-pred-seek ',if-name pred list key node))
- (deftransform ,if-not-name ((pred list &key key) * * :node node)
- (transform-list-pred-seek ',if-not-name pred list key node))))))))
+ (let ((basic (symbolicate "%" name))
+ (basic-eq (symbolicate "%" name "-EQ"))
+ (basic-key (symbolicate "%" name "-KEY"))
+ (basic-key-eq (symbolicate "%" name "-KEY-EQ")))
+ `(progn
+ (deftransform ,name ((item list &key key test test-not) * * :node node)
+ (transform-list-item-seek ',name item list key test test-not node))
+ (deftransform ,basic ((item list) (eq-comparable-type t))
+ `(,',basic-eq item list))
+ (deftransform ,basic-key ((item list) (eq-comparable-type t))
+ `(,',basic-key-eq item list))
+ ,@(when if/if-not
+ (let ((if-name (symbolicate name "-IF"))
+ (if-not-name (symbolicate name "-IF-NOT")))
+ `((deftransform ,if-name ((pred list &key key) * * :node node)
+ (transform-list-pred-seek ',if-name pred list key node))
+ (deftransform ,if-not-name ((pred list &key key) * * :node node)
+ (transform-list-pred-seek ',if-not-name pred list key node)))))))))
(def adjoin)
(def assoc t)
(def member t)
;;; almost as fast as MEMQ.
(deftransform delete ((item list &key test) (t list &rest t) *)
"convert to EQ test"
- ;; FIXME: The scope of this transformation could be
- ;; widened somewhat, letting it work whenever the test is
- ;; 'EQL and we know from the type of ITEM that it #'EQ
- ;; works like #'EQL on it. (E.g. types FIXNUM, CHARACTER,
- ;; and SYMBOL.)
- ;; If TEST is EQ, apply transform, else
- ;; if test is not EQL, then give up on transform, else
- ;; if ITEM is not a NUMBER or is a FIXNUM, apply
- ;; transform, else give up on transform.
- (cond (test
- (unless (lvar-fun-is test '(eq))
- (give-up-ir1-transform)))
- ((types-equal-or-intersect (lvar-type item)
- (specifier-type 'number))
- (give-up-ir1-transform "Item might be a number.")))
+ (let ((type (lvar-type item)))
+ (unless (or (and test (lvar-fun-is test '(eq)))
+ (and (eq-comparable-type-p type)
+ (or (not test) (lvar-fun-is test '(eql)))))
+ (give-up-ir1-transform)))
`(delq item list))
(deftransform delete-if ((pred list) (t list))
(vector t &key (:start t) (:end t))
*
:node node)
- (let ((type (lvar-type seq))
- (element-type (type-specifier (extract-upgraded-element-type seq))))
- (cond ((and (neq '* element-type) (policy node (> speed space)))
+ (let* ((type (lvar-type seq))
+ (element-ctype (array-type-upgraded-element-type type))
+ (element-type (type-specifier element-ctype))
+ (saetp (unless (eq *wild-type* element-ctype)
+ (find-saetp-by-ctype element-ctype))))
+ (cond ((eq *wild-type* element-ctype)
+ (delay-ir1-transform node :constraint)
+ `(vector-fill* seq item start end))
+ ((and saetp (sb!vm::valid-bit-bash-saetp-p saetp))
+ (let* ((n-bits (sb!vm:saetp-n-bits saetp))
+ (basher-name (format nil "UB~D-BASH-FILL" n-bits))
+ (basher (or (find-symbol basher-name
+ (load-time-value (find-package :sb!kernel)))
+ (abort-ir1-transform
+ "Unknown fill basher, please report to sbcl-devel: ~A"
+ basher-name)))
+ (kind (cond ((sb!vm:saetp-fixnum-p saetp) :tagged)
+ ((member element-type '(character base-char)) :char)
+ ((eq element-type 'single-float) :single-float)
+ #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
+ ((eq element-type 'double-float) :double-float)
+ #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
+ ((equal element-type '(complex single-float))
+ :complex-single-float)
+ (t
+ (aver (integer-type-p element-ctype))
+ :bits)))
+ ;; BASH-VALUE is a word that we can repeatedly smash
+ ;; on the array: for less-than-word sized elements it
+ ;; contains multiple copies of the fill item.
+ (bash-value
+ (if (constant-lvar-p item)
+ (let ((tmp (lvar-value item)))
+ (unless (ctypep tmp element-ctype)
+ (abort-ir1-transform "~S is not ~S" tmp element-type))
+ (let* ((bits
+ (ldb (byte n-bits 0)
+ (ecase kind
+ (:tagged
+ (ash tmp sb!vm:n-fixnum-tag-bits))
+ (:char
+ (char-code tmp))
+ (:bits
+ tmp)
+ (:single-float
+ (single-float-bits tmp))
+ #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
+ (:double-float
+ (logior (ash (double-float-high-bits tmp) 32)
+ (double-float-low-bits tmp)))
+ #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
+ (:complex-single-float
+ (logior (ash (single-float-bits (imagpart tmp)) 32)
+ (ldb (byte 32 0)
+ (single-float-bits (realpart tmp))))))))
+ (res bits))
+ (loop for i of-type sb!vm:word from n-bits by n-bits
+ until (= i sb!vm:n-word-bits)
+ do (setf res (ldb (byte sb!vm:n-word-bits 0)
+ (logior res (ash bits i)))))
+ res))
+ (progn
+ (delay-ir1-transform node :constraint)
+ `(let* ((bits (ldb (byte ,n-bits 0)
+ ,(ecase kind
+ (:tagged
+ `(ash item ,sb!vm:n-fixnum-tag-bits))
+ (:char
+ `(char-code item))
+ (:bits
+ `item)
+ (:single-float
+ `(single-float-bits item))
+ #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
+ (:double-float
+ `(logior (ash (double-float-high-bits item) 32)
+ (double-float-low-bits item)))
+ #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
+ (:complex-single-float
+ `(logior (ash (single-float-bits (imagpart item)) 32)
+ (ldb (byte 32 0)
+ (single-float-bits (realpart item))))))))
+ (res bits))
+ (declare (type sb!vm:word res))
+ ,@(unless (= sb!vm:n-word-bits n-bits)
+ `((loop for i of-type sb!vm:word from ,n-bits by ,n-bits
+ until (= i sb!vm:n-word-bits)
+ do (setf res
+ (ldb (byte ,sb!vm:n-word-bits 0)
+ (logior res (ash bits (truly-the (integer 0 ,(- sb!vm:n-word-bits n-bits)) i))))))))
+ res)))))
+ (values
+ ;; KLUDGE: WITH-ARRAY data in its full glory is going to mess up
+ ;; dynamic-extent for MAKE-ARRAY :INITIAL-ELEMENT initialization.
+ (if (csubtypep (lvar-type seq) (specifier-type '(simple-array * (*))))
+ `(let* ((len (length seq))
+ (end (or end len))
+ (bound (1+ end)))
+ ;; Minor abuse %CHECK-BOUND for bounds checking.
+ ;; (- END START) may still end up negative, but
+ ;; the basher handle that.
+ (,basher ,bash-value seq
+ (%check-bound seq bound start)
+ (- (if end (%check-bound seq bound end) len)
+ start)))
+ `(with-array-data ((data seq)
+ (start start)
+ (end end)
+ :check-fill-pointer t)
+ (declare (type (simple-array ,element-type 1) data))
+ (declare (type index start end))
+ (declare (optimize (safety 0) (speed 3)))
+ (,basher ,bash-value data start (- end start))
+ seq))
+ `((declare (type ,element-type item))))))
+ ((policy node (> speed space))
(values
`(with-array-data ((data seq)
(start start)
:start start
:end (%check-generic-sequence-bounds seq start end)))
\f
-;;;; utilities
-
-;;; If LVAR is a constant lvar, the return the constant value. If it
-;;; is null, then return default, otherwise quietly give up the IR1
-;;; transform.
-;;;
-;;; ### Probably should take an ARG and flame using the NAME.
-(defun constant-value-or-lose (lvar &optional default)
- (declare (type (or lvar null) lvar))
- (cond ((not lvar) default)
- ((constant-lvar-p lvar)
- (lvar-value lvar))
- (t
- (give-up-ir1-transform))))
-
-
;;;; hairy sequence transforms
;;; FIXME: no hairy sequence transforms in SBCL?
(def!constant vector-data-bit-offset
(* sb!vm:vector-data-offset sb!vm:n-word-bits))
-(eval-when (:compile-toplevel)
-(defun valid-bit-bash-saetp-p (saetp)
- ;; BIT-BASHing isn't allowed on simple vectors that contain pointers
- (and (not (eq t (sb!vm:saetp-specifier saetp)))
- ;; Disallowing (VECTOR NIL) also means that we won't transform
- ;; sequence functions into bit-bashing code and we let the
- ;; generic sequence functions signal errors if necessary.
- (not (zerop (sb!vm:saetp-n-bits saetp)))
- ;; Due to limitations with the current BIT-BASHing code, we can't
- ;; BIT-BASH reliably on arrays whose element types are larger
- ;; than the word size.
- (<= (sb!vm:saetp-n-bits saetp) sb!vm:n-word-bits)))
-) ; EVAL-WHEN
-
;;; FIXME: In the copy loops below, we code the loops in a strange
;;; fashion:
;;;
;;; you tweak it, make sure that you compare the disassembly, if not the
;;; performance of, the functions implementing string streams
;;; (e.g. SB!IMPL::STRING-OUCH).
-(eval-when (:compile-toplevel :load-toplevel :execute)
+(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
(defun make-replace-transform (saetp sequence-type1 sequence-type2)
`(deftransform replace ((seq1 seq2 &key (start1 0) (start2 0) end1 end2)
(,sequence-type1 ,sequence-type2 &rest t)
,sequence-type1
:node node)
- ,(cond
- ((and saetp (valid-bit-bash-saetp-p saetp)) nil)
- ;; If the sequence types are different, SEQ1 and SEQ2 must
- ;; be distinct arrays, and we can open code the copy loop.
- ((not (eql sequence-type1 sequence-type2)) nil)
- ;; If we're not bit-bashing, only allow cases where we
- ;; can determine the order of copying up front. (There
- ;; are actually more cases we can handle if we know the
- ;; amount that we're copying, but this handles the
- ;; common cases.)
- (t '(unless (= (constant-value-or-lose start1 0)
- (constant-value-or-lose start2 0))
- (give-up-ir1-transform))))
`(let* ((len1 (length seq1))
(len2 (length seq2))
(end1 (or end1 len1))
(end2 (or end2 len2))
- (replace-len1 (- end1 start1))
- (replace-len2 (- end2 start2)))
- ,(unless (policy node (= safety 0))
+ (replace-len (min (- end1 start1) (- end2 start2))))
+ ,(unless (policy node (= insert-array-bounds-checks 0))
`(progn
- (unless (<= 0 start1 end1 len1)
- (sequence-bounding-indices-bad-error seq1 start1 end1))
- (unless (<= 0 start2 end2 len2)
- (sequence-bounding-indices-bad-error seq2 start2 end2))))
+ (unless (<= 0 start1 end1 len1)
+ (sequence-bounding-indices-bad-error seq1 start1 end1))
+ (unless (<= 0 start2 end2 len2)
+ (sequence-bounding-indices-bad-error seq2 start2 end2))))
,',(cond
- ((and saetp (valid-bit-bash-saetp-p saetp))
- (let* ((n-element-bits (sb!vm:saetp-n-bits saetp))
- (bash-function (intern (format nil "UB~D-BASH-COPY"
- n-element-bits)
- (find-package "SB!KERNEL"))))
- `(funcall (function ,bash-function) seq2 start2
- seq1 start1 (min replace-len1 replace-len2))))
- (t
- ;; We can expand the loop inline here because we
- ;; would have given up the transform (see above)
- ;; if we didn't have constant matching start
- ;; indices.
- '(do ((i start1 (1+ i))
- (j start2 (1+ j))
- (end (+ start1
- (min replace-len1 replace-len2))))
- ((>= i end))
- (declare (optimize (insert-array-bounds-checks 0)))
- (setf (aref seq1 i) (aref seq2 j)))))
+ ((and saetp (sb!vm:valid-bit-bash-saetp-p saetp))
+ (let* ((n-element-bits (sb!vm:saetp-n-bits saetp))
+ (bash-function (intern (format nil "UB~D-BASH-COPY"
+ n-element-bits)
+ (find-package "SB!KERNEL"))))
+ `(funcall (function ,bash-function) seq2 start2
+ seq1 start1 replace-len)))
+ (t
+ `(if (and
+ ;; If the sequence types are different, SEQ1 and
+ ;; SEQ2 must be distinct arrays.
+ ,(eql sequence-type1 sequence-type2)
+ (eq seq1 seq2) (> start1 start2))
+ (do ((i (truly-the index (+ start1 replace-len -1))
+ (1- i))
+ (j (truly-the index (+ start2 replace-len -1))
+ (1- j)))
+ ((< i start1))
+ (declare (optimize (insert-array-bounds-checks 0)))
+ (setf (aref seq1 i) (aref seq2 j)))
+ (do ((i start1 (1+ i))
+ (j start2 (1+ j))
+ (end (+ start1 replace-len)))
+ ((>= i end))
+ (declare (optimize (insert-array-bounds-checks 0)))
+ (setf (aref seq1 i) (aref seq2 j))))))
seq1))))
(macrolet
(let ((type (lvar-type seq)))
(cond
((and (array-type-p type)
- (csubtypep type (specifier-type '(or (simple-unboxed-array (*)) simple-vector))))
+ (csubtypep type (specifier-type '(or (simple-unboxed-array (*)) simple-vector)))
+ (policy node (> speed space)))
(let ((element-type (type-specifier (array-type-specialized-element-type type))))
`(let* ((length (length seq))
(end (or end length)))
'start)
'result 0 'size element-type)
result))))
- ((csubtypep type (specifier-type 'string))
- '(string-subseq* seq start end))
(t
'(vector-subseq* seq start end)))))
(result (make-array length :element-type ',element-type)))
,(maybe-expand-copy-loop-inline 'seq 0 'result 0 'length element-type)
result)))
- ((csubtypep type (specifier-type 'string))
- '(string-subseq* seq 0 nil))
(t
'(vector-subseq* seq 0 nil)))))
:node node
:policy (> speed (max space safety)))
"open code"
- (let ((from-end (when (lvar-p from-end)
- (unless (constant-lvar-p from-end)
- (give-up-ir1-transform ":FROM-END is not constant."))
- (lvar-value from-end)))
- (keyp (lvar-p key))
- (testp (lvar-p test))
- (check-bounds-p (policy node (plusp insert-array-bounds-checks))))
- `(block search
- (flet ((oops (vector start end)
- (sequence-bounding-indices-bad-error vector start end)))
- (let* ((len1 (length pattern))
- (len2 (length text))
- (end1 (or end1 len1))
- (end2 (or end2 len2))
- ,@(when keyp
- '((key (coerce key 'function))))
- ,@(when testp
- '((test (coerce test 'function)))))
- (declare (type index start1 start2 end1 end2))
- ,@(when check-bounds-p
- `((unless (<= start1 end1 len1)
- (oops pattern start1 end1))
- (unless (<= start2 end2 len2)
- (oops pattern start2 end2))))
- (do (,(if from-end
- '(index2 (- end2 (- end1 start1)) (1- index2))
- '(index2 start2 (1+ index2))))
- (,(if from-end
- '(< index2 start2)
- '(>= index2 end2))
- nil)
- ;; INDEX2 is FIXNUM, not an INDEX, as right before the loop
- ;; terminates is hits -1 when :FROM-END is true and :START2
- ;; is 0.
- (declare (type fixnum index2))
- (when (do ((index1 start1 (1+ index1))
- (index2 index2 (1+ index2)))
- ((>= index1 end1) t)
- (declare (type index index1 index2)
- (optimize (insert-array-bounds-checks 0)))
- ,@(unless from-end
- '((when (= index2 end2)
- (return-from search nil))))
- (unless (,@(if testp
- '(funcall test)
- '(eql))
- ,(if keyp
- '(funcall key (aref pattern index1))
- '(aref pattern index1))
- ,(if keyp
- '(funcall key (aref text index2))
- '(aref text index2)))
- (return nil)))
- (return index2))))))))
+ (flet ((maybe (x)
+ (when (lvar-p x)
+ (if (constant-lvar-p x)
+ (when (lvar-value x)
+ :yes)
+ :maybe))))
+ (let ((from-end (when (lvar-p from-end)
+ (unless (constant-lvar-p from-end)
+ (give-up-ir1-transform ":FROM-END is not constant."))
+ (lvar-value from-end)))
+ (key? (maybe key))
+ (test? (maybe test))
+ (check-bounds-p (policy node (plusp insert-array-bounds-checks))))
+ `(block search
+ (flet ((oops (vector start end)
+ (sequence-bounding-indices-bad-error vector start end)))
+ (let* ((len1 (length pattern))
+ (len2 (length text))
+ (end1 (or end1 len1))
+ (end2 (or end2 len2))
+ ,@(case key?
+ (:yes `((key (%coerce-callable-to-fun key))))
+ (:maybe `((key (when key
+ (%coerce-callable-to-fun key))))))
+ ,@(when test?
+ `((test (%coerce-callable-to-fun test)))))
+ (declare (type index start1 start2 end1 end2))
+ ,@(when check-bounds-p
+ `((unless (<= start1 end1 len1)
+ (oops pattern start1 end1))
+ (unless (<= start2 end2 len2)
+ (oops pattern start2 end2))))
+ (when (= end1 start1)
+ (return-from search (if from-end
+ end2
+ start2)))
+ (do (,(if from-end
+ '(index2 (- end2 (- end1 start1)) (1- index2))
+ '(index2 start2 (1+ index2))))
+ (,(if from-end
+ '(< index2 start2)
+ '(>= index2 end2))
+ nil)
+ ;; INDEX2 is FIXNUM, not an INDEX, as right before the loop
+ ;; terminates is hits -1 when :FROM-END is true and :START2
+ ;; is 0.
+ (declare (type fixnum index2))
+ (when (do ((index1 start1 (1+ index1))
+ (index2 index2 (1+ index2)))
+ ((>= index1 end1) t)
+ (declare (type index index1 index2)
+ (optimize (insert-array-bounds-checks 0)))
+ ,@(unless from-end
+ '((when (= index2 end2)
+ (return-from search nil))))
+ (unless (,@(if test?
+ `(funcall test)
+ `(eql))
+ ,(case key?
+ (:yes `(funcall key (aref pattern index1)))
+ (:maybe `(let ((elt (aref pattern index1)))
+ (if key
+ (funcall key elt)
+ elt)))
+ (otherwise `(aref pattern index1)))
+ ,(case key?
+ (:yes `(funcall key (aref text index2)))
+ (:maybe `(let ((elt (aref text index2)))
+ (if key
+ (funcall key elt)
+ elt)))
+ (otherwise `(aref text index2))))
+ (return nil)))
+ (return index2)))))))))
;;; Open-code CONCATENATE for strings. It would be possible to extend
;;; this transform to non-strings, but I chose to just do the case that
;;; should cover 95% of CONCATENATE performance complaints for now.
;;; -- JES, 2007-11-17
+;;;
+;;; Only handle the simple result type cases. If somebody does (CONCATENATE
+;;; '(STRING 6) ...) their code won't be optimized, but nobody does that in
+;;; practice.
+;;;
+;;; Limit full open coding based on length of constant sequences. Default
+;;; value is chosen so that other parts of the compiler (constraint propagation
+;;; mainly) won't go nonlinear too badly. It's not an exact number -- but
+;;; in the right ballpark.
+(defvar *concatenate-open-code-limit* 129)
+
(deftransform concatenate ((result-type &rest lvars)
- (symbol &rest sequence)
- *
- :policy (> speed space))
- (unless (constant-lvar-p result-type)
- (give-up-ir1-transform))
- (let* ((element-type (let ((type (lvar-value result-type)))
- ;; Only handle the simple result type cases. If
- ;; somebody does (CONCATENATE '(STRING 6) ...)
- ;; their code won't be optimized, but nobody does
- ;; that in practice.
- (case type
- ((string simple-string) 'character)
- ((base-string simple-base-string) 'base-char)
- (t (give-up-ir1-transform)))))
- (vars (loop for x in lvars collect (gensym)))
- (lvar-values (loop for lvar in lvars
- collect (when (constant-lvar-p lvar)
- (lvar-value lvar))))
- (lengths
- (loop for value in lvar-values
- for var in vars
- collect (if value
- (length value)
- `(sb!impl::string-dispatch ((simple-array * (*))
- sequence)
- ,var
- (declare (muffle-conditions compiler-note))
- (length ,var))))))
- `(apply
- (lambda ,vars
- (declare (ignorable ,@vars))
- (let* ((.length. (+ ,@lengths))
- (.pos. 0)
- (.string. (make-string .length. :element-type ',element-type)))
- (declare (type index .length. .pos.)
- (muffle-conditions compiler-note))
- ,@(loop for value in lvar-values
- for var in vars
- collect (if (stringp value)
- ;; Fold the array reads for constant arguments
- `(progn
- ,@(loop for c across value
- collect `(setf (aref .string.
- .pos.) ,c)
- collect `(incf .pos.)))
- `(sb!impl::string-dispatch
- (#!+sb-unicode
- (simple-array character (*))
- (simple-array base-char (*))
- t)
- ,var
- (replace .string. ,var :start1 .pos.)
- (incf .pos. (length ,var)))))
- .string.))
- lvars)))
+ ((constant-arg
+ (member string simple-string base-string simple-base-string))
+ &rest sequence)
+ * :node node)
+ (let ((vars (loop for x in lvars collect (gensym)))
+ (type (lvar-value result-type)))
+ (if (policy node (<= speed space))
+ ;; Out-of-line
+ `(lambda (.dummy. ,@vars)
+ (declare (ignore .dummy.))
+ ,(ecase type
+ ((string simple-string)
+ `(%concatenate-to-string ,@vars))
+ ((base-string simple-base-string)
+ `(%concatenate-to-base-string ,@vars))))
+ ;; Inline
+ (let* ((element-type (ecase type
+ ((string simple-string) 'character)
+ ((base-string simple-base-string) 'base-char)))
+ (lvar-values (loop for lvar in lvars
+ collect (when (constant-lvar-p lvar)
+ (lvar-value lvar))))
+ (lengths
+ (loop for value in lvar-values
+ for var in vars
+ collect (if value
+ (length value)
+ `(sb!impl::string-dispatch ((simple-array * (*))
+ sequence)
+ ,var
+ (declare (muffle-conditions compiler-note))
+ (length ,var)))))
+ (non-constant-start
+ (loop for value in lvar-values
+ while (and (stringp value)
+ (< (length value) *concatenate-open-code-limit*))
+ sum (length value))))
+ `(apply
+ (lambda ,vars
+ (declare (ignorable ,@vars))
+ (declare (optimize (insert-array-bounds-checks 0)))
+ (let* ((.length. (+ ,@lengths))
+ (.pos. ,non-constant-start)
+ (.string. (make-string .length. :element-type ',element-type)))
+ (declare (type index .length. .pos.)
+ (muffle-conditions compiler-note))
+ ,@(loop with first-constants = t
+ for first = t then nil
+ for value in lvar-values
+ for var in vars
+ collect
+ (cond ((and (stringp value)
+ (< (length value) *concatenate-open-code-limit*))
+ ;; Fold the array reads for constant arguments
+ `(progn
+ ,@(loop for c across value
+ for i from 0
+ collect
+ ;; Without truly-the we get massive numbers
+ ;; of pointless error traps.
+ `(setf (aref .string.
+ (truly-the index ,(if first-constants
+ i
+ `(+ .pos. ,i))))
+ ,c))
+ ,(unless first-constants
+ `(incf (truly-the index .pos.) ,(length value)))))
+ (t
+ (prog1
+ `(sb!impl::string-dispatch
+ (#!+sb-unicode
+ (simple-array character (*))
+ (simple-array base-char (*))
+ t)
+ ,var
+ (replace .string. ,var
+ ,@(cond ((not first-constants)
+ '(:start1 .pos.))
+ ((plusp non-constant-start)
+ `(:start1 ,non-constant-start))))
+ (incf (truly-the index .pos.) (length ,var)))
+ (setf first-constants nil)))))
+ .string.))
+ lvars)))))
\f
;;;; CONS accessor DERIVE-TYPE optimizers
(defoptimizer (car derive-type) ((cons))
- (let ((type (lvar-type cons))
+ ;; This and CDR needs to use LVAR-CONSERVATIVE-TYPE because type inference
+ ;; gets confused by things like (SETF CAR).
+ (let ((type (lvar-conservative-type cons))
(null-type (specifier-type 'null)))
(cond ((eq type null-type)
null-type)
(cons-type-car-type type)))))
(defoptimizer (cdr derive-type) ((cons))
- (let ((type (lvar-type cons))
+ (let ((type (lvar-conservative-type cons))
(null-type (specifier-type 'null)))
(cond ((eq type null-type)
null-type)
*
:policy (> speed space))
"expand inline"
- `(let ((index 0)
- (find nil)
+ `(let ((find nil)
(position nil))
- (declare (type index index))
- (dolist (i sequence
- (if (and end (> end index))
- (sequence-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))))))
+ (flet ((bounds-error ()
+ (sequence-bounding-indices-bad-error sequence start end)))
+ (if (and end (> start end))
+ (bounds-error)
+ (do ((slow sequence (cdr slow))
+ (fast (cdr sequence) (cddr fast))
+ (index 0 (+ index 1)))
+ ((cond ((null slow)
+ (if (and end (> end index))
+ (bounds-error)
+ (return (values find position))))
+ ((and end (>= index end))
+ (return (values find position)))
+ ((eq slow fast)
+ (circular-list-error sequence)))
+ (bug "never"))
+ (declare (list slow fast))
+ (when (>= index start)
+ (let* ((element (car slow))
+ (key-i (funcall key element)))
+ (,',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 element
+ position index)
+ (return (values element index)))))))))))))
(def %find-position-if when)
(def %find-position-if-not unless))
'(%find-position-vector-macro item sequence
from-end start end key test))
+(deftransform %find-position ((item sequence from-end start end key test)
+ (t bit-vector t t t t t)
+ * :node node)
+ (when (and test (lvar-fun-is test '(eq eql equal)))
+ (setf test nil))
+ (when (and key (lvar-fun-is key '(identity)))
+ (setf key nil))
+ (when (or test key)
+ (delay-ir1-transform node :optimize)
+ (give-up-ir1-transform "non-trivial :KEY or :TEST"))
+ (catch 'not-a-bit
+ `(with-array-data ((bits sequence :offset-var offset)
+ (start start)
+ (end end)
+ :check-fill-pointer t)
+ (let ((p ,(if (constant-lvar-p item)
+ (case (lvar-value item)
+ (0 `(%bit-position/0 bits from-end start end))
+ (1 `(%bit-position/1 bits from-end start end))
+ (otherwise (throw 'not-a-bit `(values nil nil))))
+ `(%bit-position item bits from-end start end))))
+ (if p
+ (values item (the index (- (truly-the index p) offset)))
+ (values nil nil))))))
+
+(deftransform %find-position ((item sequence from-end start end key test)
+ (character string t t t function function)
+ *
+ :policy (> speed space))
+ (if (eq '* (upgraded-element-type-specifier sequence))
+ (let ((form
+ `(sb!impl::string-dispatch ((simple-array character (*))
+ (simple-array base-char (*))
+ (simple-array nil (*)))
+ sequence
+ (%find-position item sequence from-end start end key test))))
+ (if (csubtypep (lvar-type sequence) (specifier-type 'simple-string))
+ form
+ ;; Otherwise we'd get three instances of WITH-ARRAY-DATA from
+ ;; %FIND-POSITION.
+ `(with-array-data ((sequence sequence :offset-var offset)
+ (start start)
+ (end end)
+ :check-fill-pointer t)
+ (multiple-value-bind (elt index) ,form
+ (values elt (when (fixnump index) (- index offset)))))))
+ ;; The type is known exactly, other transforms will take care of it.
+ (give-up-ir1-transform)))
+
;;; logic to unravel :TEST, :TEST-NOT, and :KEY options in FIND,
;;; POSITION-IF, etc.
(define-source-transform effective-find-position-test (test test-not)
(define-trimmer-transform string-right-trim nil t)
(define-trimmer-transform string-trim t t))
+\f
+;;; (partially) constant-fold backq-* functions, or convert to their
+;;; plain CL equivalent (now that they're not needed for pprinting).
+
+;; Pop constant values from the end, list/list* them if any, and link
+;; the remainder with list* at runtime.
+(defun transform-backq-list-or-list* (function values)
+ (let ((gensyms (make-gensym-list (length values)))
+ (reverse (reverse values))
+ (constants '()))
+ (loop while (and reverse
+ (constant-lvar-p (car reverse)))
+ do (push (lvar-value (pop reverse))
+ constants))
+ (if (null constants)
+ `(lambda ,gensyms
+ (,function ,@gensyms))
+ (let ((tail (apply function constants)))
+ (if (null reverse)
+ `',tail
+ (let* ((nvariants (length reverse))
+ (variants (subseq gensyms 0 nvariants)))
+ `(lambda ,gensyms
+ (declare (ignore ,@(subseq gensyms nvariants)))
+ ,(if tail
+ `(list* ,@variants ',tail)
+ `(list ,@variants)))))))))
+
+(deftransform sb!impl::backq-list ((&rest elts))
+ (transform-backq-list-or-list* 'list elts))
+
+(deftransform sb!impl::backq-list* ((&rest elts))
+ (transform-backq-list-or-list* 'list* elts))
+
+;; Merge adjacent constant values
+(deftransform sb!impl::backq-append ((&rest elts))
+ (let ((gensyms (make-gensym-list (length elts)))
+ (acc nil)
+ (ignored '())
+ (arguments '()))
+ (flet ((convert-accumulator ()
+ (let ((constant (apply 'append (nreverse (shiftf acc nil)))))
+ (when constant
+ (push `',constant arguments)))))
+ (loop for gensym in gensyms
+ for (elt . next) on elts by #'cdr
+ do (cond ((constant-lvar-p elt)
+ (let ((elt (lvar-value elt)))
+ (when (and next (not (proper-list-p elt)))
+ (abort-ir1-transform
+ "Non-list or improper list spliced in ~
+ the middle of a backquoted list."))
+ (push gensym ignored)
+ (push elt acc)))
+ (t
+ (convert-accumulator)
+ (push gensym arguments)))
+ finally (convert-accumulator)))
+ (let ((arguments (nreverse arguments)))
+ `(lambda ,gensyms
+ (declare (ignore ,@ignored))
+ (append ,@arguments)))))
+
+;; Nothing special for nconc
+(define-source-transform sb!impl::backq-nconc (&rest elts)
+ `(nconc ,@elts))
+
+;; cons and vector are handled with regular constant folding...
+;; but we still want to convert backq-cons into cl:cons.
+(deftransform sb!impl::backq-cons ((x y))
+ `(cons x y))
projects / sbcl.git / blobdiff