Mercurial > hg > xemacs-beta
changeset 5502:5b08be74bb53
Be better about recognising side-effect-free forms, byte-optimize.el.
2011-05-07 Aidan Kehoe <kehoea@parhasard.net>
* byte-optimize.el:
* byte-optimize.el (byte-optimize-form-code-walker):
Call #'byte-optimize-side-effect-free-p on the form, rather than
just checking the plist of the form's car.
* byte-optimize.el (side-effect-free-fns):
Move the CL functions into their alphabetical place in the list.
* byte-optimize.el (function):
* byte-optimize.el (byte-optimize-side-effect-free-p): New.
Function returning non-nil if a funcall has no side-effects, which
handles things like (remove* item list :key 'car) and
(remove-if-not #'integerp list).
author | Aidan Kehoe <kehoea@parhasard.net> |
---|---|
date | Sat, 07 May 2011 11:45:20 +0100 |
parents | 4813ff11c6e2 |
children | 7b5946dbfb96 |
files | lisp/ChangeLog lisp/byte-optimize.el |
diffstat | 2 files changed, 52 insertions(+), 22 deletions(-) [+] |
line wrap: on
line diff
--- a/lisp/ChangeLog Fri May 06 10:37:14 2011 +0100 +++ b/lisp/ChangeLog Sat May 07 11:45:20 2011 +0100 @@ -1,3 +1,17 @@ +2011-05-07 Aidan Kehoe <kehoea@parhasard.net> + + * byte-optimize.el: + * byte-optimize.el (byte-optimize-form-code-walker): + Call #'byte-optimize-side-effect-free-p on the form, rather than + just checking the plist of the form's car. + * byte-optimize.el (side-effect-free-fns): + Move the CL functions into their alphabetical place in the list. + * byte-optimize.el (function): + * byte-optimize.el (byte-optimize-side-effect-free-p): New. + Function returning non-nil if a funcall has no side-effects, which + handles things like (remove* item list :key 'car) and + (remove-if-not #'integerp list). + 2011-05-06 Aidan Kehoe <kehoea@parhasard.net> * cl-macs.el (most-positive-fixnum-on-32-bit-machines):
--- a/lisp/byte-optimize.el Fri May 06 10:37:14 2011 +0100 +++ b/lisp/byte-optimize.el Sat May 07 11:45:20 2011 +0100 @@ -524,21 +524,17 @@ byte-compile-macro-environment)))) (byte-optimize-form form for-effect)) + ((not (symbolp fn)) + (byte-compile-warn "%s is a malformed function" (prin1-to-string fn)) + form) + ;; Support compiler macros as in cl.el. - ((and (fboundp 'compiler-macroexpand) - (symbolp (car-safe form)) - (get (car-safe form) 'cl-compiler-macro) - (not (eq form - (setq form (compiler-macroexpand form))))) + ((and (get fn 'cl-compiler-macro) + (not (eq form (setq form (compiler-macroexpand form))))) (byte-optimize-form form for-effect)) - ((not (symbolp fn)) - (or (eq 'mocklisp (car-safe fn)) ; ha! - (byte-compile-warn "%s is a malformed function" - (prin1-to-string fn))) - form) - - ((and for-effect (setq tmp (get fn 'side-effect-free)) + ((and for-effect + (setq tmp (byte-optimize-side-effect-free-p form)) (or byte-compile-delete-errors (eq tmp 'error-free) (progn @@ -1260,42 +1256,62 @@ list-length getf )) (side-effect-and-error-free-fns - '(arrayp atom + '(acons arrayp atom bigfloatp bignump bobp bolp buffer-end buffer-list buffer-size buffer-string bufferp car-safe case-table-p cdr-safe char-or-string-p char-table-p characterp commandp cons - consolep console-live-p consp + consolep console-live-p consp copy-tree current-buffer ;; XEmacs: extent functions, frame-live-p, various other stuff devicep device-live-p - eobp eolp eq eql equal eventp extentp + eobp eolp eq eql equal equalp eventp extentp extent-live-p fixnump floatingp floatp framep frame-live-p get-largest-window get-lru-window hash-table-p identity ignore integerp integer-or-marker-p interactive-p invocation-directory invocation-name - keymapp list listp + keymapp list list* listp make-marker mark mark-marker markerp memory-limit minibuffer-window ;; mouse-movement-p not in XEmacs natnump nlistp not null number-or-marker-p numberp one-window-p ;; overlayp not in XEmacs point point-marker point-min point-max processp - rationalp ratiop range-table-p realp + random-state-p rationalp ratiop range-table-p realp selected-window sequencep stringp subrp symbolp syntax-table-p user-full-name user-login-name user-original-login-name user-real-login-name user-real-uid user-uid vector vectorp - window-configuration-p window-live-p windowp - ;; Functions defined by cl - eql list* subst acons equalp random-state-p - copy-tree sublis - ))) + window-configuration-p window-live-p windowp))) (dolist (fn side-effect-free-fns) (put fn 'side-effect-free t)) (dolist (fn side-effect-and-error-free-fns) (put fn 'side-effect-free 'error-free))) +(dolist (function + '(adjoin assoc* count find intersection member* mismatch position + rassoc* remove* remove-duplicates search set-difference + set-exclusive-or stable-intersection stable-sort stable-union + sublis subsetp subst substitute tree-equal union)) + ;; These all throw errors, there's no point implementing an error-free + ;; version of the list. + (put function 'side-effect-free-if-keywords-are t)) + +(defun byte-optimize-side-effect-free-p (form) + (or (get (car-safe form) 'side-effect-free) + (and (get (car-safe form) 'side-effect-free-if-keywords-are) + (loop + for (key value) + on (nthcdr (get (car form) 'byte-compile-keyword-start) form) + by #'cddr + never (or (and (member* key + '(:test :test-not :key :if :if-not)) + (or (not (byte-compile-constp value)) + (not (and (consp value) + (symbolp (cadr value)) + (get (cadr value) + 'side-effect-free))))) + (not (keywordp key))))))) (defun byte-compile-splice-in-already-compiled-code (form) ;; form is (byte-code "..." [...] n)