X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fseqtran.lisp;h=0ece88aa56a14b49d97001de6e77a1bc833ef3fe;hb=8ac4c19014a23665e5842d0a989cb9d22d1592ed;hp=91713e50437dd7a4725bc61771d8c7a8d2e480f9;hpb=23f1e2ef66bcc31ca7ea765a82a97998119aa4d5;p=sbcl.git diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp index 91713e5..0ece88a 100644 --- a/src/compiler/seqtran.lisp +++ b/src/compiler/seqtran.lisp @@ -93,7 +93,7 @@ `(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))) @@ -161,8 +161,7 @@ (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 @@ -215,27 +214,21 @@ (declare (ignorable dacc)) ,push-dacc)))))))))) -(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: The MACROLET ... DEF-FROB ... DEFTRANSFORM idioms in this -;;; file are literal translations of old CMU CL DOLIST ... DEFTRANSFORM, -;;; and so use :EVAL-NAME for historical reasons. It'd be tidier to -;;; just let macroexpansion substitution take care of everything, -;;; and remove both :EVAL-NAME and the extra layer of quotes. - -(macrolet ((def-frob (name) - `(deftransform ',name ((e l &key (test #'eql)) '* '* :node node :when :both - :eval-name t) +(macrolet ((def (name) + `(deftransform ,name ((e l &key (test #'eql)) * * + :node node) (unless (constant-continuation-p l) (give-up-ir1-transform)) @@ -253,16 +246,15 @@ ,(frob (cdr els))) nil))) (frob val)))))) - (def-frob member) - (def-frob memq)) + (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-frob (fun eq-fun) - `(deftransform ',fun ((item list &key test) '(t list &rest t) '* - :eval-name t) +(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 @@ -274,15 +266,15 @@ ;; 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)) + (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-frob delete delq) - (def-frob assoc assq) - (def-frob member memq)) + (def delete delq) + (def assoc assq) + (def member memq)) (deftransform delete-if ((pred list) (t list)) "open code" @@ -301,23 +293,28 @@ :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)))))) ;;;; 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) @@ -340,6 +337,9 @@ (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 @@ -393,9 +393,9 @@ ;; 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 @@ -485,10 +485,10 @@ (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) @@ -529,7 +529,7 @@ (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))) |# @@ -542,26 +542,25 @@ ;;; 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. -(macrolet ((def-frob (fun pred*) - `(deftransform ',fun ((string1 string2 &key (start1 0) end1 +(macrolet ((def (fun pred*) + `(deftransform ,fun ((string1 string2 &key (start1 0) end1 (start2 0) end2) - '* '* :eval-name t) + * *) `(,',pred* string1 string2 start1 end1 start2 end2)))) - (def-frob string< string<*) - (def-frob string> string>*) - (def-frob string<= string<=*) - (def-frob string>= string>=*) - (def-frob string= string=*) - (def-frob string/= string/=*)) + (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-frob (name lessp equalp) - `(deftransform ',name ((string1 string2 start1 end1 start2 end2) - '(simple-string simple-string t t t t) '* - :eval-name t) +(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 @@ -575,25 +574,25 @@ (truly-the index (+ index (truly-the fixnum - (- start2 start1)))))) + (- start2 + start1)))))) index) (t nil)) ,(if ',equalp 'end1 nil)))))) - (def-frob string<* t nil) - (def-frob string<=* t t) - (def-frob string>* nil nil) - (def-frob string>=* nil t)) - -(macrolet ((def-frob (name result-fun) - `(deftransform ',name ((string1 string2 start1 end1 start2 end2) - '(simple-string simple-string t t t t) '* - :eval-name t) + (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-frob string=* not) - (def-frob string/=* identity)) + (def string=* not) + (def string/=* identity)) ;;;; string-only transforms for sequence functions @@ -611,6 +610,15 @@ ;;;; 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? @@ -644,6 +652,7 @@ ;;; %CONCATENATE (with a DEFTRANSFORM to translate constant RTYPE to ;;; CTYPE before calling %CONCATENATE) which is comparably efficient, ;;; at least once DYNAMIC-EXTENT works. +#+nil ; FIXME: currently commented out because of bug 188 (deftransform concatenate ((rtype &rest sequences) (t &rest simple-string) simple-string) @@ -652,7 +661,7 @@ (all-lengths) (args)) (dolist (seq sequences) - (declare (ignore seq)) + (declare (ignorable seq)) (let ((n-seq (gensym)) (n-length (gensym))) (args n-seq) @@ -711,41 +720,48 @@ (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.) @@ -851,7 +867,19 @@ 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) * @@ -861,6 +889,17 @@ (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) *