X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fseqtran.lisp;h=55c4dba90e132d5b005eac3237d2397e0f40ea26;hb=961c7076f5fba67ddba0e12dd131104834348b1a;hp=2699964568f975ba43d318d8111878074fa44fdc;hpb=1a60ff79067ec697c476185e0c79565dacf8c8c0;p=sbcl.git diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp index 2699964..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" @@ -403,205 +458,17 @@ (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))) -|# - + ;;;; 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. ;;;; string operations @@ -916,7 +783,10 @@ (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)) *)