X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fseqtran.lisp;h=d218ceb2204cd87673328d9d060ea4d57012c9d8;hb=872175cd9cb5b4966a36d4bd92421cc407a0355b;hp=47fca9c630f8dae1be6384a0badf2f5900b1b6ec;hpb=a530bbe337109d898d5b4a001fc8f1afa3b5dc39;p=sbcl.git diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp index 47fca9c..d218ceb 100644 --- a/src/compiler/seqtran.lisp +++ b/src/compiler/seqtran.lisp @@ -10,9 +10,6 @@ ;;;; files for more information. (in-package "SB!C") - -(file-comment - "$Header$") ;;;; mapping onto lists: the MAPFOO functions @@ -71,7 +68,42 @@ ;;;; mapping onto sequences: the MAP function -;;; Try to compile MAP efficiently when we can determine sequence +;;; MAP is %MAP plus a check to make sure that any length specified in +;;; the result type matches the actual result. We also wrap it in a +;;; TRULY-THE for the most specific type we can determine. +(deftransform map ((result-type-arg fun &rest seqs) * * :node node) + (let* ((seq-names (make-gensym-list (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))))) + `(lambda (result-type-arg fun ,@seq-names) + (truly-the ,result-type + ,(cond ((policy node (> speed safety)) + bare) + ((not constant-result-type-arg-p) + `(sequence-of-checked-length-given-type ,bare + result-type-arg)) + (t + (let ((result-ctype (specifier-type result-type))) + (if (array-type-p result-ctype) + (let* ((dims (array-type-dimensions result-ctype)) + (dim (first dims))) + (if (eq dim '*) + bare + `(vector-of-checked-length-given-length ,bare + ,dim))) + bare)))))))) + +;;; Try to compile %MAP efficiently when we can determine sequence ;;; argument types at compile time. ;;; ;;; Note: This transform was written to allow open coding of @@ -83,11 +115,7 @@ ;;; handle that case more efficiently, but it's left as an exercise to ;;; the reader, because the code is complicated enough already and I ;;; don't happen to need that functionality right now. -- WHN 20000410 -;;; -;;; FIXME: Now that we have this transform, we should be able -;;; to get rid of the macros MAP-TO-LIST, MAP-TO-SIMPLE, -;;; and MAP-FOR-EFFECT. -(deftransform map ((result-type fun &rest seqs) * *) +(deftransform %map ((result-type fun &rest seqs) * * :policy (>= speed space)) "open code" (unless seqs (abort-ir1-transform "no sequence args")) (unless (constant-continuation-p result-type) @@ -136,10 +164,7 @@ (t (give-up-ir1-transform "internal error: unexpected sequence type")))) (t - (let* ((seq-args (mapcar (lambda (seq) - (declare (ignore seq)) - (gensym "SEQ")) - seqs)) + (let* ((seq-args (make-gensym-list (length seqs))) (index-bindingoids (mapcar (lambda (seq-arg seq-supertype) (let ((i (gensym "I"))) @@ -178,9 +203,7 @@ ;; of the &REST vars.) `(lambda (result-type fun ,@seq-args) (declare (ignore result-type)) - (do ((really-fun (if (functionp fun) - fun - (%coerce-name-to-function fun))) + (do ((really-fun (%coerce-callable-to-function fun)) ,@index-bindingoids (acc nil)) ((or ,@tests) @@ -226,7 +249,7 @@ `(if (funcall test e ',(car els)) ',els ,(frob (cdr els))) - 'nil))) + nil))) (frob val))))) ;;; FIXME: Rewrite this so that these definitions of DELETE, ASSOC, and MEMBER @@ -256,8 +279,8 @@ (cond (test (unless (continuation-function-is test '(eq)) (give-up-ir1-transform))) - ((types-intersect (continuation-type item) - (specifier-type 'number)) + ((types-equal-or-intersect (continuation-type item) + (specifier-type 'number)) (give-up-ir1-transform "Item might be a number."))) `(,eq-fun item list)))) @@ -273,67 +296,27 @@ (T (setq splice x))))) (deftransform fill ((seq item &key (start 0) (end (length seq))) - (simple-array t &key (:start t) (:end index))) - "open code" - '(do ((i start (1+ i))) - ((= i end) seq) - (declare (type index i)) - (setf (aref seq i) item))) - -(deftransform position ((item list &key (test #'eql)) (t list)) + (vector t &key (:start t) (:end index)) + * + :policy (> speed space)) "open code" - '(do ((i 0 (1+ i)) - (l list (cdr l))) - ((endp l) nil) - (declare (type index i)) - (when (funcall test item (car l)) (return i)))) - -(deftransform position ((item vec &key (test #'eql) (start 0) - (end (length vec))) - (t simple-array &key (:start t) (:end index))) - "open code" - '(do ((i start (1+ i))) - ((= i end) nil) - (declare (type index i)) - (when (funcall test item (aref vec i)) (return i)))) - -;;; names of predicates that compute the same value as CHAR= when -;;; applied to characters -(defconstant char=-functions '(eql equal char=)) - -(deftransform search ((string1 string2 &key (start1 0) end1 (start2 0) end2 - test) - (simple-string simple-string &rest t)) - (unless (or (not test) - (continuation-function-is test char=-functions)) - (give-up-ir1-transform)) - '(sb!impl::%sp-string-search string1 start1 (or end1 (length string1)) - string2 start2 (or end2 (length string2)))) - -(deftransform position ((item sequence &key from-end test (start 0) end) - (t simple-string &rest t)) - (unless (or (not test) - (continuation-function-is test char=-functions)) - (give-up-ir1-transform)) - `(and (typep item 'character) - (,(if (constant-value-or-lose from-end) - 'sb!impl::%sp-reverse-find-character - 'sb!impl::%sp-find-character) - sequence start (or end (length sequence)) - item))) - -(deftransform find ((item sequence &key from-end (test #'eql) (start 0) end) - (t simple-string &rest t)) - `(if (position item sequence - ,@(when from-end `(:from-end from-end)) - :test test :start start :end end) - item - nil)) + (let ((element-type (upgraded-element-type-specifier-or-give-up seq))) + `(with-array-data ((data seq) + (start start) + (end end)) + (declare (type (simple-array ,element-type 1) data)) + (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))))) ;;;; utilities -;;; Return true if Cont's only use is a non-notinline reference to a global -;;; function with one of the specified Names. +;;; Return true if CONT's only use is a non-notinline reference to a +;;; global function with one of the specified NAMES. (defun continuation-function-is (cont names) (declare (type continuation cont) (list names)) (let ((use (continuation-use cont))) @@ -343,8 +326,10 @@ (eq (global-var-kind leaf) :global-function) (not (null (member (leaf-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. +;;; 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)) @@ -355,11 +340,12 @@ (give-up-ir1-transform)))) #| -;;; 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))) +;;; 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) @@ -396,7 +382,7 @@ (eql (continuation-value cont) x))) (eql default x))) -(defstruct iterator +(defstruct (iterator (:copier nil)) ;; The kind of iterator. (kind nil (member :normal :result)) ;; A list of LET* bindings to create the initial state. @@ -516,7 +502,8 @@ ,body)) ((not (csubtypep (continuation-type fun-cont) (specifier-type 'function))) - (when (policy *compiler-error-context* (> speed brevity)) + (when (policy *compiler-error-context* + (> speed inhibit-warnings)) (compiler-note "~S may not be a function, so must coerce at run-time." n-fun)) @@ -593,7 +580,7 @@ (- start2 start1)))))) index) (t nil)) - ,(if equalp 'end1 'nil)))))) + ,(if equalp 'end1 nil)))))) (dolist (stuff '((string=* not) (string/=* identity))) @@ -605,3 +592,253 @@ (sb!impl::%sp-string-compare string1 start1 (or end1 (length string1)) string2 start2 (or end2 (length string2))))))) + +;;;; 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. + +;;; FIXME: Shouldn't we be testing for legality of +;;; * START1, START2, END1, and END2 indices? +;;; * size of copied string relative to destination string? +;;; (Either there should be tests conditional on SAFETY>=SPEED, or +;;; the transform should be conditional on SPEED>SAFETY.) +;;; +;;; FIXME: Also, the transform should probably be dependent on +;;; SPEED>SPACE. +(deftransform replace ((string1 string2 &key (start1 0) (start2 0) + end1 end2) + (simple-string simple-string &rest t)) + `(locally + (declare (optimize (safety 0))) + (bit-bash-copy string2 + (the index + (+ (the index (* start2 sb!vm:byte-bits)) + ,vector-data-bit-offset)) + string1 + (the index + (+ (the index (* start1 sb!vm: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: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. +(deftransform concatenate ((rtype &rest sequences) + (t &rest simple-string) + simple-string) + (collect ((lets) + (forms) + (all-lengths) + (args)) + (dolist (seq sequences) + (declare (ignore seq)) + (let ((n-seq (gensym)) + (n-length (gensym))) + (args n-seq) + (lets `(,n-length (the index (* (length ,n-seq) sb!vm:byte-bits)))) + (all-lengths n-length) + (forms `(bit-bash-copy ,n-seq ,vector-data-bit-offset + res start + ,n-length)) + (forms `(setq start (+ start ,n-length))))) + `(lambda (rtype ,@(args)) + (declare (ignore rtype)) + (let* (,@(lets) + (res (make-string (truncate (the index (+ ,@(all-lengths))) + sb!vm:byte-bits))) + (start ,vector-data-bit-offset)) + (declare (type index start ,@(all-lengths))) + ,@(forms) + res)))) + +;;;; CONS accessor DERIVE-TYPE optimizers + +(defoptimizer (car derive-type) ((cons)) + (let ((type (continuation-type cons)) + (null-type (specifier-type 'null))) + (cond ((eq type null-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))) + (cond ((eq type null-type) + null-type) + ((cons-type-p type) + (cons-type-cdr-type type))))) + +;;;; FIND, POSITION, and their -IF and -IF-NOT variants + +;;; We want to make sure that %FIND-POSITION is inline-expanded into +;;; %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))) + (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"))))) + +;;; %FIND-POSITION-IF for LIST data +(deftransform %find-position-if ((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 (values find position)) + (let ((key-i (funcall key i))) + (when (and end (>= index end)) + (return (values find position))) + (when (>= index start) + (when (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)))) + +;;; %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) + "expand inline" + '(%find-position-if (let ((test-fun (%coerce-callable-to-function test))) + (lambda (i) + (funcall test-fun i item))) + sequence + from-end + start + end + (%coerce-callable-to-function 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) + (let ((offset (gensym "OFFSET")) + (block (gensym "BLOCK")) + (index (gensym "INDEX")) + (n-sequence (gensym "N-SEQUENCE-")) + (sequence (gensym "SEQUENCE")) + (n-end (gensym "N-END-")) + (end (gensym "END-"))) + `(let ((,n-sequence ,sequence-arg) + (,n-end ,end-arg)) + (with-array-data ((,sequence ,n-sequence :offset-var ,offset) + (,start ,start) + (,end (or ,n-end (length ,n-sequence)))) + (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)))))) + +(def!macro %find-position-vector-macro (item sequence + from-end start end key test) + (let ((element (gensym "ELEMENT"))) + (%find-position-or-find-position-if-vector-expansion + sequence + from-end + start + end + element + `(funcall ,test ,item (funcall ,key ,element))))) + +(def!macro %find-position-if-vector-macro (predicate sequence + from-end start end key) + (let ((element (gensym "ELEMENT"))) + (%find-position-or-find-position-if-vector-expansion + sequence + from-end + start + end + element + `(funcall ,predicate (funcall ,key ,element))))) + +;;; %FIND-POSITION and %FIND-POSITION-IF 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) + "expand inline" + (check-inlineability-of-find-position-if sequence from-end) + '(%find-position-if-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) + "expand inline" + (check-inlineability-of-find-position-if sequence from-end) + '(%find-position-vector-macro item sequence + from-end start end key test))