X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fseqtran.lisp;h=55c4dba90e132d5b005eac3237d2397e0f40ea26;hb=c75cf4e142aaf9a72433ea6db778d8111a0b1c83;hp=62a3630989c5cd66d292fcb41018df5ec795425f;hpb=e6cf9d8e3e0d328e34c0edccd4f0ebc09e9b666f;p=sbcl.git diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp index 62a3630..55c4dba 100644 --- a/src/compiler/seqtran.lisp +++ b/src/compiler/seqtran.lisp @@ -27,31 +27,30 @@ (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)) @@ -292,55 +291,111 @@ (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"