(defun mapfoo-transform (fn arglists accumulate take-car)
(collect ((do-clauses)
- (args-to-fn)
- (tests))
+ (args-to-fn)
+ (tests))
(let ((n-first (gensym)))
(dolist (a (if accumulate
- arglists
- `(,n-first ,@(rest arglists))))
- (let ((v (gensym)))
- (do-clauses `(,v ,a (cdr ,v)))
- (tests `(endp ,v))
- (args-to-fn (if take-car `(car ,v) v))))
+ arglists
+ `(,n-first ,@(rest arglists))))
+ (let ((v (gensym)))
+ (do-clauses `(,v ,a (cdr ,v)))
+ (tests `(endp ,v))
+ (args-to-fn (if take-car `(car ,v) v))))
(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 ((,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 ((,fn-sym ,fn)
- (,map-result (list nil)))
- (do-anonymous ((,temp ,map-result) . ,(do-clauses))
- (,endtest (truly-the list (cdr ,map-result)))
- (rplacd ,temp (setq ,temp (list ,call)))))))
- ((nil)
- `(let ((,fn-sym ,fn)
- (,n-first ,(first arglists)))
- (do-anonymous ,(do-clauses)
- (,endtest (truly-the list ,n-first))
- ,call))))))))
+ (call `(%funcall ,fn-sym . ,(args-to-fn)))
+ (endtest `(or ,@(tests))))
+
+ `(let ((,fn-sym (%coerce-callable-to-fun ,fn)))
+ ,(ecase accumulate
+ (:nconc
+ (let ((temp (gensym))
+ (map-result (gensym)))
+ `(let ((,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)))
+ (do-anonymous ((,temp ,map-result) . ,(do-clauses))
+ (,endtest (truly-the list (cdr ,map-result)))
+ (rplacd ,temp (setq ,temp (list ,call)))))))
+ ((nil)
+ `(let ((,n-first ,(first arglists)))
+ (do-anonymous ,(do-clauses)
+ (,endtest (truly-the list ,n-first))
+ ,call)))))))))
(define-source-transform mapc (function list &rest more-lists)
(mapfoo-transform function (cons list more-lists) nil t))
;;; TRULY-THE for the most specific type we can determine.
(deftransform map ((result-type-arg fun seq &rest seqs) * * :node node)
(let* ((seq-names (make-gensym-list (1+ (length seqs))))
- (bare `(%map result-type-arg fun ,@seq-names))
- (constant-result-type-arg-p (constant-continuation-p result-type-arg))
- ;; what we know about the type of the result. (Note that the
- ;; "result type" argument is not necessarily the type of the
- ;; result, since NIL means the result has NULL type.)
- (result-type (if (not constant-result-type-arg-p)
- 'consed-sequence
- (let ((result-type-arg-value
- (continuation-value result-type-arg)))
- (if (null result-type-arg-value)
- 'null
- result-type-arg-value)))))
+ (bare `(%map result-type-arg fun ,@seq-names))
+ (constant-result-type-arg-p (constant-lvar-p result-type-arg))
+ ;; what we know about the type of the result. (Note that the
+ ;; "result type" argument is not necessarily the type of the
+ ;; result, since NIL means the result has NULL type.)
+ (result-type (if (not constant-result-type-arg-p)
+ 'consed-sequence
+ (let ((result-type-arg-value
+ (lvar-value result-type-arg)))
+ (if (null result-type-arg-value)
+ 'null
+ result-type-arg-value)))))
`(lambda (result-type-arg fun ,@seq-names)
(truly-the ,result-type
- ,(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 (ir1-transform-specifier-type
- result-type)))
- (if (array-type-p result-ctype)
- (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))))))))
+ ,(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 (ir1-transform-specifier-type
+ result-type)))
+ (if (array-type-p result-ctype)
+ (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))))))))
;;; Return a DO loop, mapping a function FUN to elements of
-;;; sequences. SEQS is a list of continuations, SEQ-NAMES - list of
-;;; variables, bound to sequences, INTO - a variable, which is used in
+;;; sequences. SEQS is a list of lvars, SEQ-NAMES - list of variables,
+;;; bound to sequences, INTO - a variable, which is used in
;;; 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)
+ (declarations)
(vector-lengths)
(tests)
- (places))
+ (places)
+ (around))
(let ((found-vector-p nil))
(flet ((process-vector (length)
(unless found-vector-p
(bindings `(index 0 (1+ index)))
(declarations `(type index index)))
(vector-lengths length)))
- (loop for seq of-type continuation in seqs
+ (loop for seq of-type lvar in seqs
for seq-name in seq-names
- for type = (continuation-type seq)
+ for type = (lvar-type seq)
do (cond ((csubtypep type (specifier-type 'list))
- (with-unique-names (index)
+ (with-unique-names (index)
(bindings `(,index ,seq-name (cdr ,index)))
(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 `(aref ,seq-name index)))
+ (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"))))
(process-vector `(array-dimension ,into 0))))
(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)))))
+ (tests `(>= index length)))
+ (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-continuation-p result-type)
+ (unless (constant-lvar-p result-type)
(give-up-ir1-transform "RESULT-TYPE argument not constant"))
(labels ( ;; 1-valued SUBTYPEP, fails unless second value of SUBTYPEP is true
- (fn-1subtypep (fn x y)
- (multiple-value-bind (subtype-p valid-p) (funcall fn x y)
- (if valid-p
- subtype-p
- (give-up-ir1-transform
- "can't analyze sequence type relationship"))))
- (1subtypep (x y) (fn-1subtypep #'sb!xc:subtypep x y)))
- (let* ((result-type-value (continuation-value result-type))
- (result-supertype (cond ((null result-type-value) 'null)
- ((1subtypep result-type-value 'vector)
- 'vector)
- ((1subtypep result-type-value 'list)
- 'list)
- (t
- (give-up-ir1-transform
- "can't determine result type")))))
+ (fn-1subtypep (fn x y)
+ (multiple-value-bind (subtype-p valid-p) (funcall fn x y)
+ (if valid-p
+ subtype-p
+ (give-up-ir1-transform
+ "can't analyze sequence type relationship"))))
+ (1subtypep (x y) (fn-1subtypep #'sb!xc:subtypep x y)))
+ (let* ((result-type-value (lvar-value result-type))
+ (result-supertype (cond ((null result-type-value) 'null)
+ ((1subtypep result-type-value 'vector)
+ 'vector)
+ ((1subtypep result-type-value 'list)
+ 'list)
+ (t
+ (give-up-ir1-transform
+ "result type unsuitable")))))
(cond ((and result-type-value (null seqs))
- ;; The consing arity-1 cases can be implemented
- ;; reasonably efficiently as function calls, and the cost
- ;; of consing should be significantly larger than
- ;; function call overhead, so we always compile these
- ;; cases as full calls regardless of speed-versus-space
- ;; optimization policy.
- (cond ((subtypep result-type-value 'list)
- '(%map-to-list-arity-1 fun seq))
- ( ;; (This one can be inefficient due to COERCE, but
- ;; the current open-coded implementation has the
- ;; same problem.)
- (subtypep result-type-value 'vector)
- `(coerce (%map-to-simple-vector-arity-1 fun seq)
- ',result-type-value))
- (t (bug "impossible (?) sequence type"))))
- (t
- (let* ((seqs (cons seq seqs))
- (seq-args (make-gensym-list (length seqs))))
- (multiple-value-bind (push-dacc result)
- (ecase result-supertype
- (null (values nil nil))
- (list (values `(push funcall-result acc)
+ ;; The consing arity-1 cases can be implemented
+ ;; reasonably efficiently as function calls, and the cost
+ ;; of consing should be significantly larger than
+ ;; function call overhead, so we always compile these
+ ;; cases as full calls regardless of speed-versus-space
+ ;; optimization policy.
+ (cond ((subtypep result-type-value 'list)
+ '(%map-to-list-arity-1 fun seq))
+ ( ;; (This one can be inefficient due to COERCE, but
+ ;; the current open-coded implementation has the
+ ;; same problem.)
+ (subtypep result-type-value 'vector)
+ `(coerce (%map-to-simple-vector-arity-1 fun seq)
+ ',result-type-value))
+ (t (bug "impossible (?) sequence type"))))
+ (t
+ (let* ((seqs (cons seq seqs))
+ (seq-args (make-gensym-list (length seqs))))
+ (multiple-value-bind (push-dacc result)
+ (ecase result-supertype
+ (null (values nil nil))
+ (list (values `(push funcall-result acc)
`(nreverse acc)))
- (vector (values `(push funcall-result acc)
- `(coerce (nreverse acc)
- ',result-type-value))))
- ;; (We use the same idiom, of returning a LAMBDA from
- ;; DEFTRANSFORM, as is used in the DEFTRANSFORMs for
- ;; FUNCALL and ALIEN-FUNCALL, and for the same
- ;; reason: we need to get the runtime values of each
- ;; of the &REST vars.)
- `(lambda (result-type fun ,@seq-args)
- (declare (ignore result-type))
+ (vector (values `(push funcall-result acc)
+ `(coerce (nreverse acc)
+ ',result-type-value))))
+ ;; (We use the same idiom, of returning a LAMBDA from
+ ;; DEFTRANSFORM, as is used in the DEFTRANSFORMs for
+ ;; FUNCALL and ALIEN-FUNCALL, and for the same
+ ;; reason: we need to get the runtime values of each
+ ;; of the &REST vars.)
+ `(lambda (result-type fun ,@seq-args)
+ (declare (ignore result-type))
(let ((fun (%coerce-callable-to-fun fun))
(acc nil))
(declare (type list acc))
,(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 '(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))
(deftransform %check-vector-sequence-bounds ((vector start end)
- (vector * *) *
- :node node)
- (if (policy node (< safety speed))
+ (vector * *) *
+ :node node)
+ (if (policy node (= 0 insert-array-bounds-checks))
'(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))
-
- (let ((val (continuation-value l)))
- (unless (policy node
- (or (= speed 3)
- (and (>= speed space)
- (<= (length val) 5))))
- (give-up-ir1-transform))
-
- (labels ((frob (els)
- (if els
- `(if (funcall test e ',(car els))
- ',els
- ,(frob (cdr els)))
- nil)))
- (frob val))))))
- (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 (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
- ;; 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 (continuation-fun-is test '(eq))
- (give-up-ir1-transform)))
- ((types-equal-or-intersect (continuation-type item)
- (specifier-type 'number))
- (give-up-ir1-transform "Item might be a number.")))
- `(,',eq-fun item list))))
- (def delete delq)
- (def assoc assq)
- (def member memq))
+ (if (<= 0 start (or end length) length)
+ (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
+ ;; this ever so slightly faster then FORMAT, this
+ ;; way we are also proof against *PRINT-CASE*
+ ;; frobbing and such.
+ (write-char #\% s)
+ (write-string (symbol-name function-name) s)
+ (dolist (f key-functions)
+ (write-char #\- s)
+ (write-string (symbol-name f) s))
+ (when variant
+ (write-char #\- s)
+ (write-string (symbol-name variant) s)))
+ (load-time-value (find-package "SB!KERNEL")))
+ (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))
+ ;; Ditto for KEY IDENTITY.
+ (when (and key (lvar-fun-is key '(identity)))
+ (setf key nil))
+ ;; Key can legally be NIL, but if it's NIL for sure we pretend it's
+ ;; not there at all. If it might be NIL, make up a form to that
+ ;; ensures it is a function.
+ (multiple-value-bind (key key-form)
+ (when key
+ (let ((key-type (lvar-type key))
+ (null-type (specifier-type 'null)))
+ (cond ((csubtypep key-type null-type)
+ (values nil nil))
+ ((csubtypep null-type key-type)
+ (values key '(if key
+ (%coerce-callable-to-fun key)
+ #'identity)))
+ (t
+ (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 (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)))
+ (c-test `(,c-test item ,target-expr))
+ (t `(eql item ,target-expr)))))
+ (labels ((open-code (tail)
+ (when tail
+ `(if (let ((this ',(car tail)))
+ ,(ecase name
+ ((assoc rassoc)
+ (let ((cxx (if (eq name 'assoc) 'car 'cdr)))
+ `(and this (let ((target (,cxx this)))
+ ,test-expr))))
+ (member
+ `(let ((target this))
+ ,test-expr))))
+ ',(ecase name
+ ((assoc rassoc) (car tail))
+ (member tail))
+ ,(open-code (cdr tail)))))
+ (ensure-fun (args)
+ (if (eq 'key (second args))
+ key-form
+ (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))
+ (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
+ (if (eq name 'adjoin)
+ '(list item)
+ nil))
+ (t
+ ;; specialized out-of-line version
+ `(,(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)
+ ;; If KEY is IDENTITY, drop it.
+ (when (and key (lvar-fun-is key '(identity)))
+ (setf key nil))
+ ;; Key can legally be NIL, but if it's NIL for sure we pretend it's
+ ;; not there at all. If it might be NIL, make up a form to that
+ ;; ensures it is a function.
+ (multiple-value-bind (key key-form)
+ (when key
+ (let ((key-type (lvar-type key))
+ (null-type (specifier-type 'null)))
+ (cond ((csubtypep key-type null-type)
+ (values nil nil))
+ ((csubtypep null-type key-type)
+ (values key '(if key
+ (%coerce-callable-to-fun key)
+ #'identity)))
+ (t
+ (values key (ensure-lvar-fun-form key 'key))))))
+ (let ((test-expr `(%funcall pred ,(if key '(%funcall key target) 'target)))
+ (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)
+ (when tail
+ `(if (let ((this ',(car tail)))
+ ,(ecase name
+ ((assoc-if assoc-if-not rassoc-if rassoc-if-not)
+ (let ((cxx (if (member name '(assoc-if assoc-if-not)) 'car 'cdr)))
+ `(and this (let ((target (,cxx this)))
+ ,test-expr))))
+ ((member-if member-if-not)
+ `(let ((target this))
+ ,test-expr))))
+ ',(ecase name
+ ((assoc-if assoc-if-not rassoc-if rassoc-if-not)
+ (car tail))
+ ((member-if member-if-not)
+ 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))
+ (not (nthcdr *list-open-code-limit* c-list)))
+ `(let ((pred ,pred-expr)
+ ,@(when key `((key ,key-form))))
+ ,(open-code c-list)))
+ ((and cp (not c-list))
+ ;; constant nil list -- nothing to find!
+ nil)
+ (t
+ ;; specialized out-of-line version
+ `(,(specialized-list-seek-function-name name (when key '(key)))
+ ,pred-expr list ,@(when key (list key-form))))))))))
+
+(macrolet ((def (name &optional if/if-not)
+ (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)
+ (def rassoc t))
+
+(deftransform memq ((item list) (t (constant-arg list)))
+ (labels ((rec (tail)
+ (if tail
+ `(if (eq item ',(car tail))
+ ',tail
+ ,(rec (cdr tail)))
+ nil)))
+ (rec (lvar-value list))))
+
+;;; A similar transform used to apply to MEMBER and ASSOC, but since
+;;; TRANSFORM-LIST-ITEM-SEEK now takes care of them those transform
+;;; would never fire, and (%MEMBER-TEST ITEM LIST #'EQ) should be
+;;; almost as fast as MEMQ.
+(deftransform delete ((item list &key test) (t list &rest t) *)
+ "convert to EQ test"
+ (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))
"open code"
'(do ((x list (cdr x))
- (splice '()))
+ (splice '()))
((endp x) list)
(cond ((funcall pred (car x))
- (if (null splice)
- (setq list (cdr x))
- (rplacd splice (cdr x))))
- (T (setq splice x)))))
-
-(deftransform fill ((seq item &key (start 0) (end (length seq)))
- (vector t &key (:start t) (:end index))
- *
- :policy (> speed space))
- "open code"
- (let ((element-type (upgraded-element-type-specifier-or-give-up seq)))
- (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...
- (declare (optimize (safety 0)))
- (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
-
-;;; Return true if CONT's only use is a non-NOTINLINE reference to a
-;;; global function with one of the specified NAMES.
-(defun continuation-fun-is (cont names)
- (declare (type continuation cont) (list names))
- (let ((use (continuation-use cont)))
- (and (ref-p use)
- (let ((leaf (ref-leaf use)))
- (and (global-var-p leaf)
- (eq (global-var-kind leaf) :global-function)
- (not (null (member (leaf-source-name leaf) names
- :test #'equal))))))))
-
-;;; If CONT is a constant continuation, 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 (cont &optional default)
- (declare (type (or continuation null) cont))
- (cond ((not cont) default)
- ((constant-continuation-p cont)
- (continuation-value cont))
- (t
- (give-up-ir1-transform))))
-
-;;; FIXME: Why is this code commented out? (Why *was* it commented
-;;; out? We inherited this situation from cmucl-2.4.8, with no
-;;; explanation.) Should we just delete this code?
-#|
-;;; This is a frob whose job it is to make it easier to pass around
-;;; the arguments to IR1 transforms. It bundles together the name of
-;;; the argument (which should be referenced in any expansion), and
-;;; the continuation for that argument (or NIL if unsupplied.)
-(defstruct (arg (:constructor %make-arg (name cont))
- (:copier nil))
- (name nil :type symbol)
- (cont nil :type (or continuation null)))
-(defmacro make-arg (name)
- `(%make-arg ',name ,name))
-
-;;; If Arg is null or its CONT is null, then return Default, otherwise
-;;; return Arg's NAME.
-(defun default-arg (arg default)
- (declare (type (or arg null) arg))
- (if (and arg (arg-cont arg))
- (arg-name arg)
- default))
-
-;;; If Arg is null or has no CONT, return the default. Otherwise, Arg's
-;;; CONT must be a constant continuation whose value we return. If not, we
-;;; give up.
-(defun arg-constant-value (arg default)
- (declare (type (or arg null) arg))
- (if (and arg (arg-cont arg))
- (let ((cont (arg-cont arg)))
- (unless (constant-continuation-p cont)
- (give-up-ir1-transform "Argument is not constant: ~S."
- (arg-name arg)))
- (continuation-value from-end))
- default))
-
-;;; If Arg is a constant and is EQL to X, then return T, otherwise NIL. If
-;;; Arg is NIL or its CONT is NIL, then compare to the default.
-(defun arg-eql (arg default x)
- (declare (type (or arg null) x))
- (if (and arg (arg-cont arg))
- (let ((cont (arg-cont arg)))
- (and (constant-continuation-p cont)
- (eql (continuation-value cont) x)))
- (eql default x)))
-
-(defstruct (iterator (:copier nil))
- ;; The kind of iterator.
- (kind nil (member :normal :result))
- ;; A list of LET* bindings to create the initial state.
- (binds nil :type list)
- ;; A list of declarations for Binds.
- (decls nil :type list)
- ;; 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.
- (done nil)
- ;; 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
- ;; undefined after NEXT has been evaluated.
- (length (error "Must specify LENGTH."))
- ;; A form that advances the state to the next value. It is an error to call
- ;; this when the iterator is Done.
- (next (error "Must specify NEXT.")))
-
-;;; Type of an index var that can go negative (in the from-end case.)
-(deftype neg-index ()
- `(integer -1 ,most-positive-fixnum))
-
-;;; Return an ITERATOR structure describing how to iterate over an arbitrary
-;;; sequence. Sequence is a variable bound to the sequence, and Type is the
-;;; type of the sequence. If true, INDEX is a variable that should be bound to
-;;; the index of the current element in the sequence.
-;;;
-;;; If we can't tell whether the sequence is a list or a vector, or whether
-;;; the iteration is forward or backward, then GIVE-UP.
-(defun make-sequence-iterator (sequence type &key start end from-end index)
- (declare (symbol sequence) (type ctype type)
- (type (or arg null) start end from-end)
- (type (or symbol null) index))
- (let ((from-end (arg-constant-value from-end nil)))
- (cond ((csubtypep type (specifier-type 'vector))
- (let* ((n-stop (gensym))
- (n-idx (or index (gensym)))
- (start (default-arg 0 start))
- (end (default-arg `(length ,sequence) end)))
- (make-iterator
- :kind :normal
- :binds `((,n-idx ,(if from-end `(1- ,end) ,start))
- (,n-stop ,(if from-end `(1- ,start) ,end)))
- :decls `((type neg-index ,n-idx ,n-stop))
- :current `(aref ,sequence ,n-idx)
- :done `(,(if from-end '<= '>=) ,n-idx ,n-stop)
- :next `(setq ,n-idx
- ,(if from-end `(1- ,n-idx) `(1+ ,n-idx)))
- :length (if from-end
- `(- ,n-idx ,n-stop)
- `(- ,n-stop ,n-idx)))))
- ((csubtypep type (specifier-type 'list))
- (let* ((n-stop (if (and end (not from-end)) (gensym) nil))
- (n-current (gensym))
- (start-p (not (arg-eql start 0 0)))
- (end-p (not (arg-eql end nil nil)))
- (start (default-arg start 0))
- (end (default-arg end nil)))
- (make-iterator
- :binds `((,n-current
- ,(if from-end
- (if (or start-p end-p)
- `(nreverse (subseq ,sequence ,start
- ,@(when end `(,end))))
- `(reverse ,sequence))
- (if start-p
- `(nthcdr ,start ,sequence)
- sequence)))
- ,@(when n-stop
- `((,n-stop (nthcdr (the index
- (- ,end ,start))
- ,n-current))))
- ,@(when index
- `((,index ,(if from-end `(1- ,end) start)))))
- :kind :normal
- :decls `((list ,n-current ,n-end)
- ,@(when index `((type neg-index ,index))))
- :current `(car ,n-current)
- :done `(eq ,n-current ,n-stop)
- :length `(- ,(or end `(length ,sequence)) ,start)
- :next `(progn
- (setq ,n-current (cdr ,n-current))
- ,@(when index
- `((setq ,n-idx
- ,(if from-end
- `(1- ,index)
- `(1+ ,index)))))))))
- (t
- (give-up-ir1-transform
- "can't tell whether sequence is a list or a vector")))))
-
-;;; Make an iterator used for constructing result sequences. Name is a
-;;; variable to be bound to the result sequence. Type is the type of result
-;;; sequence to make. Length is an expression to be evaluated to get the
-;;; maximum length of the result (not evaluated in list case.)
-(defun make-result-sequence-iterator (name type length)
- (declare (symbol name) (type ctype type))
-
-;;; Define each NAME as a local macro that will call the value of the
-;;; function arg with the given arguments. If the argument isn't known to be a
-;;; function, give them an efficiency note and reference a coerced version.
-(defmacro coerce-funs (specs &body body)
- #!+sb-doc
- "COERCE-FUNCTIONS ({(Name Fun-Arg Default)}*) Form*"
- (collect ((binds)
- (defs))
- (dolist (spec specs)
- `(let ((body (progn ,@body))
- (n-fun (arg-name ,(second spec)))
- (fun-cont (arg-cont ,(second spec))))
- (cond ((not fun-cont)
- `(macrolet ((,',(first spec) (&rest args)
- `(,',',(third spec) ,@args)))
- ,body))
- ((not (csubtypep (continuation-type fun-cont)
- (specifier-type 'function)))
- (when (policy *compiler-error-context*
- (> speed inhibit-warnings))
- (compiler-notify
- "~S may not be a function, so must coerce at run-time."
- n-fun))
- (once-only ((n-fun `(if (functionp ,n-fun)
- ,n-fun
- (symbol-function ,n-fun))))
- `(macrolet ((,',(first spec) (&rest args)
- `(funcall ,',n-fun ,@args)))
- ,body)))
- (t
- `(macrolet ((,',(first spec) (&rest args)
- `(funcall ,',n-fun ,@args)))
- ,body)))))))
-
-;;; Wrap code around the result of the body to define Name as a local macro
-;;; that returns true when its arguments satisfy the test according to the Args
-;;; Test and Test-Not. If both Test and Test-Not are supplied, abort the
-;;; transform.
-(defmacro with-sequence-test ((name test test-not) &body body)
- `(let ((not-p (arg-cont ,test-not)))
- (when (and (arg-cont ,test) not-p)
- (abort-ir1-transform "Both ~S and ~S were supplied."
- (arg-name ,test)
- (arg-name ,test-not)))
- (coerce-funs ((,name (if not-p ,test-not ,test) eql))
- ,@body)))
-|#
+ (if (null splice)
+ (setq list (cdr x))
+ (rplacd splice (cdr x))))
+ (t (setq splice x)))))
+
+(deftransform fill ((seq item &key (start 0) (end nil))
+ (list t &key (:start t) (:end t)))
+ '(list-fill* seq item start end))
+
+(deftransform fill ((seq item &key (start 0) (end nil))
+ (vector t &key (:start t) (:end t))
+ *
+ :node node)
+ (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)
+ (end end)
+ :check-fill-pointer t)
+ (declare (type (simple-array ,element-type 1) data))
+ (declare (type index start end))
+ ;; WITH-ARRAY-DATA did our range checks once and for all, so
+ ;; it'd be wasteful to check again on every AREF...
+ (declare (optimize (safety 0) (speed 3)))
+ (do ((i start (1+ i)))
+ ((= i end) seq)
+ (declare (type index i))
+ (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)))))
+ ((csubtypep type (specifier-type 'string))
+ '(string-fill* seq item start end))
+ (t
+ '(vector-fill* seq item start end)))))
+
+(deftransform fill ((seq item &key (start 0) (end nil))
+ ((and sequence (not vector) (not list)) t &key (:start t) (:end t)))
+ `(sb!sequence:fill seq item
+ :start start
+ :end (%check-generic-sequence-bounds seq start end)))
\f
;;;; hairy sequence transforms
;;; FIXME: no hairy sequence transforms in SBCL?
+;;;
+;;; There used to be a bunch of commented out code about here,
+;;; containing the (apparent) beginning of hairy sequence transform
+;;; infrastructure. People interested in implementing better sequence
+;;; transforms might want to look at it for inspiration, even though
+;;; the actual code is ancient CMUCL -- and hence bitrotted. The code
+;;; was deleted in 1.0.7.23.
\f
;;;; string operations
;;; must be SIMPLE-BASE-STRINGs.
(macrolet ((def (name lessp equalp)
`(deftransform ,name ((string1 string2 start1 end1 start2 end2)
- (simple-base-string simple-base-string t t t t) *)
+ (simple-base-string simple-base-string t t t t) *)
`(let* ((end1 (if (not end1) (length string1) end1))
(end2 (if (not end2) (length string2) end2))
(index (sb!impl::%sp-string-compare
string1 start1 end1 string2 start2 end2)))
(if index
- (cond ((= index ,(if ',lessp 'end1 'end2)) index)
- ((= index ,(if ',lessp 'end2 'end1)) nil)
+ (cond ((= index end1)
+ ,(if ',lessp 'index nil))
+ ((= (+ index (- start2 start1)) end2)
+ ,(if ',lessp nil 'index))
((,(if ',lessp 'char< 'char>)
(schar string1 index)
(schar string2
(+ index
(truly-the fixnum
(- start2
- start1))))))
+ start1))))))
index)
(t nil))
,(if ',equalp 'end1 nil))))))
(def string/=* identity))
\f
-;;;; string-only transforms for sequence functions
-;;;;
-;;;; Note: CMU CL had more of these, including transforms for
-;;;; functions which cons. In SBCL, we've gotten rid of most of the
-;;;; transforms for functions which cons, since our GC overhead is
-;;;; sufficiently large that it doesn't seem worth it to try to
-;;;; economize on function call overhead or on the overhead of runtime
-;;;; type dispatch in AREF. The exception is CONCATENATE, since
-;;;; a full call to CONCATENATE would have to look up the sequence
-;;;; type, which can be really slow.
-;;;;
-;;;; FIXME: It would be nicer for these transforms to work for any
-;;;; calls when all arguments are vectors with the same element type,
-;;;; rather than restricting them to STRINGs only.
+;;;; transforms for sequence functions
-;;; Moved here from generic/vm-tran.lisp to satisfy clisp
-;;;
-;;; FIXME: Add a comment telling whether this holds for all vectors
-;;; or only for vectors based on simple arrays (non-adjustable, etc.).
+;;; Moved here from generic/vm-tran.lisp to satisfy clisp. Only applies
+;;; to vectors based on simple arrays.
(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-base-string simple-base-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
- (the index
- (+ (the index (* start2 sb!vm:n-byte-bits))
- ,vector-data-bit-offset))
- string1
- (the index
- (+ (the index (* start1 sb!vm:n-byte-bits))
- ,vector-data-bit-offset))
- (the index
- (* (min (the index (- (or end1 (length string1))
- start1))
- (the index (- (or end2 (length string2))
- start2)))
- sb!vm:n-byte-bits)))
- string1))
-
-;;; FIXME: It seems as though it should be possible to make a DEFUN
-;;; %CONCATENATE (with a DEFTRANSFORM to translate constant RTYPE to
-;;; CTYPE before calling %CONCATENATE) which is comparably efficient,
-;;; at least once DYNAMIC-EXTENT works.
+;;; FIXME: In the copy loops below, we code the loops in a strange
+;;; fashion:
+;;;
+;;; (do ((i (+ src-offset length) (1- i)))
+;;; ((<= i 0) ...)
+;;; (... (aref foo (1- i)) ...))
+;;;
+;;; rather than the more natural (and seemingly more efficient):
+;;;
+;;; (do ((i (1- (+ src-offset length)) (1- i)))
+;;; ((< i 0) ...)
+;;; (... (aref foo i) ...))
+;;;
+;;; (more efficient because we don't have to do the index adjusting on
+;;; every iteration of the loop)
+;;;
+;;; We do this to avoid a suboptimality in SBCL's backend. In the
+;;; latter case, the backend thinks I is a FIXNUM (which it is), but
+;;; when used as an array index, the backend thinks I is a
+;;; POSITIVE-FIXNUM (which it is). However, since the backend thinks of
+;;; these as distinct storage classes, it cannot coerce a move from a
+;;; FIXNUM TN to a POSITIVE-FIXNUM TN. The practical effect of this
+;;; deficiency is that we have two extra moves and increased register
+;;; pressure, which can lead to some spectacularly bad register
+;;; allocation. (sub-FIXME: the register allocation even with the
+;;; strangely written loops is not always excellent, either...). Doing
+;;; it the first way, above, means that I is always thought of as a
+;;; POSITIVE-FIXNUM and there are no issues.
+;;;
+;;; Besides, the *-WITH-OFFSET machinery will fold those index
+;;; adjustments in the first version into the array addressing at no
+;;; performance penalty!
+
+;;; This transform is critical to the performance of string streams. If
+;;; 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 (#-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)
+ `(let* ((len1 (length seq1))
+ (len2 (length seq2))
+ (end1 (or end1 len1))
+ (end2 (or end2 len2))
+ (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))))
+ ,',(cond
+ ((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
+ ((define-replace-transforms ()
+ (loop for saetp across sb!vm:*specialized-array-element-type-properties*
+ for sequence-type = `(simple-array ,(sb!vm:saetp-specifier saetp) (*))
+ unless (= (sb!vm:saetp-typecode saetp) sb!vm::simple-array-nil-widetag)
+ collect (make-replace-transform saetp sequence-type sequence-type)
+ into forms
+ finally (return `(progn ,@forms))))
+ (define-one-transform (sequence-type1 sequence-type2)
+ (make-replace-transform nil sequence-type1 sequence-type2)))
+ (define-replace-transforms)
+ #!+sb-unicode
+ (progn
+ (define-one-transform (simple-array base-char (*)) (simple-array character (*)))
+ (define-one-transform (simple-array character (*)) (simple-array base-char (*)))))
+
+;;; Expand simple cases of UB<SIZE>-BASH-COPY inline. "simple" is
+;;; defined as those cases where we are doing word-aligned copies from
+;;; both the source and the destination and we are copying from the same
+;;; offset from both the source and the destination. (The last
+;;; condition is there so we can determine the direction to copy at
+;;; compile time rather than runtime. Remember that UB<SIZE>-BASH-COPY
+;;; acts like memmove, not memcpy.) These conditions may seem rather
+;;; restrictive, but they do catch common cases, like allocating a (* 2
+;;; N)-size buffer and blitting in the old N-size buffer in.
+
+(defun frob-bash-transform (src src-offset
+ dst dst-offset
+ length n-elems-per-word)
+ (declare (ignore src dst length))
+ (let ((n-bits-per-elem (truncate sb!vm:n-word-bits n-elems-per-word)))
+ (multiple-value-bind (src-word src-elt)
+ (truncate (lvar-value src-offset) n-elems-per-word)
+ (multiple-value-bind (dst-word dst-elt)
+ (truncate (lvar-value dst-offset) n-elems-per-word)
+ ;; Avoid non-word aligned copies.
+ (unless (and (zerop src-elt) (zerop dst-elt))
+ (give-up-ir1-transform))
+ ;; Avoid copies where we would have to insert code for
+ ;; determining the direction of copying.
+ (unless (= src-word dst-word)
+ (give-up-ir1-transform))
+ ;; FIXME: The cross-compiler doesn't optimize TRUNCATE properly,
+ ;; so we have to do its work here.
+ `(let ((end (+ ,src-word ,(if (= n-elems-per-word 1)
+ 'length
+ `(truncate (the index length) ,n-elems-per-word)))))
+ (declare (type index end))
+ ;; Handle any bits at the end.
+ (when (logtest length (1- ,n-elems-per-word))
+ (let* ((extra (mod length ,n-elems-per-word))
+ ;; FIXME: The shift amount on this ASH is
+ ;; *always* negative, but the backend doesn't
+ ;; have a NEGATIVE-FIXNUM primitive type, so we
+ ;; wind up with a pile of code that tests the
+ ;; sign of the shift count prior to shifting when
+ ;; all we need is a simple negate and shift
+ ;; right. Yuck.
+ (mask (ash #.(1- (ash 1 sb!vm:n-word-bits))
+ (* (- extra ,n-elems-per-word)
+ ,n-bits-per-elem))))
+ (setf (sb!kernel:%vector-raw-bits dst end)
+ (logior
+ (logandc2 (sb!kernel:%vector-raw-bits dst end)
+ (ash mask
+ ,(ecase sb!c:*backend-byte-order*
+ (:little-endian 0)
+ (:big-endian `(* (- ,n-elems-per-word extra)
+ ,n-bits-per-elem)))))
+ (logand (sb!kernel:%vector-raw-bits src end)
+ (ash mask
+ ,(ecase sb!c:*backend-byte-order*
+ (:little-endian 0)
+ (:big-endian `(* (- ,n-elems-per-word extra)
+ ,n-bits-per-elem)))))))))
+ ;; Copy from the end to save a register.
+ (do ((i end (1- i)))
+ ((<= i ,src-word))
+ (setf (sb!kernel:%vector-raw-bits dst (1- i))
+ (sb!kernel:%vector-raw-bits src (1- i))))
+ (values))))))
+
+#.(loop for i = 1 then (* i 2)
+ collect `(deftransform ,(intern (format nil "UB~D-BASH-COPY" i)
+ "SB!KERNEL")
+ ((src src-offset
+ dst dst-offset
+ length)
+ ((simple-unboxed-array (*))
+ (constant-arg index)
+ (simple-unboxed-array (*))
+ (constant-arg index)
+ index)
+ *)
+ (frob-bash-transform src src-offset
+ dst dst-offset length
+ ,(truncate sb!vm:n-word-bits i))) into forms
+ until (= i sb!vm:n-word-bits)
+ finally (return `(progn ,@forms)))
+
+;;; We expand copy loops inline in SUBSEQ and COPY-SEQ if we're copying
+;;; arrays with elements of size >= the word size. We do this because
+;;; we know the arrays cannot alias (one was just consed), therefore we
+;;; can determine at compile time the direction to copy, and for
+;;; word-sized elements, UB<WORD-SIZE>-BASH-COPY will do a bit of
+;;; needless checking to figure out what's going on. The same
+;;; considerations apply if we are copying elements larger than the word
+;;; size, with the additional twist that doing it inline is likely to
+;;; cons far less than calling REPLACE and letting generic code do the
+;;; work.
+;;;
+;;; However, we do not do this for elements whose size is < than the
+;;; word size because we don't want to deal with any alignment issues
+;;; inline. The UB*-BASH-COPY transforms might fix things up later
+;;; anyway.
+
+(defun maybe-expand-copy-loop-inline (src src-offset dst dst-offset length
+ element-type)
+ (let ((saetp (find-saetp element-type)))
+ (aver saetp)
+ (if (>= (sb!vm:saetp-n-bits saetp) sb!vm:n-word-bits)
+ (expand-aref-copy-loop src src-offset dst dst-offset length)
+ `(locally (declare (optimize (safety 0)))
+ (replace ,dst ,src :start1 ,dst-offset :start2 ,src-offset :end1 ,length)))))
+
+(defun expand-aref-copy-loop (src src-offset dst dst-offset length)
+ (if (eql src-offset dst-offset)
+ `(do ((i (+ ,src-offset ,length) (1- i)))
+ ((<= i ,src-offset))
+ (declare (optimize (insert-array-bounds-checks 0)))
+ (setf (aref ,dst (1- i)) (aref ,src (1- i))))
+ ;; KLUDGE: The compiler is not able to derive that (+ offset
+ ;; length) must be a fixnum, but arrives at (unsigned-byte 29).
+ ;; We, however, know it must be so, as by this point the bounds
+ ;; have already been checked.
+ `(do ((i (truly-the fixnum (+ ,src-offset ,length)) (1- i))
+ (j (+ ,dst-offset ,length) (1- j)))
+ ((<= i ,src-offset))
+ (declare (optimize (insert-array-bounds-checks 0))
+ (type (integer 0 #.sb!xc:array-dimension-limit) j i))
+ (setf (aref ,dst (1- j)) (aref ,src (1- i))))))
+
+;;; SUBSEQ, COPY-SEQ
+
+(deftransform subseq ((seq start &optional end)
+ (vector t &optional t)
+ *
+ :node node)
+ (let ((type (lvar-type seq)))
+ (cond
+ ((and (array-type-p type)
+ (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)))
+ ,(unless (policy node (zerop insert-array-bounds-checks))
+ '(progn
+ (unless (<= 0 start end length)
+ (sequence-bounding-indices-bad-error seq start end))))
+ (let* ((size (- end start))
+ (result (make-array size :element-type ',element-type)))
+ ,(maybe-expand-copy-loop-inline 'seq (if (constant-lvar-p start)
+ (lvar-value start)
+ 'start)
+ 'result 0 'size element-type)
+ result))))
+ (t
+ '(vector-subseq* seq start end)))))
+
+(deftransform subseq ((seq start &optional end)
+ (list t &optional t))
+ `(list-subseq* seq start end))
+
+(deftransform subseq ((seq start &optional end)
+ ((and sequence (not vector) (not list)) t &optional t))
+ '(sb!sequence:subseq seq start end))
+
+(deftransform copy-seq ((seq) (vector))
+ (let ((type (lvar-type seq)))
+ (cond ((and (array-type-p type)
+ (csubtypep type (specifier-type '(or (simple-unboxed-array (*)) simple-vector))))
+ (let ((element-type (type-specifier (array-type-specialized-element-type type))))
+ `(let* ((length (length seq))
+ (result (make-array length :element-type ',element-type)))
+ ,(maybe-expand-copy-loop-inline 'seq 0 'result 0 'length element-type)
+ result)))
+ (t
+ '(vector-subseq* seq 0 nil)))))
+
+(deftransform copy-seq ((seq) (list))
+ '(list-copy-seq* seq))
+
+(deftransform copy-seq ((seq) ((and sequence (not vector) (not list))))
+ '(sb!sequence:copy-seq seq))
+
+;;; FIXME: it really should be possible to take advantage of the
+;;; macros used in code/seq.lisp here to avoid duplication of code,
+;;; and enable even funkier transformations.
+(deftransform search ((pattern text &key (start1 0) (start2 0) end1 end2
+ (test #'eql)
+ (key #'identity)
+ from-end)
+ (vector vector &rest t)
+ *
+ :node node
+ :policy (> speed (max space safety)))
+ "open code"
+ (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
;;;
-;;; FIXME: currently KLUDGEed because of bug 188
-(deftransform concatenate ((rtype &rest sequences)
- (t &rest (or simple-base-string
- (simple-array nil (*))))
- simple-base-string
- :policy (< safety 3))
- (loop for rest-seqs on sequences
- for n-seq = (gensym "N-SEQ")
- for n-length = (gensym "N-LENGTH")
- for start = vector-data-bit-offset then next-start
- for next-start = (gensym "NEXT-START")
- collect n-seq into args
- collect `(,n-length (* (length ,n-seq) sb!vm:n-byte-bits)) into lets
- collect n-length into all-lengths
- collect next-start into starts
- collect `(if (and (typep ,n-seq '(simple-array nil (*)))
- (> ,n-length 0))
- (error 'nil-array-accessed-error)
- (bit-bash-copy ,n-seq ,vector-data-bit-offset
- res ,start ,n-length))
- into forms
- collect `(setq ,next-start (+ ,start ,n-length)) into forms
- finally
- (return
- `(lambda (rtype ,@args)
- (declare (ignore rtype))
- (let* (,@lets
- (res (make-string (truncate (the index (+ ,@all-lengths))
- sb!vm:n-byte-bits))))
- (declare (type index ,@all-lengths))
- (let (,@(mapcar (lambda (name) `(,name 0)) starts))
- (declare (type index ,@starts))
- ,@forms)
- res)))))
+;;; 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)
+ ((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 (continuation-type cons))
- (null-type (specifier-type 'null)))
+ ;; 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-p type)
- (cons-type-car-type type)))))
+ null-type)
+ ((cons-type-p type)
+ (cons-type-car-type type)))))
(defoptimizer (cdr derive-type) ((cons))
- (let ((type (continuation-type cons))
- (null-type (specifier-type 'null)))
+ (let ((type (lvar-conservative-type cons))
+ (null-type (specifier-type 'null)))
(cond ((eq type null-type)
- null-type)
- ((cons-type-p type)
- (cons-type-cdr-type type)))))
+ null-type)
+ ((cons-type-p type)
+ (cons-type-cdr-type type)))))
\f
;;;; FIND, POSITION, and their -IF and -IF-NOT variants
;;; %FIND-POSITION-IF only when %FIND-POSITION-IF has an inline
;;; expansion, so we factor out the condition into this function.
(defun check-inlineability-of-find-position-if (sequence from-end)
- (let ((ctype (continuation-type sequence)))
+ (let ((ctype (lvar-type sequence)))
(cond ((csubtypep ctype (specifier-type 'vector))
- ;; It's not worth trying to inline vector code unless we
- ;; know a fair amount about it at compile time.
- (upgraded-element-type-specifier-or-give-up sequence)
- (unless (constant-continuation-p from-end)
- (give-up-ir1-transform
- "FROM-END argument value not known at compile time")))
- ((csubtypep ctype (specifier-type 'list))
- ;; Inlining on lists is generally worthwhile.
- )
- (t
- (give-up-ir1-transform
- "sequence type not known at compile time")))))
+ ;; It's not worth trying to inline vector code unless we
+ ;; know a fair amount about it at compile time.
+ (upgraded-element-type-specifier-or-give-up sequence)
+ (unless (constant-lvar-p from-end)
+ (give-up-ir1-transform
+ "FROM-END argument value not known at compile time")))
+ ((csubtypep ctype (specifier-type 'list))
+ ;; Inlining on lists is generally worthwhile.
+ )
+ (t
+ (give-up-ir1-transform
+ "sequence type not known at compile time")))))
;;; %FIND-POSITION-IF and %FIND-POSITION-IF-NOT for LIST data
(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))))))
+ `(deftransform ,name ((predicate sequence from-end start end key)
+ (function list t t t function)
+ *
+ :policy (> speed space))
+ "expand inline"
+ `(let ((find nil)
+ (position nil))
+ (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 for LIST data can be expanded into %FIND-POSITION-IF
;;; without loss of efficiency. (I.e., the optimizer should be able
;;; to straighten everything out.)
(deftransform %find-position ((item sequence from-end start end key test)
- (t list t t t t t)
- *
- :policy (> speed space)
- :important t)
+ (t list t t t t t)
+ *
+ :policy (> speed space))
"expand inline"
'(%find-position-if (let ((test-fun (%coerce-callable-to-fun test)))
- ;; 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
- from-end
- start
- end
- (%coerce-callable-to-fun key)))
+ ;; 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
+ from-end
+ start
+ end
+ (%coerce-callable-to-fun key)))
;;; The inline expansions for the VECTOR case are saved as macros so
;;; that we can share them between the DEFTRANSFORMs and the default
;;; cases in the DEFUNs. (This isn't needed for the LIST case, because
;;; the DEFTRANSFORMs for LIST are less choosy about when to expand.)
(defun %find-position-or-find-position-if-vector-expansion (sequence-arg
- from-end
- start
- end-arg
- element
- done-p-expr)
- (with-unique-names (offset block index n-sequence sequence n-end end)
- `(let ((,n-sequence ,sequence-arg)
- (,n-end ,end-arg))
+ from-end
+ start
+ end-arg
+ element
+ done-p-expr)
+ (with-unique-names (offset block index n-sequence sequence end)
+ `(let* ((,n-sequence ,sequence-arg))
(with-array-data ((,sequence ,n-sequence :offset-var ,offset)
- (,start ,start)
- (,end (%check-vector-sequence-bounds
- ,n-sequence ,start ,n-end)))
+ (,start ,start)
+ (,end ,end-arg)
+ :check-fill-pointer t)
(block ,block
- (macrolet ((maybe-return ()
- '(let ((,element (aref ,sequence ,index)))
- (when ,done-p-expr
- (return-from ,block
- (values ,element
- (- ,index ,offset)))))))
- (if ,from-end
- (loop for ,index
- ;; (If we aren't fastidious about declaring that
- ;; INDEX might be -1, then (FIND 1 #() :FROM-END T)
- ;; can send us off into never-never land, since
- ;; INDEX is initialized to -1.)
- of-type index-or-minus-1
- from (1- ,end) downto ,start do
- (maybe-return))
- (loop for ,index of-type index from ,start below ,end do
- (maybe-return))))
- (values nil nil))))))
+ (macrolet ((maybe-return ()
+ ;; WITH-ARRAY-DATA has already performed bounds
+ ;; checking, so we can safely elide the checks
+ ;; in the inner loop.
+ '(let ((,element (locally (declare (optimize (insert-array-bounds-checks 0)))
+ (aref ,sequence ,index))))
+ (when ,done-p-expr
+ (return-from ,block
+ (values ,element
+ (- ,index ,offset)))))))
+ (if ,from-end
+ (loop for ,index
+ ;; (If we aren't fastidious about declaring that
+ ;; INDEX might be -1, then (FIND 1 #() :FROM-END T)
+ ;; can send us off into never-never land, since
+ ;; INDEX is initialized to -1.)
+ of-type index-or-minus-1
+ from (1- ,end) downto ,start do
+ (maybe-return))
+ (loop for ,index of-type index from ,start below ,end do
+ (maybe-return))))
+ (values nil nil))))))
(def!macro %find-position-vector-macro (item sequence
- from-end start end key test)
+ from-end start end key test)
(with-unique-names (element)
(%find-position-or-find-position-if-vector-expansion
sequence
`(funcall ,test ,item (funcall ,key ,element)))))
(def!macro %find-position-if-vector-macro (predicate sequence
- from-end start end key)
+ from-end start end key)
(with-unique-names (element)
(%find-position-or-find-position-if-vector-expansion
sequence
`(funcall ,predicate (funcall ,key ,element)))))
(def!macro %find-position-if-not-vector-macro (predicate sequence
- from-end start end key)
+ from-end start end key)
(with-unique-names (element)
(%find-position-or-find-position-if-vector-expansion
sequence
;;; %FIND-POSITION, %FIND-POSITION-IF and %FIND-POSITION-IF-NOT for
;;; VECTOR data
(deftransform %find-position-if ((predicate sequence from-end start end key)
- (function vector t t t function)
- *
- :policy (> speed space)
- :important t)
+ (function vector t t t function)
+ *
+ :policy (> speed space))
"expand inline"
(check-inlineability-of-find-position-if sequence from-end)
'(%find-position-if-vector-macro predicate sequence
- from-end start end key))
+ from-end start end key))
(deftransform %find-position-if-not ((predicate sequence from-end start end key)
- (function vector t t t function)
- *
- :policy (> speed space)
- :important t)
+ (function vector t t t function)
+ *
+ :policy (> speed space))
"expand inline"
(check-inlineability-of-find-position-if sequence from-end)
'(%find-position-if-not-vector-macro predicate sequence
from-end start end key))
(deftransform %find-position ((item sequence from-end start end key test)
- (t vector t t t function function)
- *
- :policy (> speed space)
- :important t)
+ (t vector t t t function function)
+ *
+ :policy (> speed space))
"expand inline"
(check-inlineability-of-find-position-if sequence from-end)
'(%find-position-vector-macro item sequence
- from-end start end key test))
+ 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)
(once-only ((test test)
- (test-not test-not))
+ (test-not test-not))
`(cond
((and ,test ,test-not)
(error "can't specify both :TEST and :TEST-NOT"))
(define-source-transform effective-find-position-key (key)
(once-only ((key key))
`(if ,key
- (%coerce-callable-to-fun ,key)
- #'identity)))
+ (%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))))))
+ `(deftransform ,fun-name ((item sequence &key
+ from-end (start 0) end
+ key test test-not)
+ (t (or list vector) &rest t))
+ '(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))))))
+ `(deftransform ,fun-name ((predicate sequence &key
+ from-end (start 0)
+ end key)
+ (t (or list vector) &rest t))
+ '(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))
;;; 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.
+;;; FIXME: Maybe remove uses of these deprecated functions 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))))))
+ `(deftransform ,fun-name ((predicate sequence &key
+ from-end (start 0)
+ end key)
+ (t (or list vector) &rest t))
+ '(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))
+
+(macrolet ((define-trimmer-transform (fun-name leftp rightp)
+ `(deftransform ,fun-name ((char-bag string)
+ (t simple-string))
+ (let ((find-expr
+ (if (constant-lvar-p char-bag)
+ ;; If the bag is constant, use MEMBER
+ ;; instead of FIND, since we have a
+ ;; deftransform for MEMBER that can
+ ;; open-code all of the comparisons when
+ ;; the list is constant. -- JES, 2007-12-10
+ `(not (member (schar string index)
+ ',(coerce (lvar-value char-bag) 'list)
+ :test #'char=))
+ '(not (find (schar string index) char-bag :test #'char=)))))
+ `(flet ((char-not-in-bag (index)
+ ,find-expr))
+ (let* ((end (length string))
+ (left-end (if ,',leftp
+ (do ((index 0 (1+ index)))
+ ((or (= index (the fixnum end))
+ (char-not-in-bag index))
+ index)
+ (declare (fixnum index)))
+ 0))
+ (right-end (if ,',rightp
+ (do ((index (1- end) (1- index)))
+ ((or (< index left-end)
+ (char-not-in-bag index))
+ (1+ index))
+ (declare (fixnum index)))
+ end)))
+ (if (and (eql left-end 0)
+ (eql right-end (length string)))
+ string
+ (subseq string left-end right-end))))))))
+ (define-trimmer-transform string-left-trim t nil)
+ (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