X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fseqtran.lisp;h=71416a05c6ede86990df85e5a56e76231b4c500e;hb=29a9ccc860532b32c566aec095f570e999a9c52c;hp=81c943fce80fad4a599da92cb984df1390979a7c;hpb=e33fb894f991b2926d8f3bace9058e4c0b2c3a37;p=sbcl.git diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp index 81c943f..71416a0 100644 --- a/src/compiler/seqtran.lisp +++ b/src/compiler/seqtran.lisp @@ -227,62 +227,54 @@ (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-frob (name) + `(deftransform ,name ((e l &key (test #'eql)) * * :node node :when :both) + (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-frob member) + (def-frob 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) *) + "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-frob delete delq) + (def-frob assoc assq) + (def-frob member memq)) (deftransform delete-if ((pred list) (t list)) "open code" @@ -315,9 +307,9 @@ ;;;; 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 +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 @@ -485,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) @@ -529,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))) |# @@ -542,57 +537,57 @@ ;;; 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-frob (fun pred*) + `(deftransform ,fun ((string1 string2 &key (start1 0) end1 + (start2 0) end2) + * *) + `(,',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/=*)) + +;;; 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) *) + `(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-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) *) + `(,',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)) + ;;;; string-only transforms for sequence functions ;;;;