X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fseqtran.lisp;h=9e4d3b441e54e3d576b5aa4e59fe150886414892;hb=2b69e4fdba7249fb494635bf78bb3595e34c1eb7;hp=f87bd7800b733d07641917ccd214908865687b4e;hpb=2c9e9cdf20257c422cd43bd30b89990499bca475;p=sbcl.git diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp index f87bd78..9e4d3b4 100644 --- a/src/compiler/seqtran.lisp +++ b/src/compiler/seqtran.lisp @@ -643,16 +643,28 @@ (logior res (ash bits (truly-the (integer 0 ,(- sb!vm:n-word-bits n-bits)) i)))))))) res))))) (values - `(with-array-data ((data seq) - (start start) - (end end) - :check-fill-pointer t) - (declare (type (simple-array ,element-type 1) data)) - (declare (type index start end)) - (declare (optimize (safety 0) (speed 3)) - (muffle-conditions compiler-note)) - (,basher ,bash-value data start (- end start)) - seq) + ;; KLUDGE: WITH-ARRAY data in its full glory is going to mess up + ;; dynamic-extent for MAKE-ARRAY :INITIAL-ELEMENT initialization. + (if (csubtypep (lvar-type seq) (specifier-type '(simple-array * (*)))) + `(let* ((len (length seq)) + (end (or end len)) + (bound (1+ end))) + ;; Minor abuse %CHECK-BOUND for bounds checking. + ;; (- END START) may still end up negative, but + ;; the basher handle that. + (,basher ,bash-value seq + (%check-bound seq bound start) + (- (if end (%check-bound seq bound end) len) + start))) + `(with-array-data ((data seq) + (start start) + (end end) + :check-fill-pointer t) + (declare (type (simple-array ,element-type 1) data)) + (declare (type index start end)) + (declare (optimize (safety 0) (speed 3))) + (,basher ,bash-value data start (- end start)) + seq)) `((declare (type ,element-type item)))))) ((policy node (> speed space)) (values @@ -995,7 +1007,8 @@ (let ((type (lvar-type seq))) (cond ((and (array-type-p type) - (csubtypep type (specifier-type '(or (simple-unboxed-array (*)) simple-vector)))) + (csubtypep type (specifier-type '(or (simple-unboxed-array (*)) simple-vector))) + (policy node (> speed space))) (let ((element-type (type-specifier (array-type-specialized-element-type type)))) `(let* ((length (length seq)) (end (or end length))) @@ -1010,8 +1023,6 @@ 'start) 'result 0 'size element-type) result)))) - ((csubtypep type (specifier-type 'string)) - '(string-subseq* seq start end)) (t '(vector-subseq* seq start end))))) @@ -1032,8 +1043,6 @@ (result (make-array length :element-type ',element-type))) ,(maybe-expand-copy-loop-inline 'seq 0 'result 0 'length element-type) result))) - ((csubtypep type (specifier-type 'string)) - '(string-subseq* seq 0 nil)) (t '(vector-subseq* seq 0 nil))))) @@ -1088,7 +1097,9 @@ (unless (<= start2 end2 len2) (oops pattern start2 end2)))) (when (= end1 start1) - (return-from search start2)) + (return-from search (if from-end + end2 + start2))) (do (,(if from-end '(index2 (- end2 (- end1 start1)) (1- index2)) '(index2 start2 (1+ index2)))) @@ -1139,7 +1150,7 @@ ;;; practice. ;;; ;;; Limit full open coding based on length of constant sequences. Default -;;; value is chosen so that other parts of to compiler (constraint propagation +;;; value is chosen so that other parts of the compiler (constraint propagation ;;; mainly) won't go nonlinear too badly. It's not an exact number -- but ;;; in the right ballpark. (defvar *concatenate-open-code-limit* 129) @@ -1433,6 +1444,31 @@ from-end start end key test)) (deftransform %find-position ((item sequence from-end start end key test) + (t bit-vector t t t t t) + * :node node) + (when (and test (lvar-fun-is test '(eq eql equal))) + (setf test nil)) + (when (and key (lvar-fun-is key '(identity))) + (setf key nil)) + (when (or test key) + (delay-ir1-transform node :optimize) + (give-up-ir1-transform "non-trivial :KEY or :TEST")) + (catch 'not-a-bit + `(with-array-data ((bits sequence :offset-var offset) + (start start) + (end end) + :check-fill-pointer t) + (let ((p ,(if (constant-lvar-p item) + (case (lvar-value item) + (0 `(%bit-position/0 bits from-end start end)) + (1 `(%bit-position/1 bits from-end start end)) + (otherwise (throw 'not-a-bit `(values nil nil)))) + `(%bit-position item bits from-end start end)))) + (if p + (values item (the index (- (truly-the index p) offset))) + (values nil nil)))))) + +(deftransform %find-position ((item sequence from-end start end key test) (character string t t t function function) * :policy (> speed space)) @@ -1579,3 +1615,74 @@ (define-trimmer-transform string-right-trim nil t) (define-trimmer-transform string-trim t t)) + +;;; (partially) constant-fold backq-* functions, or convert to their +;;; plain CL equivalent (now that they're not needed for pprinting). + +;; Pop constant values from the end, list/list* them if any, and link +;; the remainder with list* at runtime. +(defun transform-backq-list-or-list* (function values) + (let ((gensyms (make-gensym-list (length values))) + (reverse (reverse values)) + (constants '())) + (loop while (and reverse + (constant-lvar-p (car reverse))) + do (push (lvar-value (pop reverse)) + constants)) + (if (null constants) + `(lambda ,gensyms + (,function ,@gensyms)) + (let ((tail (apply function constants))) + (if (null reverse) + `',tail + (let* ((nvariants (length reverse)) + (variants (subseq gensyms 0 nvariants))) + `(lambda ,gensyms + (declare (ignore ,@(subseq gensyms nvariants))) + ,(if tail + `(list* ,@variants ',tail) + `(list ,@variants))))))))) + +(deftransform sb!impl::backq-list ((&rest elts)) + (transform-backq-list-or-list* 'list elts)) + +(deftransform sb!impl::backq-list* ((&rest elts)) + (transform-backq-list-or-list* 'list* elts)) + +;; Merge adjacent constant values +(deftransform sb!impl::backq-append ((&rest elts)) + (let ((gensyms (make-gensym-list (length elts))) + (acc nil) + (ignored '()) + (arguments '())) + (flet ((convert-accumulator () + (let ((constant (apply 'append (nreverse (shiftf acc nil))))) + (when constant + (push `',constant arguments))))) + (loop for gensym in gensyms + for (elt . next) on elts by #'cdr + do (cond ((constant-lvar-p elt) + (let ((elt (lvar-value elt))) + (when (and next (not (proper-list-p elt))) + (abort-ir1-transform + "Non-list or improper list spliced in ~ + the middle of a backquoted list.")) + (push gensym ignored) + (push elt acc))) + (t + (convert-accumulator) + (push gensym arguments))) + finally (convert-accumulator))) + (let ((arguments (nreverse arguments))) + `(lambda ,gensyms + (declare (ignore ,@ignored)) + (append ,@arguments))))) + +;; Nothing special for nconc +(define-source-transform sb!impl::backq-nconc (&rest elts) + `(nconc ,@elts)) + +;; cons and vector are handled with regular constant folding... +;; but we still want to convert backq-cons into cl:cons. +(deftransform sb!impl::backq-cons ((x y)) + `(cons x y))