X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fseqtran.lisp;h=a1fc338a67f00825ed67dcfd0be1a49cd6a79400;hb=740af378fef405f7d3735fd95423d90100a10beb;hp=6e39e29c176e1249e124e5590dcba5afe6278cdc;hpb=397b000303e15df61661d9726126ee99ee10d9c6;p=sbcl.git diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp index 6e39e29..a1fc338 100644 --- a/src/compiler/seqtran.lisp +++ b/src/compiler/seqtran.lisp @@ -48,22 +48,22 @@ (do-anonymous ,(do-clauses) (,endtest ,n-first) ,call)))))))) -(def-source-transform mapc (function list &rest more-lists) +(define-source-transform mapc (function list &rest more-lists) (mapfoo-transform function (cons list more-lists) nil t)) -(def-source-transform mapcar (function list &rest more-lists) +(define-source-transform mapcar (function list &rest more-lists) (mapfoo-transform function (cons list more-lists) :list t)) -(def-source-transform mapcan (function list &rest more-lists) +(define-source-transform mapcan (function list &rest more-lists) (mapfoo-transform function (cons list more-lists) :nconc t)) -(def-source-transform mapl (function list &rest more-lists) +(define-source-transform mapl (function list &rest more-lists) (mapfoo-transform function (cons list more-lists) nil nil)) -(def-source-transform maplist (function list &rest more-lists) +(define-source-transform maplist (function list &rest more-lists) (mapfoo-transform function (cons list more-lists) :list nil)) -(def-source-transform mapcon (function list &rest more-lists) +(define-source-transform mapcon (function list &rest more-lists) (mapfoo-transform function (cons list more-lists) :nconc nil)) ;;;; mapping onto sequences: the MAP function @@ -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 @@ -203,7 +202,7 @@ ;; of the &REST vars.) `(lambda (result-type fun ,@seq-args) (declare (ignore result-type)) - (do ((really-fun (%coerce-callable-to-function fun)) + (do ((really-fun (%coerce-callable-to-fun fun)) ,@index-bindingoids (acc nil)) ((or ,@tests) @@ -215,74 +214,67 @@ (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: 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.*\' 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" @@ -312,48 +304,20 @@ ;; it'd be wasteful to check again on every AREF. (declare (optimize (safety 0))) (setf (aref data i) item))))) - -(deftransform position ((item list &key (test #'eql)) (t list)) - "open code" - '(do ((i 0 (1+ i)) - (l list (cdr l))) - ((endp l) nil) - (declare (type index i)) - (when (funcall test item (car l)) (return i)))) - -(deftransform position ((item vec &key (test #'eql) (start 0) - (end (length vec))) - (t simple-array &key (:start t) (:end index))) - "open code" - '(do ((i start (1+ i))) - ((= i end) nil) - (declare (type index i)) - (when (funcall test item (aref vec i)) (return i)))) - -;;; names of predicates that compute the same value as CHAR= when -;;; applied to characters -(defparameter *char=-functions* '(eql equal char=)) - -(deftransform find ((item sequence &key from-end (test #'eql) (start 0) end) - (t simple-string &rest t)) - `(if (position item sequence - ,@(when from-end `(:from-end from-end)) - :test test :start start :end end) - item - nil)) ;;;; 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) (let ((leaf (ref-leaf use))) (and (global-var-p leaf) (eq (global-var-kind leaf) :global-function) - (not (null (member (leaf-name leaf) names :test #'equal)))))))) + (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 @@ -368,6 +332,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 @@ -421,9 +388,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 @@ -513,10 +480,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) @@ -557,7 +524,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))) |# @@ -570,57 +537,58 @@ ;;; 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)) + ;;;; string-only transforms for sequence functions ;;;; @@ -637,6 +605,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? @@ -652,18 +629,18 @@ (declare (optimize (safety 0))) (bit-bash-copy string2 (the index - (+ (the index (* start2 sb!vm:byte-bits)) + (+ (the index (* start2 sb!vm:n-byte-bits)) ,vector-data-bit-offset)) string1 (the index - (+ (the index (* start1 sb!vm:byte-bits)) + (+ (the index (* start1 sb!vm:n-byte-bits)) ,vector-data-bit-offset)) (the index (* (min (the index (- (or end1 (length string1)) start1)) (the index (- (or end2 (length string2)) start2))) - sb!vm:byte-bits))) + sb!vm:n-byte-bits))) string1)) ;;; FIXME: It seems as though it should be possible to make a DEFUN @@ -678,11 +655,11 @@ (all-lengths) (args)) (dolist (seq sequences) - (declare (ignore seq)) + (declare (ignorable seq)) (let ((n-seq (gensym)) (n-length (gensym))) (args n-seq) - (lets `(,n-length (the index (* (length ,n-seq) sb!vm:byte-bits)))) + (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 @@ -692,7 +669,7 @@ (declare (ignore rtype)) (let* (,@(lets) (res (make-string (truncate (the index (+ ,@(all-lengths))) - sb!vm:byte-bits))) + sb!vm:n-byte-bits))) (start ,vector-data-bit-offset)) (declare (type index start ,@(all-lengths))) ,@(forms) @@ -715,3 +692,214 @@ null-type) ((cons-type-p type) (cons-type-cdr-type type))))) + +;;;; FIND, POSITION, and their -IF and -IF-NOT variants + +;;; We want to make sure that %FIND-POSITION is inline-expanded into +;;; %FIND-POSITION-IF only when %FIND-POSITION-IF has an inline +;;; expansion, so we factor out the condition into this function. +(defun check-inlineability-of-find-position-if (sequence from-end) + (let ((ctype (continuation-type sequence))) + (cond ((csubtypep ctype (specifier-type 'vector)) + ;; It's not worth trying to inline vector code unless we + ;; know a fair amount about it at compile time. + (upgraded-element-type-specifier-or-give-up sequence) + (unless (constant-continuation-p from-end) + (give-up-ir1-transform + "FROM-END argument value not known at compile time"))) + ((csubtypep ctype (specifier-type 'list)) + ;; Inlining on lists is generally worthwhile. + ) + (t + (give-up-ir1-transform + "sequence type not known at compile time"))))) + +;;; %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.) +(deftransform %find-position ((item sequence from-end start end key test) + (t list t t t t t) + * + :policy (> speed space) + :important t) + "expand inline" + '(%find-position-if (let ((test-fun (%coerce-callable-to-fun test))) + ;; I'm having difficulty believing I'm + ;; reading it right, but as far as I can see, + ;; the only guidance that ANSI gives for the + ;; order of arguments to asymmetric tests is + ;; the character-set dependent example from + ;; the definition of FIND, + ;; (find #\d "here are some.." :test #'char>) + ;; => #\Space + ;; (In ASCII, we have (CHAR> #\d #\SPACE)=>T.) + ;; (Neither the POSITION definition page nor + ;; section 17.2 ("Rules about Test Functions") + ;; seem to consider the possibility of + ;; asymmetry.) + ;; + ;; So, judging from the example, we want to + ;; do (FUNCALL TEST-FUN ITEM I), because + ;; (FUNCALL #'CHAR> #\d #\SPACE)=>T. + ;; + ;; -- WHN (whose attention was drawn to it by + ;; Alexey Dejneka's bug report/fix) + (lambda (i) + (funcall test-fun item i))) + sequence + from-end + start + end + (%coerce-callable-to-fun key))) + +;;; The inline expansions for the VECTOR case are saved as macros so +;;; that we can share them between the DEFTRANSFORMs and the default +;;; cases in the DEFUNs. (This isn't needed for the LIST case, because +;;; the DEFTRANSFORMs for LIST are less choosy about when to expand.) +(defun %find-position-or-find-position-if-vector-expansion (sequence-arg + from-end + start + 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-"))) + `(let ((,n-sequence ,sequence-arg) + (,n-end ,end-arg)) + (with-array-data ((,sequence ,n-sequence :offset-var ,offset) + (,start ,start) + (,end (or ,n-end (length ,n-sequence)))) + (block ,block + (macrolet ((maybe-return () + '(let ((,element (aref ,sequence ,index))) + (when ,done-p-expr + (return-from ,block + (values ,element + (- ,index ,offset))))))) + (if ,from-end + (loop for ,index + ;; (If we aren't fastidious about declaring that + ;; INDEX might be -1, then (FIND 1 #() :FROM-END T) + ;; can send us off into never-never land, since + ;; INDEX is initialized to -1.) + of-type index-or-minus-1 + from (1- ,end) downto ,start do + (maybe-return)) + (loop for ,index of-type index from ,start below ,end do + (maybe-return)))) + (values nil nil)))))) + +(def!macro %find-position-vector-macro (item sequence + from-end start end key test) + (let ((element (gensym "ELEMENT"))) + (%find-position-or-find-position-if-vector-expansion + sequence + from-end + start + end + element + ;; (See the LIST transform for a discussion of the correct + ;; argument order, i.e. whether the searched-for ,ITEM goes before + ;; or after the checked sequence element.) + `(funcall ,test ,item (funcall ,key ,element))))) + +(def!macro %find-position-if-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 + `(funcall ,predicate (funcall ,key ,element))))) + +(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) + * + :policy (> speed space) + :important t) + "expand inline" + (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) + * + :policy (> speed space) + :important t) + "expand inline" + (check-inlineability-of-find-position-if sequence from-end) + '(%find-position-vector-macro item sequence + from-end start end key test))