;;; 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)
(when (or test key)
(delay-ir1-transform node :optimize)
(give-up-ir1-transform "non-trivial :KEY or :TEST"))
- `(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
- (abort-ir1-transform)))
- `(%bit-position (the bit item) bits from-end start end))))
- (if p
- (values item (the index (- (truly-the index p) offset)))
- (values nil nil)))))
+ (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)
(define-trimmer-transform string-right-trim nil t)
(define-trimmer-transform string-trim t t))
+\f
+;;; (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))