X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fseqtran.lisp;h=40040ab2576fb9d897a0a3f31b471ee59ead02a5;hb=8e4ec430504f0f563280be26034af590dff50d34;hp=5181c060d74b1bdc8e081520924ea192ddeb6274;hpb=5bb3440a27492813feac0b9730283bb62d4690b8;p=sbcl.git diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp index 5181c06..40040ab 100644 --- a/src/compiler/seqtran.lisp +++ b/src/compiler/seqtran.lisp @@ -315,7 +315,7 @@ '(nth i s)) (deftransform %setelt ((s i v) ((simple-array * (*)) * *) *) - '(%aset s i v)) + '(setf (aref s i) v)) (deftransform %setelt ((s i v) (list * *) * :policy (< safety 3)) '(setf (car (nthcdr i s)) v)) @@ -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))))) @@ -1141,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) @@ -1158,10 +1167,10 @@ `(lambda (.dummy. ,@vars) (declare (ignore .dummy.)) ,(ecase type - ((string simple-string) - `(%concatenate-to-string ,@vars)) - ((base-string simple-base-string) - `(%concatenate-to-base-string ,@vars)))) + ((string simple-string) + `(%concatenate-to-string ,@vars)) + ((base-string simple-base-string) + `(%concatenate-to-base-string ,@vars)))) ;; Inline (let* ((element-type (ecase type ((string simple-string) 'character) @@ -1170,47 +1179,65 @@ collect (when (constant-lvar-p lvar) (lvar-value lvar)))) (lengths - (loop for value in lvar-values - for var in vars - collect (if value - (length value) - `(sb!impl::string-dispatch ((simple-array * (*)) - sequence) - ,var - (declare (muffle-conditions compiler-note)) - (length ,var)))))) + (loop for value in lvar-values + for var in vars + collect (if value + (length value) + `(sb!impl::string-dispatch ((simple-array * (*)) + sequence) + ,var + (declare (muffle-conditions compiler-note)) + (length ,var))))) + (non-constant-start + (loop for value in lvar-values + while (and (stringp value) + (< (length value) *concatenate-open-code-limit*)) + sum (length value)))) `(apply (lambda ,vars (declare (ignorable ,@vars)) (declare (optimize (insert-array-bounds-checks 0))) (let* ((.length. (+ ,@lengths)) - (.pos. 0) + (.pos. ,non-constant-start) (.string. (make-string .length. :element-type ',element-type))) (declare (type index .length. .pos.) (muffle-conditions compiler-note)) - ,@(loop for value in lvar-values + ,@(loop with first-constants = t + for first = t then nil + for value in lvar-values for var in vars - collect (if (and (stringp value) - (< (length value) *concatenate-open-code-limit*)) - ;; Fold the array reads for constant arguments - `(progn - ,@(loop for c across value - for i from 0 - collect - ;; Without truly-the we get massive numbers - ;; of pointless error traps. - `(setf (aref .string. - (truly-the index (+ .pos. ,i))) - ,c)) - (incf .pos. ,(length value))) - `(sb!impl::string-dispatch - (#!+sb-unicode - (simple-array character (*)) - (simple-array base-char (*)) - t) - ,var - (replace .string. ,var :start1 .pos.) - (incf .pos. (length ,var))))) + collect + (cond ((and (stringp value) + (< (length value) *concatenate-open-code-limit*)) + ;; Fold the array reads for constant arguments + `(progn + ,@(loop for c across value + for i from 0 + collect + ;; Without truly-the we get massive numbers + ;; of pointless error traps. + `(setf (aref .string. + (truly-the index ,(if first-constants + i + `(+ .pos. ,i)))) + ,c)) + ,(unless first-constants + `(incf (truly-the index .pos.) ,(length value))))) + (t + (prog1 + `(sb!impl::string-dispatch + (#!+sb-unicode + (simple-array character (*)) + (simple-array base-char (*)) + t) + ,var + (replace .string. ,var + ,@(cond ((not first-constants) + '(:start1 .pos.)) + ((plusp non-constant-start) + `(:start1 ,non-constant-start)))) + (incf (truly-the index .pos.) (length ,var))) + (setf first-constants nil))))) .string.)) lvars))))) @@ -1435,6 +1462,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)) @@ -1581,3 +1633,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))