diff options
Diffstat (limited to 'lisp/emacs-lisp/byte-opt.el')
| -rw-r--r-- | lisp/emacs-lisp/byte-opt.el | 506 |
1 files changed, 255 insertions, 251 deletions
diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index abbe2a2e63f..6475f69eded 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -225,6 +225,14 @@ (byte-compile-log-lap-1 ,format-string ,@args))) +(defvar byte-optimize--lexvars nil + "Lexical variables in scope, in reverse order of declaration. +Each element is on the form (NAME KEEP [VALUE]), where: + NAME is the variable name, + KEEP is a boolean indicating whether the binding must be retained, + VALUE, if present, is a substitutable expression. +Earlier variables shadow later ones with the same name.") + ;;; byte-compile optimizers to support inlining (put 'inline 'byte-optimizer #'byte-optimize-inline-handler) @@ -266,124 +274,42 @@ ((pred byte-code-function-p) ;; (message "Inlining byte-code for %S!" name) ;; The byte-code will be really inlined in byte-compile-unfold-bcf. + (byte-compile--check-arity-bytecode form fn) `(,fn ,@(cdr form))) ((or `(lambda . ,_) `(closure . ,_)) - (if (not (or (eq fn localfn) ;From the same file => 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. - (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) - ;; Try and process it "in its original environment". - (let ((byte-compile-bound-variables nil)) - (byte-compile-preprocess - (byte-compile--reify-function fn)))))) - (if (eq (car-safe newfn) 'function) - (byte-compile-unfold-lambda `(,(cadr newfn) ,@(cdr form))) - ;; This can happen because of macroexp-warn-and-return &co. - (byte-compile-warn - "Inlining closure %S failed" name) - form)))) + ;; 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. + ;; When the function comes from another file, we byte-compile + ;; the inlined function first, and then inline its byte-code. + ;; This also has the advantage that the final code does not + ;; depend on the order of compilation of ELisp files, making + ;; the build more reproducible. + (if (eq fn localfn) + ;; From the same file => same mode. + (macroexp--unfold-lambda `(,fn ,@(cdr form))) + ;; Since we are called from inside the optimiser, we need to make + ;; sure not to propagate lexvar values. + (let ((byte-optimize--lexvars nil) + ;; Silence all compilation warnings: the useful ones should + ;; be displayed when the function's source file will be + ;; compiled anyway, but more importantly we would otherwise + ;; emit spurious warnings here because we don't have the full + ;; context, such as `declare-functions' placed earlier in the + ;; source file's code or `with-suppressed-warnings' that + ;; surrounded the `defsubst'. + (byte-compile-warnings nil)) + (byte-compile name)) + (let ((bc (symbol-function name))) + (byte-compile--check-arity-bytecode form bc) + `(,bc ,@(cdr form))))) (_ ;; Give up on inlining. form)))) - -;; ((lambda ...) ...) -(defun byte-compile-unfold-lambda (form &optional name) - ;; In lexical-binding mode, let and functions don't bind vars in the same way - ;; (let obey special-variable-p, but functions don't). But luckily, this - ;; doesn't matter here, because function's behavior is underspecified so it - ;; can safely be turned into a `let', even though the reverse is not true. - (or name (setq name "anonymous lambda")) - (let* ((lambda (car form)) - (values (cdr form)) - (arglist (nth 1 lambda)) - (body (cdr (cdr lambda))) - optionalp restp - bindings) - (if (and (stringp (car body)) (cdr body)) - (setq body (cdr body))) - (if (and (consp (car body)) (eq 'interactive (car (car body)))) - (setq body (cdr body))) - ;; FIXME: The checks below do not belong in an optimization phase. - (while arglist - (cond ((eq (car arglist) '&optional) - ;; ok, I'll let this slide because funcall_lambda() does... - ;; (if optionalp (error "multiple &optional keywords in %s" name)) - (if restp (error "&optional found after &rest in %s" name)) - (if (null (cdr arglist)) - (error "nothing after &optional in %s" name)) - (setq optionalp t)) - ((eq (car arglist) '&rest) - ;; ...but it is by no stretch of the imagination a reasonable - ;; thing that funcall_lambda() allows (&rest x y) and - ;; (&rest x &optional y) in arglists. - (if (null (cdr arglist)) - (error "nothing after &rest in %s" name)) - (if (cdr (cdr arglist)) - (error "multiple vars after &rest in %s" name)) - (setq restp t)) - (restp - (setq bindings (cons (list (car arglist) - (and values (cons 'list values))) - bindings) - values nil)) - ((and (not optionalp) (null values)) - (byte-compile-warn "attempt to open-code `%s' with too few arguments" name) - (setq arglist nil values 'too-few)) - (t - (setq bindings (cons (list (car arglist) (car values)) - bindings) - values (cdr values)))) - (setq arglist (cdr arglist))) - (if values - (progn - (or (eq values 'too-few) - (byte-compile-warn - "attempt to open-code `%s' with too many arguments" name)) - form) - - ;; The following leads to infinite recursion when loading a - ;; file containing `(defsubst f () (f))', and then trying to - ;; byte-compile that file. - ;(setq body (mapcar 'byte-optimize-form body))) - - (let ((newform - (if bindings - (cons 'let (cons (nreverse bindings) body)) - (cons 'progn body)))) - (byte-compile-log " %s\t==>\t%s" form newform) - newform)))) - ;;; implementing source-level optimizers -(defconst byte-optimize-enable-variable-constprop t - "If non-nil, enable constant propagation through local variables.") - -(defconst byte-optimize-warn-eliminated-variable nil - "Whether to warn when a variable is optimised away entirely. -This does usually not indicate a problem and makes the compiler -very chatty, but can be useful for debugging.") - -(defvar byte-optimize--lexvars nil - "Lexical variables in scope, in reverse order of declaration. -Each element is on the form (NAME KEEP [VALUE]), where: - NAME is the variable name, - KEEP is a boolean indicating whether the binding must be retained, - VALUE, if present, is a substitutable expression. -Earlier variables shadow later ones with the same name.") - (defvar byte-optimize--vars-outside-condition nil "Alist of variables lexically bound outside conditionally executed code. Variables here are sensitive to mutation inside the conditional code, @@ -412,10 +338,44 @@ Same format as `byte-optimize--lexvars', with shared structure and contents.") (numberp expr) (stringp expr) (and (consp expr) - (eq (car expr) 'quote) + (memq (car expr) '(quote function)) (symbolp (cadr expr))) (keywordp expr))) +(defmacro byte-optimize--pcase (exp &rest cases) + ;; When we do + ;; + ;; (pcase EXP + ;; (`(if ,exp ,then ,else) (DO-TEST)) + ;; (`(plus ,e2 ,e2) (DO-ADD)) + ;; (`(times ,e2 ,e2) (DO-MULT)) + ;; ...) + ;; + ;; we usually don't want to fall back to the default case if + ;; the value of EXP is of a form like `(if E1 E2)' or `(plus E1)' + ;; or `(times E1 E2 E3)', instead we either want to signal an error + ;; that EXP has an unexpected shape, or we want to carry on as if + ;; it had the right shape (ignore the extra data and pretend the missing + ;; data is nil) because it should simply never happen. + ;; + ;; The macro below implements the second option by rewriting patterns + ;; like `(if ,exp ,then ,else)' + ;; to `(if . (or `(,exp ,then ,else) pcase--dontcare))'. + ;; + ;; The resulting macroexpansion is also significantly cleaner/smaller/faster. + (declare (indent 1) (debug pcase)) + `(pcase ,exp + . ,(mapcar (lambda (case) + `(,(pcase (car case) + ((and `(,'\` (,_ . (,'\, ,_))) pat) pat) + (`(,'\` (,head . ,tail)) + (list '\` + (cons head + (list '\, `(or ,(list '\` tail) pcase--dontcare))))) + (pat pat)) + . ,(cdr case))) + cases))) + (defun byte-optimize-form-code-walker (form for-effect) ;; ;; For normal function calls, We can just mapcar the optimizer the cdr. But @@ -428,28 +388,33 @@ Same format as `byte-optimize--lexvars', with shared structure and contents.") ;; have no place in an optimizer: the corresponding tests should be ;; performed in `macroexpand-all', or in `cconv', or in `bytecomp'. (let ((fn (car-safe form))) - (pcase form + (byte-optimize--pcase form ((pred (not consp)) (cond ((and for-effect (or byte-compile-delete-errors (not (symbolp form)) - (eq form t))) + (eq form t) + (keywordp form))) nil) ((symbolp form) (let ((lexvar (assq form byte-optimize--lexvars))) - (if (cddr lexvar) ; Value available? - (if (assq form byte-optimize--vars-outside-loop) - ;; Cannot substitute; mark for retention to avoid the - ;; variable being eliminated. - (progn - (setcar (cdr lexvar) t) - form) - (caddr lexvar)) ; variable value to use - form))) + (cond + ((not lexvar) form) + (for-effect nil) + ((cddr lexvar) ; Value available? + (if (assq form byte-optimize--vars-outside-loop) + ;; Cannot substitute; mark for retention to avoid the + ;; variable being eliminated. + (progn + (setcar (cdr lexvar) t) + form) + ;; variable value to use + (caddr lexvar))) + (t form)))) (t form))) (`(quote . ,v) - (if (cdr v) + (if (or (not v) (cdr v)) (byte-compile-warn "malformed quote form: `%s'" (prin1-to-string form))) ;; Map (quote nil) to nil to simplify optimizer logic. @@ -458,31 +423,34 @@ Same format as `byte-optimize--lexvars', with shared structure and contents.") (not for-effect) form)) (`(,(or 'let 'let*) . ,rest) - (cons fn (byte-optimize-let-form fn rest for-effect))) + (cons fn (byte-optimize-let-form fn rest for-effect))) (`(cond . ,clauses) ;; The condition in the first clause is always executed, but ;; right now we treat all of them as conditional for simplicity. (let ((byte-optimize--vars-outside-condition byte-optimize--lexvars)) (cons fn (mapcar (lambda (clause) - (if (consp clause) - (cons - (byte-optimize-form (car clause) nil) - (byte-optimize-body (cdr clause) for-effect)) - (byte-compile-warn "malformed cond form: `%s'" - (prin1-to-string clause)) - clause)) - clauses)))) + (if (consp clause) + (cons + (byte-optimize-form (car clause) nil) + (byte-optimize-body (cdr clause) for-effect)) + (byte-compile-warn "malformed cond form: `%s'" + (prin1-to-string clause)) + clause)) + clauses)))) (`(progn . ,exps) ;; As an extra added bonus, this simplifies (progn <x>) --> <x>. (if (cdr exps) (macroexp-progn (byte-optimize-body exps for-effect)) (byte-optimize-form (car exps) for-effect))) - (`(prog1 . ,(or `(,exp . ,exps) pcase--dontcare)) - (if exps - `(prog1 ,(byte-optimize-form exp for-effect) - . ,(byte-optimize-body exps t)) - (byte-optimize-form exp for-effect))) + (`(prog1 ,exp . ,exps) + (let ((exp-opt (byte-optimize-form exp for-effect))) + (if exps + (let ((exps-opt (byte-optimize-body exps t))) + (if (macroexp-const-p exp-opt) + `(progn ,@exps-opt ,exp-opt) + `(prog1 ,exp-opt ,@exps-opt))) + exp-opt))) (`(,(or `save-excursion `save-restriction `save-current-buffer) . ,exps) ;; Those subrs which have an implicit progn; it's not quite good @@ -492,19 +460,23 @@ Same format as `byte-optimize--lexvars', with shared structure and contents.") (cons fn (byte-optimize-body exps for-effect))) (`(if ,test ,then . ,else) + ;; FIXME: We are conservative here: any variable changed in the + ;; THEN branch will be barred from substitution in the ELSE + ;; branch, despite the branches being mutually exclusive. + ;; The test is always executed. (let* ((test-opt (byte-optimize-form test nil)) - ;; The THEN and ELSE branches are executed conditionally. - ;; - ;; FIXME: We are conservative here: any variable changed in the - ;; THEN branch will be barred from substitution in the ELSE - ;; branch, despite the branches being mutually exclusive. - (byte-optimize--vars-outside-condition byte-optimize--lexvars) - (then-opt (byte-optimize-form then for-effect)) - (else-opt (byte-optimize-body else for-effect))) + (const (macroexp-const-p test-opt)) + ;; The branches are traversed unconditionally when possible. + (byte-optimize--vars-outside-condition + (if const + byte-optimize--vars-outside-condition + byte-optimize--lexvars)) + ;; Avoid traversing dead branches. + (then-opt (and test-opt (byte-optimize-form then for-effect))) + (else-opt (and (not (and test-opt const)) + (byte-optimize-body else for-effect)))) `(if ,test-opt ,then-opt . ,else-opt))) - (`(if . ,_) - (byte-compile-warn "too few arguments for `if'")) (`(,(or 'and 'or) . ,exps) ; Remember, and/or are control structures. ;; FIXME: We have to traverse the expressions in left-to-right @@ -542,8 +514,6 @@ Same format as `byte-optimize--lexvars', with shared structure and contents.") (body (byte-optimize-body exps t))) `(while ,condition . ,body))) - (`(while . ,_) - (byte-compile-warn "too few arguments for `while'")) (`(interactive . ,_) (byte-compile-warn "misplaced interactive spec: `%s'" @@ -555,13 +525,19 @@ Same format as `byte-optimize--lexvars', with shared structure and contents.") ;; all the subexpressions and compiling them separately. form) - (`(condition-case . ,(or `(,var ,exp . ,clauses) pcase--dontcare)) + (`(condition-case ,var ,exp . ,clauses) (let ((byte-optimize--vars-outside-condition byte-optimize--lexvars)) - `(condition-case ,var ;Not evaluated. + `(condition-case ,var ;Not evaluated. ,(byte-optimize-form exp for-effect) ,@(mapcar (lambda (clause) - `(,(car clause) - ,@(byte-optimize-body (cdr clause) for-effect))) + (let ((byte-optimize--lexvars + (and lexical-binding + (if var + (cons (list var t) + byte-optimize--lexvars) + byte-optimize--lexvars)))) + (cons (car clause) + (byte-optimize-body (cdr clause) for-effect)))) clauses)))) (`(unwind-protect ,exp . ,exps) @@ -581,7 +557,7 @@ Same format as `byte-optimize--lexvars', with shared structure and contents.") `(unwind-protect ,bodyform . ,(byte-optimize-body exps t)))))) - (`(catch . ,(or `(,tag . ,exps) pcase--dontcare)) + (`(catch ,tag . ,exps) (let ((byte-optimize--vars-outside-condition byte-optimize--lexvars)) `(catch ,(byte-optimize-form tag nil) . ,(byte-optimize-body exps for-effect)))) @@ -591,7 +567,7 @@ Same format as `byte-optimize--lexvars', with shared structure and contents.") ;; computed for effect. We want to avoid the warnings ;; that might occur if they were treated that way. ;; However, don't actually bother calling `ignore'. - `(prog1 nil . ,(mapcar #'byte-optimize-form exps))) + `(progn ,@(mapcar #'byte-optimize-form exps) nil)) ;; Needed as long as we run byte-optimize-form after cconv. (`(internal-make-closure . ,_) @@ -604,7 +580,7 @@ Same format as `byte-optimize--lexvars', with shared structure and contents.") form) (`((lambda . ,_) . ,_) - (let ((newform (byte-compile-unfold-lambda form))) + (let ((newform (macroexp--unfold-lambda form))) (if (eq newform form) ;; Some error occurred, avoid infinite recursion. form @@ -625,24 +601,20 @@ Same format as `byte-optimize--lexvars', with shared structure and contents.") (lexvar (assq var byte-optimize--lexvars)) (value (byte-optimize-form expr nil))) (when lexvar - ;; If it's bound outside conditional, invalidate. - (if (assq var byte-optimize--vars-outside-condition) - ;; We are in conditional code and the variable was - ;; bound outside: cancel substitutions. - (setcdr (cdr lexvar) nil) - ;; Set a new value (if substitutable). - (setcdr (cdr lexvar) - (and (byte-optimize--substitutable-p value) - (list value)))) - (setcar (cdr lexvar) t)) ; Mark variable to be kept. + (setcar (cdr lexvar) t) ; Mark variable to be kept. + (setcdr (cdr lexvar) nil)) ; Inhibit further substitution. + (push var var-expr-list) (push value var-expr-list)) (setq args (cddr args))) (cons fn (nreverse var-expr-list)))) - (`(defvar ,(and (pred symbolp) name) . ,_) - (push name byte-optimize--dynamic-vars) - form) + (`(defvar ,(and (pred symbolp) name) . ,rest) + (let ((optimized-rest (and rest + (cons (byte-optimize-form (car rest) nil) + (cdr rest))))) + (push name byte-optimize--dynamic-vars) + `(defvar ,name . ,optimized-rest))) (`(,(pred byte-code-function-p) . ,exps) (cons fn (mapcar #'byte-optimize-form exps))) @@ -674,76 +646,66 @@ Same format as `byte-optimize--lexvars', with shared structure and contents.") (byte-optimize-constant-args form) form)))))) -(defun byte-optimize-form (form &optional for-effect) +(defun byte-optimize-one-form (form &optional for-effect) "The source-level pass of the optimizer." - ;; - ;; First, optimize all sub-forms of this one. - (setq form (byte-optimize-form-code-walker form for-effect)) - ;; - ;; after optimizing all subforms, optimize this form until it doesn't - ;; optimize any further. This means that some forms will be passed through - ;; the optimizer many times, but that's necessary to make the for-effect - ;; processing do as much as possible. - ;; - (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 (function-get (car form) 'byte-optimizer))) - (not (eq form (setq new (funcall opt form))))) - (progn -;; (if (equal form new) (error "bogus optimizer -- %s" opt)) - (byte-compile-log " %s\t==>\t%s" form new) - (setq new (byte-optimize-form new for-effect)) - new) - form))) + ;; Make optimiser aware of lexical arguments. + (let ((byte-optimize--lexvars + (mapcar (lambda (v) (list (car v) t)) + byte-compile--lexical-environment))) + (byte-optimize-form form for-effect))) + +(defun byte-optimize-form (form &optional for-effect) + (while + (progn + ;; First, optimize all sub-forms of this one. + (setq form (byte-optimize-form-code-walker form for-effect)) + + ;; If a form-specific optimiser is available, run it and start over + ;; until a fixpoint has been reached. + (and (consp form) + (symbolp (car form)) + (let ((opt (function-get (car form) 'byte-optimizer))) + (and opt + (let ((old form) + (new (funcall opt form))) + (byte-compile-log " %s\t==>\t%s" old new) + (setq form new) + (not (eq new old)))))))) + form) (defun byte-optimize-let-form (head form for-effect) ;; Recursively enter the optimizer for the bindings and body ;; of a let or let*. This for depth-firstness: forms that ;; are more deeply nested are optimized first. - (if (and lexical-binding byte-optimize-enable-variable-constprop) + (if lexical-binding (let* ((byte-optimize--lexvars byte-optimize--lexvars) (new-lexvars nil) (let-vars nil)) (dolist (binding (car form)) - (let (name expr) - (cond ((consp binding) - (setq name (car binding)) - (unless (symbolp name) - (byte-compile-warn "let-bind nonvariable: `%S'" name)) - (setq expr (byte-optimize-form (cadr binding) nil))) - ((symbolp binding) - (setq name binding)) - (t (byte-compile-warn "malformed let binding: `%S'" binding))) - (let* ( - (value (and (byte-optimize--substitutable-p expr) - (list expr))) - (lexical (not (or (and (symbolp name) - (special-variable-p name)) - (memq name byte-compile-bound-variables) - (memq name byte-optimize--dynamic-vars)))) - (lexinfo (and lexical (cons name (cons nil value))))) - (push (cons name (cons expr (cdr lexinfo))) let-vars) - (when lexinfo - (push lexinfo (if (eq head 'let*) - byte-optimize--lexvars - new-lexvars)))))) + (let* ((name (car binding)) + (expr (byte-optimize-form (cadr binding) nil)) + (value (and (byte-optimize--substitutable-p expr) + (list expr))) + (lexical (not (or (special-variable-p name) + (memq name byte-compile-bound-variables) + (memq name byte-optimize--dynamic-vars)))) + (lexinfo (and lexical (cons name (cons nil value))))) + (push (cons name (cons expr (cdr lexinfo))) let-vars) + (when lexinfo + (push lexinfo (if (eq head 'let*) + byte-optimize--lexvars + new-lexvars))))) (setq byte-optimize--lexvars (append new-lexvars byte-optimize--lexvars)) ;; Walk the body expressions, which may mutate some of the records, ;; and generate new bindings that exclude unused variables. - (let* ((opt-body (byte-optimize-body (cdr form) for-effect)) + (let* ((byte-optimize--dynamic-vars byte-optimize--dynamic-vars) + (opt-body (byte-optimize-body (cdr form) for-effect)) (bindings nil)) (dolist (var let-vars) ;; VAR is (NAME EXPR [KEEP [VALUE]]) - (if (and (nthcdr 3 var) (not (nth 2 var))) - ;; Value present and not marked to be kept: eliminate. - (when byte-optimize-warn-eliminated-variable - (byte-compile-warn "eliminating local variable %S" (car var))) + (when (or (not (nthcdr 3 var)) (nth 2 var)) + ;; Value not present, or variable marked to be kept. (push (list (nth 0 var) (nth 1 var)) bindings))) (cons bindings opt-body))) @@ -768,7 +730,6 @@ Same format as `byte-optimize--lexvars', with shared structure and contents.") ;; all-for-effect is true. returns a new list of forms. (let ((rest forms) (result nil) - (byte-optimize--dynamic-vars byte-optimize--dynamic-vars) fe new) (while rest (setq fe (or all-for-effect (cdr rest))) @@ -981,27 +942,45 @@ Same format as `byte-optimize--lexvars', with shared structure and contents.") "Whether EXPR is a constant symbol." (and (macroexp-const-p expr) (symbolp (eval expr)))) +(defun byte-optimize--fixnump (o) + "Return whether O is guaranteed to be a fixnum in all Emacsen. +See Info node `(elisp) Integer Basics'." + (and (fixnump o) (<= -536870912 o 536870911))) + (defun byte-optimize-equal (form) - ;; Replace `equal' or `eql' with `eq' if at least one arg is a symbol. + ;; Replace `equal' or `eql' with `eq' if at least one arg is a + ;; symbol or fixnum. (byte-optimize-binary-predicate (if (= (length (cdr form)) 2) (if (or (byte-optimize--constant-symbol-p (nth 1 form)) - (byte-optimize--constant-symbol-p (nth 2 form))) + (byte-optimize--constant-symbol-p (nth 2 form)) + (byte-optimize--fixnump (nth 1 form)) + (byte-optimize--fixnump (nth 2 form))) (cons 'eq (cdr form)) form) ;; Arity errors reported elsewhere. form))) +(defun byte-optimize-eq (form) + (pcase (cdr form) + ((or `(,x nil) `(nil ,x)) `(not ,x)) + (_ (byte-optimize-binary-predicate form)))) + (defun byte-optimize-member (form) ;; Replace `member' or `memql' with `memq' if the first arg is a symbol, - ;; or the second arg is a list of symbols. + ;; or the second arg is a list of symbols. Same with fixnums. (if (= (length (cdr form)) 2) (if (or (byte-optimize--constant-symbol-p (nth 1 form)) + (byte-optimize--fixnump (nth 1 form)) (let ((arg2 (nth 2 form))) (and (macroexp-const-p arg2) (let ((listval (eval arg2))) (and (listp listval) - (not (memq nil (mapcar #'symbolp listval)))))))) + (not (memq nil (mapcar + (lambda (o) + (or (symbolp o) + (byte-optimize--fixnump o))) + listval)))))))) (cons 'memq (cdr form)) form) ;; Arity errors reported elsewhere. @@ -1009,11 +988,12 @@ Same format as `byte-optimize--lexvars', with shared structure and contents.") (defun byte-optimize-assoc (form) ;; Replace 2-argument `assoc' with `assq', `rassoc' with `rassq', - ;; if the first arg is a symbol. + ;; if the first arg is a symbol or fixnum. (cond ((/= (length form) 3) form) - ((byte-optimize--constant-symbol-p (nth 1 form)) + ((or (byte-optimize--constant-symbol-p (nth 1 form)) + (byte-optimize--fixnump (nth 1 form))) (cons (if (eq (car form) 'assoc) 'assq 'rassq) (cdr form))) (t (byte-optimize-constant-args form)))) @@ -1073,7 +1053,7 @@ Same format as `byte-optimize--lexvars', with shared structure and contents.") (put 'min 'byte-optimizer #'byte-optimize-min-max) (put '= 'byte-optimizer #'byte-optimize-binary-predicate) -(put 'eq 'byte-optimizer #'byte-optimize-binary-predicate) +(put 'eq 'byte-optimizer #'byte-optimize-eq) (put 'eql 'byte-optimizer #'byte-optimize-equal) (put 'equal 'byte-optimizer #'byte-optimize-equal) (put 'string= 'byte-optimizer #'byte-optimize-binary-predicate) @@ -1089,7 +1069,7 @@ Same format as `byte-optimize--lexvars', with shared structure and contents.") (defun byte-optimize-quote (form) (if (or (consp (nth 1 form)) (and (symbolp (nth 1 form)) - (not (macroexp--const-symbol-p form)))) + (not (macroexp--const-symbol-p (nth 1 form))))) form (nth 1 form))) @@ -1250,18 +1230,31 @@ Same format as `byte-optimize--lexvars', with shared structure and contents.") (put 'let 'byte-optimizer #'byte-optimize-letX) (put 'let* 'byte-optimizer #'byte-optimize-letX) (defun byte-optimize-letX (form) - (cond ((null (nth 1 form)) - ;; No bindings - (cons 'progn (cdr (cdr form)))) - ((or (nth 2 form) (nthcdr 3 form)) - form) - ;; The body is nil - ((eq (car form) 'let) - (append '(progn) (mapcar 'car-safe (mapcar 'cdr-safe (nth 1 form))) - '(nil))) - (t - (let ((binds (reverse (nth 1 form)))) - (list 'let* (reverse (cdr binds)) (nth 1 (car binds)) nil))))) + (pcase form + ;; No bindings. + (`(,_ () . ,body) + `(progn . ,body)) + + ;; Body is empty or just contains a constant. + (`(,head ,bindings . ,(or '() `(,(and const (pred macroexp-const-p))))) + (if (eq head 'let) + `(progn ,@(mapcar (lambda (binding) + (and (consp binding) (cadr binding))) + bindings) + ,const) + `(let* ,(butlast bindings) ,(cadar (last bindings)) ,const))) + + ;; Body is last variable. + (`(,head ,bindings ,(and var (pred symbolp) (pred (not keywordp)) + (pred (not booleanp)) + (guard (eq var (caar (last bindings)))))) + (if (eq head 'let) + `(progn ,@(mapcar (lambda (binding) + (and (consp binding) (cadr binding))) + bindings)) + `(let* ,(butlast bindings) ,(cadar (last bindings))))) + + (_ form))) (put 'nth 'byte-optimizer #'byte-optimize-nth) @@ -1286,6 +1279,14 @@ Same format as `byte-optimize--lexvars', with shared structure and contents.") form) form)) +(put 'cons 'byte-optimizer #'byte-optimize-cons) +(defun byte-optimize-cons (form) + ;; (cons X nil) => (list X) + (if (and (= (safe-length form) 3) + (null (nth 2 form))) + `(list ,(nth 1 form)) + form)) + ;; Fixme: delete-char -> delete-region (byte-coded) ;; optimize string-as-unibyte, string-as-multibyte, string-make-unibyte, ;; string-make-multibyte for constant args. @@ -1341,6 +1342,7 @@ Same format as `byte-optimize--lexvars', with shared structure and contents.") elt encode-char exp expt encode-time error-message-string fboundp fceiling featurep ffloor file-directory-p file-exists-p file-locked-p file-name-absolute-p + file-name-concat file-newer-than-file-p file-readable-p file-symlink-p file-writable-p float float-time floor format format-time-string frame-first-window frame-root-window frame-selected-window @@ -1354,7 +1356,8 @@ Same format as `byte-optimize--lexvars', with shared structure and contents.") line-beginning-position line-end-position local-variable-if-set-p local-variable-p locale-info log log10 logand logb logcount logior lognot logxor lsh - make-byte-code make-list make-string make-symbol marker-buffer max + make-byte-code make-list make-string make-symbol mark marker-buffer max + match-beginning match-end member memq memql 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 @@ -1363,6 +1366,8 @@ Same format as `byte-optimize--lexvars', with shared structure and contents.") radians-to-degrees rassq rassoc read-from-string regexp-opt regexp-quote region-beginning region-end reverse round sin sqrt string string< string= string-equal string-lessp + string> string-greaterp string-empty-p + string-prefix-p string-suffix-p string-blank-p string-search string-to-char string-to-number string-to-syntax substring sxhash sxhash-equal sxhash-eq sxhash-eql @@ -1387,7 +1392,7 @@ Same format as `byte-optimize--lexvars', with shared structure and contents.") window-total-height window-total-width window-use-time window-vscroll window-width zerop)) (side-effect-and-error-free-fns - '(arrayp atom + '(always arrayp atom bignump bobp bolp bool-vector-p buffer-end buffer-list buffer-size buffer-string bufferp car-safe case-table-p cdr-safe char-or-string-p characterp @@ -1402,7 +1407,7 @@ Same format as `byte-optimize--lexvars', with shared structure and contents.") invocation-directory invocation-name keymapp keywordp list listp - make-marker mark mark-marker markerp max-char + make-marker mark-marker markerp max-char memory-limit mouse-movement-p natnump nlistp not null number-or-marker-p numberp @@ -1452,7 +1457,8 @@ Same format as `byte-optimize--lexvars', with shared structure and contents.") copysign isnan ldexp float logb floor ceiling round truncate ffloor fceiling fround ftruncate - string= string-equal string< string-lessp + string= string-equal string< string-lessp string> string-greaterp + string-empty-p string-blank-p string-prefix-p string-suffix-p string-search consp atom listp nlistp proper-list-p sequencep arrayp vectorp stringp bool-vector-p hash-table-p @@ -1601,10 +1607,7 @@ Same format as `byte-optimize--lexvars', with shared structure and contents.") ;; so we create a copy of it, and replace the addresses with ;; TAGs. (let ((orig-table last-constant)) - (cl-loop for e across constvec - when (eq e last-constant) - do (setq last-constant (copy-hash-table e)) - and return nil) + (setq last-constant (copy-hash-table last-constant)) ;; Replace all addresses with TAGs. (maphash #'(lambda (value offset) (let ((match (assq offset tags))) @@ -2386,6 +2389,7 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." ;; (eval-when-compile (or (byte-code-function-p (symbol-function 'byte-optimize-form)) + (subr-native-elisp-p (symbol-function 'byte-optimize-form)) (assq 'byte-code (symbol-function 'byte-optimize-form)) (let ((byte-optimize nil) (byte-compile-warnings nil)) |