'(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))
(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)))
- (,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
;;; 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)
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))
(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))
projects / sbcl.git / blobdiff