(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)))
+ (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))))))))
+
+ `(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))
(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-lvar-p l)
- (give-up-ir1-transform))
-
- (let ((val (lvar-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 (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.")))
- `(,',eq-fun item list))))
- (def delete delq)
- (def assoc assq)
- (def member memq))
+(defun specialized-list-seek-function-name (function-name key-functions)
+ (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)))
+ (load-time-value (find-package "SB!KERNEL")))
+ (bug "Unknown list item seek transform: name=~S, key-functions=~S"
+ function-name key-functions)))
+
+(defun transform-list-item-seek (name list key test test-not node)
+ ;; 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
+ ;; ensure it is a function.
+ (multiple-value-bind (key key-form)
+ (if 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 '(%coerce-callable-to-fun key))))))
+ (let* ((funs (remove nil (list (and key 'key) (cond (test 'test)
+ (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)))
+ (t `(eql item ,target-expr)))))
+ (labels ((open-code (tail)
+ (when tail
+ `(if (let ((this ',(car tail)))
+ ,(ecase name
+ (assoc
+ `(and this (let ((target (car this)))
+ ,test-expr)))
+ (member
+ `(let ((target this))
+ ,test-expr))))
+ ',(ecase name
+ (assoc (car tail))
+ (member tail))
+ ,(open-code (cdr tail)))))
+ (ensure-fun (fun)
+ (if (eq 'key fun)
+ key-form
+ `(%coerce-callable-to-fun ,fun))))
+ (let* ((cp (constant-lvar-p list))
+ (c-list (when cp (lvar-value list))))
+ (cond ((and cp c-list (policy node (>= speed space)))
+ `(let ,(mapcar (lambda (fun) `(,fun ,(ensure-fun fun))) funs)
+ ,(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 funs)
+ item list ,@(mapcar #'ensure-fun funs)))))))))
+
+(deftransform member ((item list &key key test test-not) * * :node node)
+ (transform-list-item-seek 'member list key test test-not node))
+
+(deftransform assoc ((item list &key key test test-not) * * :node node)
+ (transform-list-item-seek 'assoc list key test test-not node))
+
+(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"
+ ;; 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.")))
+ `(delq item list))
(deftransform delete-if ((pred list) (t list))
"open code"
(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)))
-|#
-\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
(sb!impl::signal-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 'start 'result 0 'size element-type)
+ ,(maybe-expand-copy-loop-inline 'seq (if (constant-lvar-p start)
+ (lvar-value start)
+ 'start)
+ 'result 0 'size element-type)
result)))))
(deftransform copy-seq ((seq) ((or (simple-unboxed-array (*)) simple-vector)) *)
projects / sbcl.git / blobdiff