diff options
Diffstat (limited to 'lisp/emacs-lisp/byte-opt.el')
| -rw-r--r-- | lisp/emacs-lisp/byte-opt.el | 162 |
1 files changed, 78 insertions, 84 deletions
diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index c9027fb663d..07e95e7e4cd 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -1,6 +1,6 @@ ;;; byte-opt.el --- the optimization passes of the emacs-lisp byte compiler -*- lexical-binding: t -*- -;; Copyright (C) 1991, 1994, 2000-2011 Free Software Foundation, Inc. +;; Copyright (C) 1991, 1994, 2000-2012 Free Software Foundation, Inc. ;; Author: Jamie Zawinski <jwz@lucid.com> ;; Hallvard Furuseth <hbf@ulrik.uio.no> @@ -183,7 +183,8 @@ ;;; Code: (require 'bytecomp) -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) +(require 'macroexp) (defun byte-compile-log-lap-1 (format &rest args) ;; Newer byte codes for stack-ref make the slot 0 non-nil again. @@ -248,8 +249,8 @@ (let* ((name (car form)) (localfn (cdr (assq name byte-compile-function-environment))) (fn (or localfn (and (fboundp name) (symbol-function name))))) - (when (and (consp fn) (eq (car fn) 'autoload)) - (load (nth 1 fn)) + (when (autoloadp fn) + (autoload-do-load fn) (setq fn (or (and (fboundp name) (symbol-function name)) (cdr (assq name byte-compile-function-environment))))) (pcase fn @@ -265,38 +266,30 @@ ;; (message "Inlining byte-code for %S!" name) ;; The byte-code will be really inlined in byte-compile-unfold-bcf. `(,fn ,@(cdr form))) - ((or (and `(lambda ,args . ,body) (let env nil)) - `(closure ,env ,args . ,body)) + ((or `(lambda . ,_) `(closure . ,_)) (if (not (or (eq fn localfn) ;From the same file => same mode. - (eq (not lexical-binding) (not env)))) ;Same mode. + (eq (car fn) ;Same mode. + (if lexical-binding 'closure 'lambda)))) ;; While byte-compile-unfold-bcf can inline dynbind byte-code into ;; letbind byte-code (or any other combination for that matter), we ;; can only inline dynbind source into dynbind source or letbind ;; source into letbind source. - ;; FIXME: we could of course byte-compile the inlined function - ;; first, and then inline its byte-code. - form - (let ((renv ())) - ;; Turn the function's closed vars (if any) into local let bindings. - (dolist (binding env) - (cond - ((consp binding) - ;; We check shadowing by the args, so that the `let' can be - ;; moved within the lambda, which can then be unfolded. - ;; FIXME: Some of those bindings might be unused in `body'. - (unless (memq (car binding) args) ;Shadowed. - (push `(,(car binding) ',(cdr binding)) renv))) - ((eq binding t)) - (t (push `(defvar ,binding) body)))) - (let ((newfn (byte-compile-preprocess - (if (null renv) - `(lambda ,args ,@body) - `(lambda ,args (let ,(nreverse renv) ,@body)))))) - (if (eq (car-safe newfn) 'function) - (byte-compile-unfold-lambda `(,(cadr newfn) ,@(cdr form))) - (byte-compile-log-warning - (format "Inlining closure %S failed" name)) - form))))) + (progn + ;; We can of course byte-compile the inlined function + ;; first, and then inline its byte-code. + (byte-compile name) + `(,(symbol-function name) ,@(cdr form))) + (let ((newfn (if (eq fn localfn) + ;; If `fn' is from the same file, it has already + ;; been preprocessed! + `(function ,fn) + (byte-compile-preprocess + (byte-compile--reify-function fn))))) + (if (eq (car-safe newfn) 'function) + (byte-compile-unfold-lambda `(,(cadr newfn) ,@(cdr form))) + (byte-compile-log-warning + (format "Inlining closure %S failed" name)) + form)))) (t ;; Give up on inlining. form)))) @@ -430,11 +423,9 @@ clause)) (cdr form)))) ((eq fn 'progn) - ;; as an extra added bonus, this simplifies (progn <x>) --> <x> + ;; As an extra added bonus, this simplifies (progn <x>) --> <x>. (if (cdr (cdr form)) - (progn - (setq tmp (byte-optimize-body (cdr form) for-effect)) - (if (cdr tmp) (cons 'progn tmp) (car tmp))) + (macroexp-progn (byte-optimize-body (cdr form) for-effect)) (byte-optimize-form (nth 1 form) for-effect))) ((eq fn 'prog1) (if (cdr (cdr form)) @@ -496,7 +487,7 @@ (prin1-to-string form)) nil) - ((memq fn '(defun defmacro function condition-case)) + ((memq fn '(function condition-case)) ;; These forms are compiled as constants or by breaking out ;; all the subexpressions and compiling them separately. form) @@ -573,10 +564,10 @@ (cons fn args))))))) (defun byte-optimize-all-constp (list) - "Non-nil if all elements of LIST satisfy `byte-compile-constp'." + "Non-nil if all elements of LIST satisfy `macroexp-const-p" (let ((constant t)) (while (and list constant) - (unless (byte-compile-constp (car list)) + (unless (macroexp-const-p (car list)) (setq constant nil)) (setq list (cdr list))) constant)) @@ -595,10 +586,11 @@ (let (opt new) (if (and (consp form) (symbolp (car form)) - (or (and for-effect - ;; we don't have any of these yet, but we might. - (setq opt (get (car form) 'byte-for-effect-optimizer))) - (setq opt (get (car form) 'byte-optimizer))) + (or ;; (and for-effect + ;; ;; We don't have any of these yet, but we might. + ;; (setq opt (get (car form) + ;; 'byte-for-effect-optimizer))) + (setq opt (function-get (car form) 'byte-optimizer))) (not (eq form (setq new (funcall opt form))))) (progn ;; (if (equal form new) (error "bogus optimizer -- %s" opt)) @@ -639,10 +631,10 @@ (while (eq (car-safe form) 'progn) (setq form (car (last (cdr form))))) (cond ((consp form) - (case (car form) - (quote (cadr form)) + (pcase (car form) + (`quote (cadr form)) ;; Can't use recursion in a defsubst. - ;; (progn (byte-compile-trueconstp (car (last (cdr form))))) + ;; (`progn (byte-compile-trueconstp (car (last (cdr form))))) )) ((not (symbolp form))) ((eq form t)) @@ -653,10 +645,10 @@ (while (eq (car-safe form) 'progn) (setq form (car (last (cdr form))))) (cond ((consp form) - (case (car form) - (quote (null (cadr form))) + (pcase (car form) + (`quote (null (cadr form))) ;; Can't use recursion in a defsubst. - ;; (progn (byte-compile-nilconstp (car (last (cdr form))))) + ;; (`progn (byte-compile-nilconstp (car (last (cdr form))))) )) ((not (symbolp form)) nil) ((null form)))) @@ -866,8 +858,8 @@ (defun byte-optimize-binary-predicate (form) - (if (byte-compile-constp (nth 1 form)) - (if (byte-compile-constp (nth 2 form)) + (if (macroexp-const-p (nth 1 form)) + (if (macroexp-const-p (nth 2 form)) (condition-case () (list 'quote (eval form)) (error form)) @@ -879,7 +871,7 @@ (let ((ok t) (rest (cdr form))) (while (and rest ok) - (setq ok (byte-compile-constp (car rest)) + (setq ok (macroexp-const-p (car rest)) rest (cdr rest))) (if ok (condition-case () @@ -945,7 +937,7 @@ (defun byte-optimize-quote (form) (if (or (consp (nth 1 form)) (and (symbolp (nth 1 form)) - (not (byte-compile-const-symbol-p form)))) + (not (macroexp--const-symbol-p form)))) form (nth 1 form))) @@ -1155,16 +1147,6 @@ ;; optimize string-as-unibyte, string-as-multibyte, string-make-unibyte, ;; string-make-multibyte for constant args. -(put 'featurep 'byte-optimizer 'byte-optimize-featurep) -(defun byte-optimize-featurep (form) - ;; Emacs-21's byte-code doesn't run under XEmacs or SXEmacs anyway, so we - ;; can safely optimize away this test. - (if (member (cdr-safe form) '(((quote xemacs)) ((quote sxemacs)))) - nil - (if (member (cdr-safe form) '(((quote emacs)))) - t - form))) - (put 'set 'byte-optimizer 'byte-optimize-set) (defun byte-optimize-set (form) (let ((var (car-safe (cdr-safe form)))) @@ -1205,8 +1187,8 @@ boundp buffer-file-name buffer-local-variables buffer-modified-p buffer-substring byte-code-function-p capitalize car-less-than-car car cdr ceiling char-after char-before - char-equal char-to-string char-width - compare-strings concat coordinates-in-window-p + char-equal char-to-string char-width compare-strings + compare-window-configurations concat coordinates-in-window-p copy-alist copy-sequence copy-marker cos count-lines decode-char decode-time default-boundp default-value documentation downcase @@ -1214,17 +1196,18 @@ fboundp fceiling featurep ffloor file-directory-p file-exists-p file-locked-p file-name-absolute-p file-newer-than-file-p file-readable-p file-symlink-p file-writable-p - float float-time floor format format-time-string frame-visible-p - fround ftruncate + float float-time floor format format-time-string frame-first-window + frame-root-window frame-selected-window + frame-visible-p fround ftruncate get gethash get-buffer get-buffer-window getenv get-file-buffer hash-table-count int-to-string intern-soft keymap-parent length local-variable-if-set-p local-variable-p log log10 logand logb logior lognot logxor lsh langinfo - make-list make-string make-symbol - marker-buffer max member memq min mod multibyte-char-to-unibyte - next-window nth nthcdr number-to-string + make-list make-string make-symbol marker-buffer max member memq min + minibuffer-selected-window minibuffer-window + mod multibyte-char-to-unibyte next-window nth nthcdr number-to-string parse-colon-path plist-get plist-member prefix-numeric-value previous-window prin1-to-string propertize degrees-to-radians @@ -1237,11 +1220,21 @@ string-to-multibyte tan truncate unibyte-char-to-multibyte upcase user-full-name - user-login-name user-original-login-name user-variable-p + user-login-name user-original-login-name custom-variable-p vconcat - window-buffer window-dedicated-p window-edges window-height - window-hscroll window-minibuffer-p window-width - zerop)) + window-absolute-pixel-edges window-at window-body-height + window-body-width window-buffer window-dedicated-p window-display-table + window-combination-limit window-edges window-frame window-fringes + window-height window-hscroll window-inside-edges + window-inside-absolute-pixel-edges window-inside-pixel-edges + window-left-child window-left-column window-margins window-minibuffer-p + window-next-buffers window-next-sibling window-new-normal + window-new-total window-normal-size window-parameter window-parameters + window-parent window-pixel-edges window-point window-prev-buffers + window-prev-sibling window-redisplay-end-trigger window-scroll-bars + window-start window-text-height window-top-child window-top-line + window-total-height window-total-width window-use-time window-vscroll + window-width zerop)) (side-effect-and-error-free-fns '(arrayp atom bobp bolp bool-vector-p @@ -1274,7 +1267,8 @@ this-single-command-raw-keys user-real-login-name user-real-uid user-uid vector vectorp visible-frame-list - wholenump window-configuration-p window-live-p windowp))) + wholenump window-configuration-p window-live-p + window-valid-p windowp))) (while side-effect-free-fns (put (car side-effect-free-fns) 'side-effect-free t) (setq side-effect-free-fns (cdr side-effect-free-fns))) @@ -1373,7 +1367,7 @@ ;; This uses dynamic-scope magic. offset (disassemble-offset bytes)) (let ((opcode (aref byte-code-vector bytedecomp-op))) - (assert opcode) + (cl-assert opcode) (setq bytedecomp-op opcode)) (cond ((memq bytedecomp-op byte-goto-ops) ;; It's a pc. @@ -1574,7 +1568,7 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." ;; stack-set-X+1 stack-ref-X --> dup stack-set-X+2 ;; but this is a very minor gain, since dup is stack-ref-0, ;; i.e. it's only better if X>5, and even then it comes - ;; at the cost cost of an extra stack slot. Let's not bother. + ;; at the cost of an extra stack slot. Let's not bother. ((and (eq 'byte-varref (car lap2)) (eq (cdr lap1) (cdr lap2)) (memq (car lap1) '(byte-varset byte-varbind))) @@ -1582,13 +1576,13 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." (not (eq (car lap0) 'byte-constant))) nil (setq keep-going t) - (if (memq (car lap0) '(byte-constant byte-dup)) - (progn - (setq tmp (if (or (not tmp) - (byte-compile-const-symbol-p - (car (cdr lap0)))) - (cdr lap0) - (byte-compile-get-constant t))) + (if (memq (car lap0) '(byte-constant byte-dup)) + (progn + (setq tmp (if (or (not tmp) + (macroexp--const-symbol-p + (car (cdr lap0)))) + (cdr lap0) + (byte-compile-get-constant t))) (byte-compile-log-lap " %s %s %s\t-->\t%s %s %s" lap0 lap1 lap2 lap0 lap1 (cons (car lap0) tmp)) @@ -1616,7 +1610,7 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." (byte-compile-log-lap " dup %s discard\t-->\t%s" lap1 lap1) (setq keep-going t rest (cdr rest)) - (if (eq 'byte-stack-set (car lap1)) (decf (cdr lap1))) + (if (eq 'byte-stack-set (car lap1)) (cl-decf (cdr lap1))) (setq lap (delq lap0 (delq lap2 lap)))) ;; ;; not goto-X-if-nil --> goto-X-if-non-nil |