Mercurial > hg > xemacs-beta
comparison lisp/byte-optimize.el @ 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 | ac37a5f7e5be |
| children | ae2fdb1fd9e0 |
comparison
equal
deleted
inserted
replaced
| 5501:4813ff11c6e2 | 5502:5b08be74bb53 |
|---|---|
| 522 ((not (eq form | 522 ((not (eq form |
| 523 (setq form (macroexpand form | 523 (setq form (macroexpand form |
| 524 byte-compile-macro-environment)))) | 524 byte-compile-macro-environment)))) |
| 525 (byte-optimize-form form for-effect)) | 525 (byte-optimize-form form for-effect)) |
| 526 | 526 |
| 527 ((not (symbolp fn)) | |
| 528 (byte-compile-warn "%s is a malformed function" (prin1-to-string fn)) | |
| 529 form) | |
| 530 | |
| 527 ;; Support compiler macros as in cl.el. | 531 ;; Support compiler macros as in cl.el. |
| 528 ((and (fboundp 'compiler-macroexpand) | 532 ((and (get fn 'cl-compiler-macro) |
| 529 (symbolp (car-safe form)) | 533 (not (eq form (setq form (compiler-macroexpand form))))) |
| 530 (get (car-safe form) 'cl-compiler-macro) | |
| 531 (not (eq form | |
| 532 (setq form (compiler-macroexpand form))))) | |
| 533 (byte-optimize-form form for-effect)) | 534 (byte-optimize-form form for-effect)) |
| 534 | 535 |
| 535 ((not (symbolp fn)) | 536 ((and for-effect |
| 536 (or (eq 'mocklisp (car-safe fn)) ; ha! | 537 (setq tmp (byte-optimize-side-effect-free-p form)) |
| 537 (byte-compile-warn "%s is a malformed function" | |
| 538 (prin1-to-string fn))) | |
| 539 form) | |
| 540 | |
| 541 ((and for-effect (setq tmp (get fn 'side-effect-free)) | |
| 542 (or byte-compile-delete-errors | 538 (or byte-compile-delete-errors |
| 543 (eq tmp 'error-free) | 539 (eq tmp 'error-free) |
| 544 (progn | 540 (progn |
| 545 (byte-compile-warn "%s called for effect" | 541 (byte-compile-warn "%s called for effect" |
| 546 (prin1-to-string form)) | 542 (prin1-to-string form)) |
| 1258 pairlis gcd lcm | 1254 pairlis gcd lcm |
| 1259 isqrt floor* ceiling* truncate* round* mod* rem* subseq | 1255 isqrt floor* ceiling* truncate* round* mod* rem* subseq |
| 1260 list-length getf | 1256 list-length getf |
| 1261 )) | 1257 )) |
| 1262 (side-effect-and-error-free-fns | 1258 (side-effect-and-error-free-fns |
| 1263 '(arrayp atom | 1259 '(acons arrayp atom |
| 1264 bigfloatp bignump bobp bolp buffer-end buffer-list buffer-size | 1260 bigfloatp bignump bobp bolp buffer-end buffer-list buffer-size |
| 1265 buffer-string bufferp | 1261 buffer-string bufferp |
| 1266 car-safe case-table-p cdr-safe char-or-string-p char-table-p | 1262 car-safe case-table-p cdr-safe char-or-string-p char-table-p |
| 1267 characterp commandp cons | 1263 characterp commandp cons |
| 1268 consolep console-live-p consp | 1264 consolep console-live-p consp copy-tree |
| 1269 current-buffer | 1265 current-buffer |
| 1270 ;; XEmacs: extent functions, frame-live-p, various other stuff | 1266 ;; XEmacs: extent functions, frame-live-p, various other stuff |
| 1271 devicep device-live-p | 1267 devicep device-live-p |
| 1272 eobp eolp eq eql equal eventp extentp | 1268 eobp eolp eq eql equal equalp eventp extentp |
| 1273 extent-live-p fixnump floatingp floatp framep frame-live-p | 1269 extent-live-p fixnump floatingp floatp framep frame-live-p |
| 1274 get-largest-window get-lru-window | 1270 get-largest-window get-lru-window |
| 1275 hash-table-p | 1271 hash-table-p |
| 1276 identity ignore integerp integer-or-marker-p interactive-p | 1272 identity ignore integerp integer-or-marker-p interactive-p |
| 1277 invocation-directory invocation-name | 1273 invocation-directory invocation-name |
| 1278 keymapp list listp | 1274 keymapp list list* listp |
| 1279 make-marker mark mark-marker markerp memory-limit minibuffer-window | 1275 make-marker mark mark-marker markerp memory-limit minibuffer-window |
| 1280 ;; mouse-movement-p not in XEmacs | 1276 ;; mouse-movement-p not in XEmacs |
| 1281 natnump nlistp not null number-or-marker-p numberp | 1277 natnump nlistp not null number-or-marker-p numberp |
| 1282 one-window-p ;; overlayp not in XEmacs | 1278 one-window-p ;; overlayp not in XEmacs |
| 1283 point point-marker point-min point-max processp | 1279 point point-marker point-min point-max processp |
| 1284 rationalp ratiop range-table-p realp | 1280 random-state-p rationalp ratiop range-table-p realp |
| 1285 selected-window sequencep stringp subrp symbolp syntax-table-p | 1281 selected-window sequencep stringp subrp symbolp syntax-table-p |
| 1286 user-full-name user-login-name user-original-login-name | 1282 user-full-name user-login-name user-original-login-name |
| 1287 user-real-login-name user-real-uid user-uid | 1283 user-real-login-name user-real-uid user-uid |
| 1288 vector vectorp | 1284 vector vectorp |
| 1289 window-configuration-p window-live-p windowp | 1285 window-configuration-p window-live-p windowp))) |
| 1290 ;; Functions defined by cl | |
| 1291 eql list* subst acons equalp random-state-p | |
| 1292 copy-tree sublis | |
| 1293 ))) | |
| 1294 (dolist (fn side-effect-free-fns) | 1286 (dolist (fn side-effect-free-fns) |
| 1295 (put fn 'side-effect-free t)) | 1287 (put fn 'side-effect-free t)) |
| 1296 (dolist (fn side-effect-and-error-free-fns) | 1288 (dolist (fn side-effect-and-error-free-fns) |
| 1297 (put fn 'side-effect-free 'error-free))) | 1289 (put fn 'side-effect-free 'error-free))) |
| 1298 | 1290 |
| 1291 (dolist (function | |
| 1292 '(adjoin assoc* count find intersection member* mismatch position | |
| 1293 rassoc* remove* remove-duplicates search set-difference | |
| 1294 set-exclusive-or stable-intersection stable-sort stable-union | |
| 1295 sublis subsetp subst substitute tree-equal union)) | |
| 1296 ;; These all throw errors, there's no point implementing an error-free | |
| 1297 ;; version of the list. | |
| 1298 (put function 'side-effect-free-if-keywords-are t)) | |
| 1299 | |
| 1300 (defun byte-optimize-side-effect-free-p (form) | |
| 1301 (or (get (car-safe form) 'side-effect-free) | |
| 1302 (and (get (car-safe form) 'side-effect-free-if-keywords-are) | |
| 1303 (loop | |
| 1304 for (key value) | |
| 1305 on (nthcdr (get (car form) 'byte-compile-keyword-start) form) | |
| 1306 by #'cddr | |
| 1307 never (or (and (member* key | |
| 1308 '(:test :test-not :key :if :if-not)) | |
| 1309 (or (not (byte-compile-constp value)) | |
| 1310 (not (and (consp value) | |
| 1311 (symbolp (cadr value)) | |
| 1312 (get (cadr value) | |
| 1313 'side-effect-free))))) | |
| 1314 (not (keywordp key))))))) | |
| 1299 | 1315 |
| 1300 (defun byte-compile-splice-in-already-compiled-code (form) | 1316 (defun byte-compile-splice-in-already-compiled-code (form) |
| 1301 ;; form is (byte-code "..." [...] n) | 1317 ;; form is (byte-code "..." [...] n) |
| 1302 (if (not (memq byte-optimize '(t byte))) | 1318 (if (not (memq byte-optimize '(t byte))) |
| 1303 (byte-compile-normal-call form) | 1319 (byte-compile-normal-call form) |