[COMMIT] Be better about recognising side-effect-free forms, byte-optimize.el.

APPROVE COMMIT NOTE: This patch has been committed. # HG changeset patch # User Aidan Kehoe <kehoea(a)parhasard.net&gt; # Date 1304765120 -3600 # Node ID 5b08be74bb532a6dbdf03caf5f48ca3640e2cae0 # Parent 4813ff11c6e297815a02fc0601a3b01881f6f6a1 Be better about recognising side-effect-free forms, byte-optimize.el. 2011-05-07 Aidan Kehoe <kehoea(a)parhasard.net&gt; * 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). diff -r 4813ff11c6e2 -r 5b08be74bb53 lisp/ChangeLog --- 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(a)parhasard.net&gt; + + * 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(a)parhasard.net&gt; * cl-macs.el (most-positive-fixnum-on-32-bit-machines): diff -r 4813ff11c6e2 -r 5b08be74bb53 lisp/byte-optimize.el --- 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) -- “Apart from the nine-banded armadillo, man is the only natural host of Mycobacterium leprae, although it can be grown in the footpads of mice.” -- Kumar & Clark, Clinical Medicine, summarising improbable leprosy research _______________________________________________ XEmacs-Patches mailing list XEmacs-Patches(a)xemacs.org http://lists.xemacs.org/mailman/listinfo/xemacs-patches