X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fseqtran.lisp;h=8c493b121cda7ab07f524f541f6ddd04184b4c3d;hb=5dc28680e9cb2d598da02aed512aa49ea81fdade;hp=47fca9c630f8dae1be6384a0badf2f5900b1b6ec;hpb=a530bbe337109d898d5b4a001fc8f1afa3b5dc39;p=sbcl.git diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp index 47fca9c..8c493b1 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) @@ -605,3 +628,79 @@ (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))))