`(sequence-of-checked-length-given-type ,bare
result-type-arg))
(t
- (let ((result-ctype (specifier-type result-type)))
+ (let ((result-ctype (ir1-transform-specifier-type result-type)))
(if (array-type-p result-ctype)
(let* ((dims (array-type-dimensions result-ctype))
(dim (first dims)))
(subtypep result-type-value 'vector)
`(coerce (apply #'%map-to-simple-vector-arity-1 fun seqs)
',result-type-value))
- (t (give-up-ir1-transform
- "internal error: unexpected sequence type"))))
+ (t (bug "impossible (?) sequence type"))))
(t
(let* ((seq-args (make-gensym-list (length seqs)))
(index-bindingoids
(declare (ignorable dacc))
,push-dacc))))))))))
\f
-(deftransform elt ((s i) ((simple-array * (*)) *) * :when :both)
+(deftransform elt ((s i) ((simple-array * (*)) *) *)
'(aref s i))
-(deftransform elt ((s i) (list *) * :when :both)
+(deftransform elt ((s i) (list *) *)
'(nth i s))
-(deftransform %setelt ((s i v) ((simple-array * (*)) * *) * :when :both)
+(deftransform %setelt ((s i v) ((simple-array * (*)) * *) *)
'(%aset s i v))
(deftransform %setelt ((s i v) (list * *))
'(setf (car (nthcdr i s)) v))
-;;; FIXME: I still think (DOLIST (..) (DEFTRANSFORM ..)) is weird.
-;;; For that matter, it would be nice to use DEF-FROB for these
-;;; sorts of things, so folks looking for the definitions of
-;;; FOO can search for '\(def.*\<foo\>' and have a chance in hell..
-(dolist (name '(member memq))
- (deftransform name ((e l &key (test #'eql)) '* '* :node node :when :both
- :eval-name t)
- (unless (constant-continuation-p l)
- (give-up-ir1-transform))
-
- (let ((val (continuation-value l)))
- (unless (policy node
- (or (= speed 3)
- (and (>= speed space)
- (<= (length val) 5))))
- (give-up-ir1-transform))
-
- (labels ((frob (els)
- (if els
- `(if (funcall test e ',(car els))
- ',els
- ,(frob (cdr els)))
- nil)))
- (frob val)))))
-
-;;; FIXME: Rewrite this so that these definitions of DELETE, ASSOC, and MEMBER
-;;; are lexically findable:
-;;; (MACROLET ((DEF-FROB (X Y) ..))
-;;; (DEF-FROB DELETE DELQ)
-;;; (DEF-FROB ASSOC ASSQ)
-;;; (DEF-FROB MEMBER MEMQ))
-;;; And while I'm at it, I could save a few byte by implementing the
-;;; transform body as call to a shared function instead of duplicated
-;;; macroexpanded code.
-(dolist (x '((delete delq)
- (assoc assq)
- (member memq)))
- (destructuring-bind (fun eq-fun) x
- (deftransform fun ((item list &key test) '(t list &rest t) '*
- :eval-name t)
- "convert to EQ test"
- ;; FIXME: The scope of this transformation could be widened somewhat,
- ;; letting it work whenever the test is 'EQL and we know from the
- ;; type of ITEM that it #'EQ works like #'EQL on it. (E.g. types
- ;; FIXNUM, CHARACTER, and SYMBOL.)
- ;; If TEST is EQ, apply transform, else
- ;; if test is not EQL, then give up on transform, else
- ;; if ITEM is not a NUMBER or is a FIXNUM, apply transform, else
- ;; give up on transform.
- (cond (test
- (unless (continuation-function-is test '(eq))
- (give-up-ir1-transform)))
- ((types-equal-or-intersect (continuation-type item)
- (specifier-type 'number))
- (give-up-ir1-transform "Item might be a number.")))
- `(,eq-fun item list))))
+(macrolet ((def (name)
+ `(deftransform ,name ((e l &key (test #'eql)) * *
+ :node node)
+ (unless (constant-continuation-p l)
+ (give-up-ir1-transform))
+
+ (let ((val (continuation-value l)))
+ (unless (policy node
+ (or (= speed 3)
+ (and (>= speed space)
+ (<= (length val) 5))))
+ (give-up-ir1-transform))
+
+ (labels ((frob (els)
+ (if els
+ `(if (funcall test e ',(car els))
+ ',els
+ ,(frob (cdr els)))
+ nil)))
+ (frob val))))))
+ (def member)
+ (def memq))
+
+;;; FIXME: We have rewritten the original code that used DOLIST to this
+;;; more natural MACROLET. However, the original code suggested that when
+;;; this was done, a few bytes could be saved by a call to a shared
+;;; function. This remains to be done.
+(macrolet ((def (fun eq-fun)
+ `(deftransform ,fun ((item list &key test) (t list &rest t) *)
+ "convert to EQ test"
+ ;; FIXME: The scope of this transformation could be
+ ;; widened somewhat, letting it work whenever the test is
+ ;; 'EQL and we know from the type of ITEM that it #'EQ
+ ;; works like #'EQL on it. (E.g. types FIXNUM, CHARACTER,
+ ;; and SYMBOL.)
+ ;; If TEST is EQ, apply transform, else
+ ;; if test is not EQL, then give up on transform, else
+ ;; if ITEM is not a NUMBER or is a FIXNUM, apply
+ ;; transform, else give up on transform.
+ (cond (test
+ (unless (continuation-fun-is test '(eq))
+ (give-up-ir1-transform)))
+ ((types-equal-or-intersect (continuation-type item)
+ (specifier-type 'number))
+ (give-up-ir1-transform "Item might be a number.")))
+ `(,',eq-fun item list))))
+ (def delete delq)
+ (def assoc assq)
+ (def member memq))
(deftransform delete-if ((pred list) (t list))
"open code"
: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))
+ (values
+ `(with-array-data ((data seq)
+ (start start)
+ (end end))
(declare (type (simple-array ,element-type 1) data))
+ (declare (type fixnum start end))
(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.
+ ;; it'd be wasteful to check again on every AREF...
(declare (optimize (safety 0)))
- (setf (aref data i) item)))))
+ (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))))))
\f
;;;; utilities
-;;; Return true if CONT's only use is a non-notinline reference to a
+;;; Return true if CONT's only use is a non-NOTINLINE reference to a
;;; global function with one of the specified NAMES.
-(defun continuation-function-is (cont names)
+(defun continuation-fun-is (cont names)
(declare (type continuation cont) (list names))
(let ((use (continuation-use cont)))
(and (ref-p use)
(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
;; 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.
+ ;; 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
+ ;; 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
(defun make-result-sequence-iterator (name type length)
(declare (symbol name) (type ctype type))
-;;; Defines each Name as a local macro that will call the value of the
-;;; Fun-Arg with the given arguments. If the argument isn't known to be a
+;;; 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-functions (specs &body body)
+(defmacro coerce-funs (specs &body body)
#!+sb-doc
"COERCE-FUNCTIONS ({(Name Fun-Arg Default)}*) Form*"
(collect ((binds)
(abort-ir1-transform "Both ~S and ~S were supplied."
(arg-name ,test)
(arg-name ,test-not)))
- (coerce-functions ((,name (if not-p ,test-not ,test) eql))
+ (coerce-funs ((,name (if not-p ,test-not ,test) eql))
,@body)))
|#
\f
;;; We transform the case-sensitive string predicates into a non-keyword
;;; version. This is an IR1 transform so that we don't have to worry about
;;; changing the order of evaluation.
-(dolist (stuff '((string< string<*)
- (string> string>*)
- (string<= string<=*)
- (string>= string>=*)
- (string= string=*)
- (string/= string/=*)))
- (destructuring-bind (fun pred*) stuff
- (deftransform fun ((string1 string2 &key (start1 0) end1
- (start2 0) end2)
- '* '* :eval-name t)
- `(,pred* string1 string2 start1 end1 start2 end2))))
-
-;;; Return a form that tests the free variables STRING1 and STRING2 for the
-;;; ordering relationship specified by Lessp and Equalp. The start and end are
-;;; also gotten from the environment. Both strings must be simple strings.
-(dolist (stuff '((string<* t nil)
- (string<=* t t)
- (string>* nil nil)
- (string>=* nil t)))
- (destructuring-bind (name lessp equalp) stuff
- (deftransform name ((string1 string2 start1 end1 start2 end2)
- '(simple-string simple-string t t t t) '*
- :eval-name t)
- `(let* ((end1 (if (not end1) (length string1) end1))
- (end2 (if (not end2) (length string2) end2))
- (index (sb!impl::%sp-string-compare
- string1 start1 end1 string2 start2 end2)))
- (if index
- (cond ((= index ,(if lessp 'end1 'end2)) index)
- ((= index ,(if lessp 'end2 'end1)) nil)
- ((,(if lessp 'char< 'char>)
- (schar string1 index)
- (schar string2
- (truly-the index
- (+ index
- (truly-the fixnum
- (- start2 start1))))))
- index)
- (t nil))
- ,(if equalp 'end1 nil))))))
-
-(dolist (stuff '((string=* not)
- (string/=* identity)))
- (destructuring-bind (name result-fun) stuff
- (deftransform name ((string1 string2 start1 end1 start2 end2)
- '(simple-string simple-string t t t t) '*
- :eval-name t)
- `(,result-fun
- (sb!impl::%sp-string-compare
- string1 start1 (or end1 (length string1))
- string2 start2 (or end2 (length string2)))))))
+(macrolet ((def (fun pred*)
+ `(deftransform ,fun ((string1 string2 &key (start1 0) end1
+ (start2 0) end2)
+ * *)
+ `(,',pred* string1 string2 start1 end1 start2 end2))))
+ (def string< string<*)
+ (def string> string>*)
+ (def string<= string<=*)
+ (def string>= string>=*)
+ (def string= string=*)
+ (def string/= string/=*))
+
+;;; Return a form that tests the free variables STRING1 and STRING2
+;;; for the ordering relationship specified by LESSP and EQUALP. The
+;;; start and end are also gotten from the environment. Both strings
+;;; must be SIMPLE-STRINGs.
+(macrolet ((def (name lessp equalp)
+ `(deftransform ,name ((string1 string2 start1 end1 start2 end2)
+ (simple-string simple-string t t t t) *)
+ `(let* ((end1 (if (not end1) (length string1) end1))
+ (end2 (if (not end2) (length string2) end2))
+ (index (sb!impl::%sp-string-compare
+ string1 start1 end1 string2 start2 end2)))
+ (if index
+ (cond ((= index ,(if ',lessp 'end1 'end2)) index)
+ ((= index ,(if ',lessp 'end2 'end1)) nil)
+ ((,(if ',lessp 'char< 'char>)
+ (schar string1 index)
+ (schar string2
+ (truly-the index
+ (+ index
+ (truly-the fixnum
+ (- start2
+ start1))))))
+ index)
+ (t nil))
+ ,(if ',equalp 'end1 nil))))))
+ (def string<* t nil)
+ (def string<=* t t)
+ (def string>* nil nil)
+ (def string>=* nil t))
+
+(macrolet ((def (name result-fun)
+ `(deftransform ,name ((string1 string2 start1 end1 start2 end2)
+ (simple-string simple-string t t t t) *)
+ `(,',result-fun
+ (sb!impl::%sp-string-compare
+ string1 start1 (or end1 (length string1))
+ string2 start2 (or end2 (length string2)))))))
+ (def string=* not)
+ (def string/=* identity))
+
\f
;;;; string-only transforms for sequence functions
;;;;
;;;; calls when all arguments are vectors with the same element type,
;;;; rather than restricting them to STRINGs only.
+;;; Moved here from generic/vm-tran.lisp to satisfy clisp
+;;;
+;;; FIXME: It would be good to implement SB!XC:DEFCONSTANT, and use
+;;; use that here, so that the compiler is born knowing this value.
+;;; FIXME: Add a comment telling whether this holds for all vectors
+;;; or only for vectors based on simple arrays (non-adjustable, etc.).
+(def!constant vector-data-bit-offset
+ (* sb!vm:vector-data-offset sb!vm:n-word-bits))
+
;;; FIXME: Shouldn't we be testing for legality of
;;; * START1, START2, END1, and END2 indices?
;;; * size of copied string relative to destination string?
;;; %CONCATENATE (with a DEFTRANSFORM to translate constant RTYPE to
;;; CTYPE before calling %CONCATENATE) which is comparably efficient,
;;; at least once DYNAMIC-EXTENT works.
+;;;
+;;; FIXME: currently KLUDGEed because of bug 188
(deftransform concatenate ((rtype &rest sequences)
(t &rest simple-string)
- simple-string)
+ simple-string
+ :policy (< safety 3))
(collect ((lets)
(forms)
(all-lengths)
(args))
(dolist (seq sequences)
- (declare (ignore seq))
+ (declare (ignorable seq))
(let ((n-seq (gensym))
(n-length (gensym)))
(args n-seq)
(forms `(bit-bash-copy ,n-seq ,vector-data-bit-offset
res start
,n-length))
- (forms `(setq start (+ start ,n-length)))))
+ (forms `(setq start (opaque-identity (+ start ,n-length))))))
`(lambda (rtype ,@(args))
(declare (ignore rtype))
- (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))))
+ ;; 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)))))
\f
;;;; CONS accessor DERIVE-TYPE optimizers
(give-up-ir1-transform
"sequence type not known at compile time")))))
-;;; %FIND-POSITION-IF for LIST data
-(deftransform %find-position-if ((predicate sequence from-end start end key)
- (function list t t t function)
- *
- :policy (> speed space)
- :important t)
- "expand inline"
- '(let ((index 0)
- (find nil)
- (position nil))
- (declare (type index index))
- (dolist (i sequence (values find position))
- (let ((key-i (funcall key i)))
- (when (and end (>= index end))
- (return (values find position)))
- (when (>= index start)
- (when (funcall predicate key-i)
- ;; This hack of dealing with non-NIL FROM-END for list
- ;; data by iterating forward through the list and keeping
- ;; track of the last time we found a match might be more
- ;; screwy than what the user expects, but it seems to be
- ;; allowed by the ANSI standard. (And if the user is
- ;; screwy enough to ask for FROM-END behavior on list
- ;; data, turnabout is fair play.)
- ;;
- ;; It's also not enormously efficient, calling PREDICATE
- ;; and KEY more often than necessary; but all the
- ;; alternatives seem to have their own efficiency
- ;; problems.
- (if from-end
- (setf find i
- position index)
- (return (values i index))))))
- (incf index))))
-
+;;; %FIND-POSITION-IF and %FIND-POSITION-IF-NOT for LIST data
+(macrolet ((def (name condition)
+ `(deftransform ,name ((predicate sequence from-end start end key)
+ (function list t t t function)
+ *
+ :policy (> speed space)
+ :important t)
+ "expand inline"
+ `(let ((index 0)
+ (find nil)
+ (position nil))
+ (declare (type index index))
+ (dolist (i sequence (values find position))
+ (let ((key-i (funcall key i)))
+ (when (and end (>= index end))
+ (return (values find position)))
+ (when (>= index start)
+ (,',condition (funcall predicate key-i)
+ ;; This hack of dealing with non-NIL
+ ;; FROM-END for list data by iterating
+ ;; forward through the list and keeping
+ ;; track of the last time we found a match
+ ;; might be more screwy than what the user
+ ;; expects, but it seems to be allowed by
+ ;; the ANSI standard. (And if the user is
+ ;; screwy enough to ask for FROM-END
+ ;; behavior on list data, turnabout is
+ ;; fair play.)
+ ;;
+ ;; It's also not enormously efficient,
+ ;; calling PREDICATE and KEY more often
+ ;; than necessary; but all the
+ ;; alternatives seem to have their own
+ ;; efficiency problems.
+ (if from-end
+ (setf find i
+ position index)
+ (return (values i index))))))
+ (incf index))))))
+ (def %find-position-if when)
+ (def %find-position-if-not unless))
+
;;; %FIND-POSITION for LIST data can be expanded into %FIND-POSITION-IF
;;; without loss of efficiency. (I.e., the optimizer should be able
;;; to straighten everything out.)
element
`(funcall ,predicate (funcall ,key ,element)))))
-;;; %FIND-POSITION and %FIND-POSITION-IF for VECTOR data
+(def!macro %find-position-if-not-vector-macro (predicate sequence
+ from-end start end key)
+ (let ((element (gensym "ELEMENT")))
+ (%find-position-or-find-position-if-vector-expansion
+ sequence
+ from-end
+ start
+ end
+ element
+ `(not (funcall ,predicate (funcall ,key ,element))))))
+
+;;; %FIND-POSITION, %FIND-POSITION-IF and %FIND-POSITION-IF-NOT for
+;;; VECTOR data
(deftransform %find-position-if ((predicate sequence from-end start end key)
(function vector t t t function)
*
(check-inlineability-of-find-position-if sequence from-end)
'(%find-position-if-vector-macro predicate sequence
from-end start end key))
+
+(deftransform %find-position-if-not ((predicate sequence from-end start end key)
+ (function vector t t t function)
+ *
+ :policy (> speed space)
+ :important t)
+ "expand inline"
+ (check-inlineability-of-find-position-if sequence from-end)
+ '(%find-position-if-not-vector-macro predicate sequence
+ from-end start end key))
+
(deftransform %find-position ((item sequence from-end start end key test)
(t vector t t t function function)
*