X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fseqtran.lisp;h=40040ab2576fb9d897a0a3f31b471ee59ead02a5;hb=8e4ec430504f0f563280be26034af590dff50d34;hp=0b52e48c455bd6ef9fae87518990b7aba16f9063;hpb=87c62dadeba82095c672161e30a3611016d270fb;p=sbcl.git diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp index 0b52e48..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)) @@ -1150,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) @@ -1167,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) @@ -1179,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))))) @@ -1615,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))