`(let ((,fn-sym ,fn)
(,map-result (list nil)))
(do-anonymous ((,temp ,map-result) . ,(do-clauses))
- (,endtest (cdr ,map-result))
+ (,endtest (truly-the list (cdr ,map-result)))
(rplacd ,temp (setq ,temp (list ,call)))))))
((nil)
`(let ((,fn-sym ,fn)
(,n-first ,(first arglists)))
(do-anonymous ,(do-clauses)
- (,endtest ,n-first) ,call))))))))
+ (,endtest (truly-the list ,n-first))
+ ,call))))))))
(define-source-transform mapc (function list &rest more-lists)
(mapfoo-transform function (cons list more-lists) nil t))
;;; MAP is %MAP plus a check to make sure that any length specified in
;;; the result type matches the actual result. We also wrap it in a
;;; TRULY-THE for the most specific type we can determine.
-(deftransform map ((result-type-arg fun &rest seqs) * * :node node)
- (let* ((seq-names (make-gensym-list (length seqs)))
+(deftransform map ((result-type-arg fun seq &rest seqs) * * :node node)
+ (let* ((seq-names (make-gensym-list (1+ (length seqs))))
(bare `(%map result-type-arg fun ,@seq-names))
(constant-result-type-arg-p (constant-continuation-p result-type-arg))
;; what we know about the type of the result. (Note that the
;; subtype of VECTOR but not an ARRAY-TYPE?
bare))))))))
+;;; Return a DO loop, mapping a function FUN to elements of
+;;; sequences. SEQS is a list of continuations, SEQ-NAMES - list of
+;;; variables, bound to sequences, INTO - a variable, which is used in
+;;; MAP-INTO. RESULT and BODY are forms, which can use variables
+;;; FUNCALL-RESULT, containing the result of application of FUN, and
+;;; INDEX, containing the current position in sequences.
+(defun build-sequence-iterator (seqs seq-names &key result into body)
+ (declare (type list seqs seq-names)
+ (type symbol into))
+ (collect ((bindings)
+ (declarations)
+ (vector-lengths)
+ (tests)
+ (places))
+ (let ((found-vector-p nil))
+ (flet ((process-vector (length)
+ (unless found-vector-p
+ (setq found-vector-p t)
+ (bindings `(index 0 (1+ index)))
+ (declarations `(type index index)))
+ (vector-lengths length)))
+ (loop for seq of-type continuation in seqs
+ for seq-name in seq-names
+ for type = (continuation-type seq)
+ do (cond ((csubtypep type (specifier-type 'list))
+ (with-unique-names (index)
+ (bindings `(,index ,seq-name (cdr ,index)))
+ (declarations `(type list ,index))
+ (places `(car ,index))
+ (tests `(endp ,index))))
+ ((csubtypep type (specifier-type 'vector))
+ (process-vector `(length ,seq-name))
+ (places `(aref ,seq-name index)))
+ (t
+ (give-up-ir1-transform
+ "can't determine sequence argument type"))))
+ (when into
+ (process-vector `(array-dimension ,into 0))))
+ (when found-vector-p
+ (bindings `(length (min ,@(vector-lengths))))
+ (tests `(= index length)))
+ `(do (,@(bindings))
+ ((or ,@(tests)) ,result)
+ (declare ,@(declarations))
+ (let ((funcall-result (funcall fun ,@(places))))
+ (declare (ignorable funcall-result))
+ ,body)))))
+
;;; Try to compile %MAP efficiently when we can determine sequence
;;; argument types at compile time.
;;;
;;; handle that case more efficiently, but it's left as an exercise to
;;; the reader, because the code is complicated enough already and I
;;; don't happen to need that functionality right now. -- WHN 20000410
-(deftransform %map ((result-type fun &rest seqs) * * :policy (>= speed space))
+(deftransform %map ((result-type fun seq &rest seqs) * *
+ :policy (>= speed space))
"open code"
- (unless seqs (abort-ir1-transform "no sequence args"))
(unless (constant-continuation-p result-type)
(give-up-ir1-transform "RESULT-TYPE argument not constant"))
- (labels (;; 1-valued SUBTYPEP, fails unless second value of SUBTYPEP is true
+ (labels ( ;; 1-valued SUBTYPEP, fails unless second value of SUBTYPEP is true
(fn-1subtypep (fn x y)
(multiple-value-bind (subtype-p valid-p) (funcall fn x y)
(if valid-p
subtype-p
(give-up-ir1-transform
"can't analyze sequence type relationship"))))
- (1subtypep (x y) (fn-1subtypep #'sb!xc:subtypep x y))
- (1csubtypep (x y) (fn-1subtypep #'csubtypep x y))
- (seq-supertype (seq)
- (let ((ctype (continuation-type seq)))
- (cond ((1csubtypep ctype (specifier-type 'vector)) 'vector)
- ((1csubtypep ctype (specifier-type 'list)) 'list)
- (t
- (give-up-ir1-transform
- "can't determine sequence argument type"))))))
+ (1subtypep (x y) (fn-1subtypep #'sb!xc:subtypep x y)))
(let* ((result-type-value (continuation-value result-type))
(result-supertype (cond ((null result-type-value) 'null)
((1subtypep result-type-value 'vector)
'list)
(t
(give-up-ir1-transform
- "can't determine result type"))))
- (seq-supertypes (mapcar #'seq-supertype seqs)))
- (cond ((and result-type-value (= 1 (length seqs)))
+ "can't determine result type")))))
+ (cond ((and result-type-value (null seqs))
;; The consing arity-1 cases can be implemented
;; reasonably efficiently as function calls, and the cost
;; of consing should be significantly larger than
;; function call overhead, so we always compile these
;; cases as full calls regardless of speed-versus-space
;; optimization policy.
- (cond ((subtypep 'list result-type-value)
- '(apply #'%map-to-list-arity-1 fun seqs))
- (;; (This one can be inefficient due to COERCE, but
+ (cond ((subtypep result-type-value 'list)
+ '(%map-to-list-arity-1 fun seq))
+ ( ;; (This one can be inefficient due to COERCE, but
;; the current open-coded implementation has the
;; same problem.)
(subtypep result-type-value 'vector)
- `(coerce (apply #'%map-to-simple-vector-arity-1 fun seqs)
+ `(coerce (%map-to-simple-vector-arity-1 fun seq)
',result-type-value))
(t (bug "impossible (?) sequence type"))))
(t
- (let* ((seq-args (make-gensym-list (length seqs)))
- (index-bindingoids
- (mapcar (lambda (seq-arg seq-supertype)
- (let ((i (gensym "I")))
- (ecase seq-supertype
- (vector `(,i 0 (1+ ,i)))
- (list `(,i ,seq-arg (rest ,i))))))
- seq-args seq-supertypes))
- (indices (mapcar #'first index-bindingoids))
- (index-decls (mapcar (lambda (index seq-supertype)
- `(type ,(ecase seq-supertype
- (vector 'index)
- (list 'list))
- ,index))
- indices seq-supertypes))
- (tests (mapcar (lambda (seq-arg seq-supertype index)
- (ecase seq-supertype
- (vector `(>= ,index (length ,seq-arg)))
- (list `(endp ,index))))
- seq-args seq-supertypes indices))
- (values (mapcar (lambda (seq-arg seq-supertype index)
- (ecase seq-supertype
- (vector `(aref ,seq-arg ,index))
- (list `(first ,index))))
- seq-args seq-supertypes indices)))
- (multiple-value-bind (push-dacc final-result)
+ (let* ((seqs (cons seq seqs))
+ (seq-args (make-gensym-list (length seqs))))
+ (multiple-value-bind (push-dacc result)
(ecase result-supertype
(null (values nil nil))
- (list (values `(push dacc acc) `(nreverse acc)))
- (vector (values `(push dacc acc)
+ (list (values `(push funcall-result acc)
+ `(nreverse acc)))
+ (vector (values `(push funcall-result acc)
`(coerce (nreverse acc)
',result-type-value))))
;; (We use the same idiom, of returning a LAMBDA from
;; of the &REST vars.)
`(lambda (result-type fun ,@seq-args)
(declare (ignore result-type))
- (do ((really-fun (%coerce-callable-to-fun fun))
- ,@index-bindingoids
- (acc nil))
- ((or ,@tests)
- ,final-result)
- (declare ,@index-decls)
- (declare (type list acc))
- (declare (ignorable acc))
- (let ((dacc (funcall really-fun ,@values)))
- (declare (ignorable dacc))
- ,push-dacc))))))))))
+ (let ((fun (%coerce-callable-to-fun fun))
+ (acc nil))
+ (declare (type list acc))
+ (declare (ignorable acc))
+ ,(build-sequence-iterator
+ seqs seq-args
+ :result result
+ :body push-dacc))))))))))
;;; MAP-INTO
(deftransform map-into ((result fun &rest seqs)
(gensym))
seqs)))
`(lambda (result fun ,@seqs-names)
- (let ((length (array-dimension result 0))
- (i 0))
- (declare (type index i))
- (declare (ignorable i))
- ,(cond ((null seqs)
- `(dotimes (j length (setq i length))
- (setf (aref result j) (funcall fun))))
- (t
- `(block nil
- (map nil
- (lambda (,@seqs-names)
- (when (= i length) (return))
- (setf (aref result i)
- (funcall fun ,@seqs-names))
- (incf i))
- ,@seqs-names))))
- (when (array-has-fill-pointer-p result)
- (setf (fill-pointer result) i))
- result))))
+ ,(build-sequence-iterator
+ seqs seqs-names
+ :result '(when (array-has-fill-pointer-p result)
+ (setf (fill-pointer result) index))
+ :into 'result
+ :body '(setf (aref result index) funcall-result))
+ result)))
\f
;;; FIXME: once the confusion over doing transforms with known-complex
(specifier-type 'function)))
(when (policy *compiler-error-context*
(> speed inhibit-warnings))
- (compiler-note
+ (compiler-notify
"~S may not be a function, so must coerce at run-time."
n-fun))
(once-only ((n-fun `(if (functionp ,n-fun)
(t &rest simple-string)
simple-string
:policy (< safety 3))
- (collect ((lets)
- (forms)
- (all-lengths)
- (args))
- (dolist (seq sequences)
- (declare (ignorable seq))
- (let ((n-seq (gensym))
- (n-length (gensym)))
- (args n-seq)
- (lets `(,n-length (the index (* (length ,n-seq) sb!vm:n-byte-bits))))
- (all-lengths n-length)
- (forms `(bit-bash-copy ,n-seq ,vector-data-bit-offset
- res start
- ,n-length))
- (forms `(setq start (opaque-identity (+ start ,n-length))))))
- `(lambda (rtype ,@(args))
- (declare (ignore rtype))
- ;; KLUDGE
- (flet ((opaque-identity (x) x))
- (declare (notinline opaque-identity))
- (let* (,@(lets)
- (res (make-string (truncate (the index (+ ,@(all-lengths)))
- sb!vm:n-byte-bits)))
- (start ,vector-data-bit-offset))
- (declare (type index start ,@(all-lengths)))
- ,@(forms)
- res)))))
+ (loop for rest-seqs on sequences
+ for n-seq = (gensym "N-SEQ")
+ for n-length = (gensym "N-LENGTH")
+ for start = vector-data-bit-offset then next-start
+ for next-start = (gensym "NEXT-START")
+ collect n-seq into args
+ collect `(,n-length (* (length ,n-seq) sb!vm:n-byte-bits)) into lets
+ collect n-length into all-lengths
+ collect next-start into starts
+ collect `(bit-bash-copy ,n-seq ,vector-data-bit-offset
+ res ,start ,n-length)
+ into forms
+ collect `(setq ,next-start (+ ,start ,n-length)) into forms
+ finally
+ (return
+ `(lambda (rtype ,@args)
+ (declare (ignore rtype))
+ (let* (,@lets
+ (res (make-string (truncate (the index (+ ,@all-lengths))
+ sb!vm:n-byte-bits))))
+ (declare (type index ,@all-lengths))
+ (let (,@(mapcar (lambda (name) `(,name 0)) starts))
+ (declare (type index ,@starts))
+ ,@forms)
+ res)))))
\f
;;;; CONS accessor DERIVE-TYPE optimizers
end-arg
element
done-p-expr)
- (let ((offset (gensym "OFFSET"))
- (block (gensym "BLOCK"))
- (index (gensym "INDEX"))
- (n-sequence (gensym "N-SEQUENCE-"))
- (sequence (gensym "SEQUENCE"))
- (n-end (gensym "N-END-"))
- (end (gensym "END-")))
+ (with-unique-names (offset block index n-sequence sequence n-end end)
`(let ((,n-sequence ,sequence-arg)
(,n-end ,end-arg))
(with-array-data ((,sequence ,n-sequence :offset-var ,offset)
(def!macro %find-position-vector-macro (item sequence
from-end start end key test)
- (let ((element (gensym "ELEMENT")))
+ (with-unique-names (element)
(%find-position-or-find-position-if-vector-expansion
sequence
from-end
(def!macro %find-position-if-vector-macro (predicate sequence
from-end start end key)
- (let ((element (gensym "ELEMENT")))
+ (with-unique-names (element)
(%find-position-or-find-position-if-vector-expansion
sequence
from-end
(def!macro %find-position-if-not-vector-macro (predicate sequence
from-end start end key)
- (let ((element (gensym "ELEMENT")))
+ (with-unique-names (element)
(%find-position-or-find-position-if-vector-expansion
sequence
from-end