- (if (null splice)
- (setq list (cdr x))
- (rplacd splice (cdr x))))
- (T (setq splice x)))))
-
-(deftransform fill ((seq item &key (start 0) (end (length seq)))
- (vector t &key (:start t) (:end index))
- *
- :policy (> speed space))
- "open code"
- (let ((element-type (upgraded-element-type-specifier-or-give-up seq)))
- `(with-array-data ((data seq)
- (start start)
- (end end))
- (declare (type (simple-array ,element-type 1) data))
- (do ((i start (1+ i)))
- ((= i end) seq)
- (declare (type index i))
- ;; WITH-ARRAY-DATA did our range checks once and for all, so
- ;; it'd be wasteful to check again on every AREF.
- (declare (optimize (safety 0)))
- (setf (aref data i) item)))))
-\f
-;;;; utilities
-
-;;; Return true if CONT's only use is a non-NOTINLINE reference to a
-;;; global function with one of the specified NAMES.
-(defun continuation-fun-is (cont names)
- (declare (type continuation cont) (list names))
- (let ((use (continuation-use cont)))
- (and (ref-p use)
- (let ((leaf (ref-leaf use)))
- (and (global-var-p leaf)
- (eq (global-var-kind leaf) :global-function)
- (not (null (member (leaf-source-name leaf) names
- :test #'equal))))))))
-
-;;; If CONT is a constant continuation, the return the constant value.
-;;; If it is null, then return default, otherwise quietly give up the
-;;; IR1 transform.
-;;;
-;;; ### Probably should take an ARG and flame using the NAME.
-(defun constant-value-or-lose (cont &optional default)
- (declare (type (or continuation null) cont))
- (cond ((not cont) default)
- ((constant-continuation-p cont)
- (continuation-value cont))
- (t
- (give-up-ir1-transform))))
-
-;;; FIXME: Why is this code commented out? (Why *was* it commented
-;;; out? We inherited this situation from cmucl-2.4.8, with no
-;;; explanation.) Should we just delete this code?
-#|
-;;; This is a frob whose job it is to make it easier to pass around
-;;; the arguments to IR1 transforms. It bundles together the name of
-;;; the argument (which should be referenced in any expansion), and
-;;; the continuation for that argument (or NIL if unsupplied.)
-(defstruct (arg (:constructor %make-arg (name cont))
- (:copier nil))
- (name nil :type symbol)
- (cont nil :type (or continuation null)))
-(defmacro make-arg (name)
- `(%make-arg ',name ,name))
-
-;;; If Arg is null or its CONT is null, then return Default, otherwise
-;;; return Arg's NAME.
-(defun default-arg (arg default)
- (declare (type (or arg null) arg))
- (if (and arg (arg-cont arg))
- (arg-name arg)
- default))
-
-;;; If Arg is null or has no CONT, return the default. Otherwise, Arg's
-;;; CONT must be a constant continuation whose value we return. If not, we
-;;; give up.
-(defun arg-constant-value (arg default)
- (declare (type (or arg null) arg))
- (if (and arg (arg-cont arg))
- (let ((cont (arg-cont arg)))
- (unless (constant-continuation-p cont)
- (give-up-ir1-transform "Argument is not constant: ~S."
- (arg-name arg)))
- (continuation-value from-end))
- default))
-
-;;; If Arg is a constant and is EQL to X, then return T, otherwise NIL. If
-;;; Arg is NIL or its CONT is NIL, then compare to the default.
-(defun arg-eql (arg default x)
- (declare (type (or arg null) x))
- (if (and arg (arg-cont arg))
- (let ((cont (arg-cont arg)))
- (and (constant-continuation-p cont)
- (eql (continuation-value cont) x)))
- (eql default x)))
-
-(defstruct (iterator (:copier nil))
- ;; The kind of iterator.
- (kind nil (member :normal :result))
- ;; A list of LET* bindings to create the initial state.
- (binds nil :type list)
- ;; A list of declarations for Binds.
- (decls nil :type list)
- ;; A form that returns the current value. This may be set with SETF to set
- ;; the current value.
- (current (error "Must specify CURRENT."))
- ;; In a :NORMAL iterator, a form that tests whether there is a current value.
- (done nil)
- ;; In a :RESULT iterator, a form that truncates the result at the current
- ;; position and returns it.
- (result nil)
- ;; A form that returns the initial total number of values. The result is
- ;; undefined after NEXT has been evaluated.
- (length (error "Must specify LENGTH."))
- ;; A form that advances the state to the next value. It is an error to call
- ;; this when the iterator is Done.
- (next (error "Must specify NEXT.")))
-
-;;; Type of an index var that can go negative (in the from-end case.)
-(deftype neg-index ()
- `(integer -1 ,most-positive-fixnum))
-
-;;; Return an ITERATOR structure describing how to iterate over an arbitrary
-;;; sequence. Sequence is a variable bound to the sequence, and Type is the
-;;; type of the sequence. If true, INDEX is a variable that should be bound to
-;;; the index of the current element in the sequence.
-;;;
-;;; If we can't tell whether the sequence is a list or a vector, or whether
-;;; the iteration is forward or backward, then GIVE-UP.
-(defun make-sequence-iterator (sequence type &key start end from-end index)
- (declare (symbol sequence) (type ctype type)
- (type (or arg null) start end from-end)
- (type (or symbol null) index))
- (let ((from-end (arg-constant-value from-end nil)))
- (cond ((csubtypep type (specifier-type 'vector))
- (let* ((n-stop (gensym))
- (n-idx (or index (gensym)))
- (start (default-arg 0 start))
- (end (default-arg `(length ,sequence) end)))
- (make-iterator
- :kind :normal
- :binds `((,n-idx ,(if from-end `(1- ,end) ,start))
- (,n-stop ,(if from-end `(1- ,start) ,end)))
- :decls `((type neg-index ,n-idx ,n-stop))
- :current `(aref ,sequence ,n-idx)
- :done `(,(if from-end '<= '>=) ,n-idx ,n-stop)
- :next `(setq ,n-idx
- ,(if from-end `(1- ,n-idx) `(1+ ,n-idx)))
- :length (if from-end
- `(- ,n-idx ,n-stop)
- `(- ,n-stop ,n-idx)))))
- ((csubtypep type (specifier-type 'list))
- (let* ((n-stop (if (and end (not from-end)) (gensym) nil))
- (n-current (gensym))
- (start-p (not (arg-eql start 0 0)))
- (end-p (not (arg-eql end nil nil)))
- (start (default-arg start 0))
- (end (default-arg end nil)))
- (make-iterator
- :binds `((,n-current
- ,(if from-end
- (if (or start-p end-p)
- `(nreverse (subseq ,sequence ,start
- ,@(when end `(,end))))
- `(reverse ,sequence))
- (if start-p
- `(nthcdr ,start ,sequence)
- sequence)))
- ,@(when n-stop
- `((,n-stop (nthcdr (the index
- (- ,end ,start))
- ,n-current))))
- ,@(when index
- `((,index ,(if from-end `(1- ,end) start)))))
- :kind :normal
- :decls `((list ,n-current ,n-end)
- ,@(when index `((type neg-index ,index))))
- :current `(car ,n-current)
- :done `(eq ,n-current ,n-stop)
- :length `(- ,(or end `(length ,sequence)) ,start)
- :next `(progn
- (setq ,n-current (cdr ,n-current))
- ,@(when index
- `((setq ,n-idx
- ,(if from-end
- `(1- ,index)
- `(1+ ,index)))))))))
- (t
- (give-up-ir1-transform
- "can't tell whether sequence is a list or a vector")))))
-
-;;; Make an iterator used for constructing result sequences. Name is a
-;;; variable to be bound to the result sequence. Type is the type of result
-;;; sequence to make. Length is an expression to be evaluated to get the
-;;; maximum length of the result (not evaluated in list case.)
-(defun make-result-sequence-iterator (name type length)
- (declare (symbol name) (type ctype type))
-
-;;; Define each NAME as a local macro that will call the value of the
-;;; function arg with the given arguments. If the argument isn't known to be a
-;;; function, give them an efficiency note and reference a coerced version.
-(defmacro coerce-funs (specs &body body)
- #!+sb-doc
- "COERCE-FUNCTIONS ({(Name Fun-Arg Default)}*) Form*"
- (collect ((binds)
- (defs))
- (dolist (spec specs)
- `(let ((body (progn ,@body))
- (n-fun (arg-name ,(second spec)))
- (fun-cont (arg-cont ,(second spec))))
- (cond ((not fun-cont)
- `(macrolet ((,',(first spec) (&rest args)
- `(,',',(third spec) ,@args)))
- ,body))
- ((not (csubtypep (continuation-type fun-cont)
- (specifier-type 'function)))
- (when (policy *compiler-error-context*
- (> speed inhibit-warnings))
- (compiler-note
- "~S may not be a function, so must coerce at run-time."
- n-fun))
- (once-only ((n-fun `(if (functionp ,n-fun)
- ,n-fun
- (symbol-function ,n-fun))))
- `(macrolet ((,',(first spec) (&rest args)
- `(funcall ,',n-fun ,@args)))
- ,body)))
- (t
- `(macrolet ((,',(first spec) (&rest args)
- `(funcall ,',n-fun ,@args)))
- ,body)))))))
-
-;;; Wrap code around the result of the body to define Name as a local macro
-;;; that returns true when its arguments satisfy the test according to the Args
-;;; Test and Test-Not. If both Test and Test-Not are supplied, abort the
-;;; transform.
-(defmacro with-sequence-test ((name test test-not) &body body)
- `(let ((not-p (arg-cont ,test-not)))
- (when (and (arg-cont ,test) not-p)
- (abort-ir1-transform "Both ~S and ~S were supplied."
- (arg-name ,test)
- (arg-name ,test-not)))
- (coerce-funs ((,name (if not-p ,test-not ,test) eql))
- ,@body)))
-|#
+ (if (null splice)
+ (setq list (cdr x))
+ (rplacd splice (cdr x))))
+ (t (setq splice x)))))
+
+(deftransform fill ((seq item &key (start 0) (end nil))
+ (list t &key (:start t) (:end t)))
+ '(list-fill* seq item start end))
+
+(deftransform fill ((seq item &key (start 0) (end nil))
+ (vector t &key (:start t) (:end t))
+ *
+ :node node)
+ (let* ((type (lvar-type seq))
+ (element-ctype (array-type-upgraded-element-type type))
+ (element-type (type-specifier element-ctype))
+ (saetp (unless (eq *wild-type* element-ctype)
+ (find-saetp-by-ctype element-ctype))))
+ (cond ((eq *wild-type* element-ctype)
+ (delay-ir1-transform node :constraint)
+ `(vector-fill* seq item start end))
+ ((and saetp (sb!vm::valid-bit-bash-saetp-p saetp))
+ (let* ((n-bits (sb!vm:saetp-n-bits saetp))
+ (basher-name (format nil "UB~D-BASH-FILL" n-bits))
+ (basher (or (find-symbol basher-name
+ (load-time-value (find-package :sb!kernel)))
+ (abort-ir1-transform
+ "Unknown fill basher, please report to sbcl-devel: ~A"
+ basher-name)))
+ (kind (cond ((sb!vm:saetp-fixnum-p saetp) :tagged)
+ ((member element-type '(character base-char)) :char)
+ ((eq element-type 'single-float) :single-float)
+ #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
+ ((eq element-type 'double-float) :double-float)
+ #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
+ ((equal element-type '(complex single-float))
+ :complex-single-float)
+ (t
+ (aver (integer-type-p element-ctype))
+ :bits)))
+ ;; BASH-VALUE is a word that we can repeatedly smash
+ ;; on the array: for less-than-word sized elements it
+ ;; contains multiple copies of the fill item.
+ (bash-value
+ (if (constant-lvar-p item)
+ (let ((tmp (lvar-value item)))
+ (unless (ctypep tmp element-ctype)
+ (abort-ir1-transform "~S is not ~S" tmp element-type))
+ (let* ((bits
+ (ldb (byte n-bits 0)
+ (ecase kind
+ (:tagged
+ (ash tmp sb!vm:n-fixnum-tag-bits))
+ (:char
+ (char-code tmp))
+ (:bits
+ tmp)
+ (:single-float
+ (single-float-bits tmp))
+ #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
+ (:double-float
+ (logior (ash (double-float-high-bits tmp) 32)
+ (double-float-low-bits tmp)))
+ #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
+ (:complex-single-float
+ (logior (ash (single-float-bits (imagpart tmp)) 32)
+ (ldb (byte 32 0)
+ (single-float-bits (realpart tmp))))))))
+ (res bits))
+ (loop for i of-type sb!vm:word from n-bits by n-bits
+ until (= i sb!vm:n-word-bits)
+ do (setf res (ldb (byte sb!vm:n-word-bits 0)
+ (logior res (ash bits i)))))
+ res))
+ (progn
+ (delay-ir1-transform node :constraint)
+ `(let* ((bits (ldb (byte ,n-bits 0)
+ ,(ecase kind
+ (:tagged
+ `(ash item ,sb!vm:n-fixnum-tag-bits))
+ (:char
+ `(char-code item))
+ (:bits
+ `item)
+ (:single-float
+ `(single-float-bits item))
+ #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
+ (:double-float
+ `(logior (ash (double-float-high-bits item) 32)
+ (double-float-low-bits item)))
+ #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
+ (:complex-single-float
+ `(logior (ash (single-float-bits (imagpart item)) 32)
+ (ldb (byte 32 0)
+ (single-float-bits (realpart item))))))))
+ (res bits))
+ (declare (type sb!vm:word res))
+ ,@(unless (= sb!vm:n-word-bits n-bits)
+ `((loop for i of-type sb!vm:word from ,n-bits by ,n-bits
+ until (= i sb!vm:n-word-bits)
+ do (setf res
+ (ldb (byte ,sb!vm:n-word-bits 0)
+ (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)
+ `((declare (type ,element-type item))))))
+ ((policy node (> speed space))
+ (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))
+ ;; WITH-ARRAY-DATA did our range checks once and for all, so
+ ;; it'd be wasteful to check again on every AREF...
+ (declare (optimize (safety 0) (speed 3)))
+ (do ((i start (1+ i)))
+ ((= i end) seq)
+ (declare (type index i))
+ (setf (aref data i) item)))
+ ;; ... though we still need to check that the new element can fit
+ ;; into the vector in safe code. -- CSR, 2002-07-05
+ `((declare (type ,element-type item)))))
+ ((csubtypep type (specifier-type 'string))
+ '(string-fill* seq item start end))
+ (t
+ '(vector-fill* seq item start end)))))
+
+(deftransform fill ((seq item &key (start 0) (end nil))
+ ((and sequence (not vector) (not list)) t &key (:start t) (:end t)))
+ `(sb!sequence:fill seq item
+ :start start
+ :end (%check-generic-sequence-bounds seq start end)))