X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fseqtran.lisp;h=d72020dda6854390153c4cc98ddf0e6f1a723fb3;hb=dfa55a883f94470267b626dae77ce7e7dfac3df6;hp=83c5e4ee47a2652ecdbdda662f3bfdcdb2c88006;hpb=cea4896b2482b7b2b429c1631d774b4cfbc0efba;p=sbcl.git diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp index 83c5e4e..d72020d 100644 --- a/src/compiler/seqtran.lisp +++ b/src/compiler/seqtran.lisp @@ -249,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 @@ -279,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)))) @@ -322,13 +322,13 @@ ;;; names of predicates that compute the same value as CHAR= when ;;; applied to characters -(defconstant char=-functions '(eql equal char=)) +(defparameter *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)) + (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)))) @@ -336,7 +336,7 @@ (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)) + (continuation-function-is test *char=-functions*)) (give-up-ir1-transform)) `(and (typep item 'character) (,(if (constant-value-or-lose from-end) @@ -355,8 +355,8 @@ ;;;; 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))) @@ -366,8 +366,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)) @@ -378,11 +380,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) @@ -419,7 +422,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. @@ -539,7 +542,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)) @@ -616,7 +620,7 @@ (- start2 start1)))))) index) (t nil)) - ,(if equalp 'end1 'nil)))))) + ,(if equalp 'end1 nil)))))) (dolist (stuff '((string=* not) (string/=* identity))) @@ -628,3 +632,97 @@ (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)))))