From 0b9b363dabd70032a288e14333896022caa2d252 Mon Sep 17 00:00:00 2001 From: Alan Mackenzie Date: Fri, 22 Apr 2022 19:11:31 +0000 Subject: [PATCH] Byte compiler: Prevent special forms' symbols being replaced by bare symbols These are symbols with position from source code, which should not be replaced by bare symbols in, e.g., optimization functions. * lisp/Makefile.in: (BYTE_COMPILE_FLAGS, compile-first case): Set max-specpdl-size to 5000 for the benefit of lisp/emacs-lisp/comp.el. * lisp/emacs-lisp/byte-opt.el (byte-optimize-form-code-walker) (byte-optimize--rename-var, byte-optimize-if, byte-optimize-letX) * lisp/emacs-lisp/bytecomp.el (byte-compile-recurse-toplevel) (byte-compile-lambda) * lisp/emacs-lisp/cconv.el (cconv-convert) * lisp/emacs-lisp/macroexp.el (macroexp--expand-all): Preserve, e.g., (car form) in the byte compiler, when this form's car is a symbol with position of a special form, rather than replacing the symbol with a bare symbol, e.g. 'cond. --- lisp/Makefile.in | 4 +- lisp/emacs-lisp/byte-opt.el | 115 ++++++++++---------- lisp/emacs-lisp/bytecomp.el | 4 +- lisp/emacs-lisp/cconv.el | 22 ++-- lisp/emacs-lisp/macroexp.el | 203 ++++++++++++++++++------------------ 5 files changed, 176 insertions(+), 172 deletions(-) diff --git a/lisp/Makefile.in b/lisp/Makefile.in index 308407a8bf1..fabf6ed55e1 100644 --- a/lisp/Makefile.in +++ b/lisp/Makefile.in @@ -78,7 +78,9 @@ AUTOGENEL = ${loaddefs} ${srcdir}/cus-load.el ${srcdir}/finder-inf.el \ BYTE_COMPILE_FLAGS = \ --eval '(setq load-prefer-newer t)' $(BYTE_COMPILE_EXTRA_FLAGS) # ... but we must prefer .elc files for those in the early bootstrap. -compile-first: BYTE_COMPILE_FLAGS = $(BYTE_COMPILE_EXTRA_FLAGS) +# A larger `max-specpdl-size' is needed for emacs-lisp/comp.el. +compile-first: BYTE_COMPILE_FLAGS = \ + --eval '(setq max-specpdl-size 5000)' $(BYTE_COMPILE_EXTRA_FLAGS) # Files to compile before others during a bootstrap. This is done to # speed up the bootstrap process. They're ordered by size, so we use diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 39bb6224595..d3d8405d068 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -338,7 +338,7 @@ for speeding up processing.") (let ((exps-opt (byte-optimize-body exps t))) (if (macroexp-const-p exp-opt) `(progn ,@exps-opt ,exp-opt) - `(prog1 ,exp-opt ,@exps-opt))) + `(,fn ,exp-opt ,@exps-opt))) exp-opt))) (`(,(or `save-excursion `save-restriction `save-current-buffer) . ,exps) @@ -358,7 +358,7 @@ for speeding up processing.") (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))) + `(,fn ,test-opt ,then-opt . ,else-opt))) (`(,(or 'and 'or) . ,exps) ;; FIXME: We have to traverse the expressions in left-to-right @@ -397,7 +397,7 @@ for speeding up processing.") ;; as mutated variables have been marked as non-substitutable. (condition (byte-optimize-form (car condition-body) nil)) (body (byte-optimize-body (cdr condition-body) t))) - `(while ,condition . ,body))) + `(,fn ,condition . ,body))) (`(interactive . ,_) (byte-compile-warn-x form "misplaced interactive spec: `%s'" form) @@ -409,7 +409,7 @@ for speeding up processing.") form) (`(condition-case ,var ,exp . ,clauses) - `(condition-case ,var ;Not evaluated. + `(,fn ,var ;Not evaluated. ,(byte-optimize-form exp for-effect) ,@(mapcar (lambda (clause) (let ((byte-optimize--lexvars @@ -432,14 +432,14 @@ for speeding up processing.") (let ((bodyform (byte-optimize-form exp for-effect))) (pcase exps (`(:fun-body ,f) - `(unwind-protect ,bodyform + `(,fn ,bodyform :fun-body ,(byte-optimize-form f nil))) (_ - `(unwind-protect ,bodyform + `(,fn ,bodyform . ,(byte-optimize-body exps t)))))) (`(catch ,tag . ,exps) - `(catch ,(byte-optimize-form tag nil) + `(,fn ,(byte-optimize-form tag nil) . ,(byte-optimize-body exps for-effect))) ;; Needed as long as we run byte-optimize-form after cconv. @@ -495,7 +495,7 @@ for speeding up processing.") (cons (byte-optimize-form (car rest) nil) (cdr rest))))) (push name byte-optimize--dynamic-vars) - `(defvar ,name . ,optimized-rest))) + `(,fn ,name . ,optimized-rest))) (`(,(pred byte-code-function-p) . ,exps) (cons fn (mapcar #'byte-optimize-form exps))) @@ -561,49 +561,50 @@ for speeding up processing.") (defun byte-optimize--rename-var (var new-var form) "Replace VAR with NEW-VAR in FORM." - (pcase form - ((pred symbolp) (if (eq form var) new-var form)) - (`(setq . ,args) - (let ((new-args nil)) - (while args - (push (byte-optimize--rename-var var new-var (car args)) new-args) - (push (byte-optimize--rename-var var new-var (cadr args)) new-args) - (setq args (cddr args))) - `(setq . ,(nreverse new-args)))) - ;; In binding constructs like `let', `let*' and `condition-case' we - ;; rename everything for simplicity, even new bindings named VAR. - (`(,(and head (or 'let 'let*)) ,bindings . ,body) - `(,head - ,(mapcar (lambda (b) (byte-optimize--rename-var-body var new-var b)) - bindings) - ,@(byte-optimize--rename-var-body var new-var body))) - (`(condition-case ,res-var ,protected-form . ,handlers) - `(condition-case ,(byte-optimize--rename-var var new-var res-var) - ,(byte-optimize--rename-var var new-var protected-form) - ,@(mapcar (lambda (h) - (cons (car h) - (byte-optimize--rename-var-body var new-var (cdr h)))) - handlers))) - (`(internal-make-closure ,vars ,env . ,rest) - `(internal-make-closure - ,vars ,(byte-optimize--rename-var-body var new-var env) . ,rest)) - (`(defvar ,name . ,rest) - ;; NAME is not renamed here; we only care about lexical variables. - `(defvar ,name . ,(byte-optimize--rename-var-body var new-var rest))) - - (`(cond . ,clauses) - `(cond ,@(mapcar (lambda (c) - (byte-optimize--rename-var-body var new-var c)) - clauses))) - - (`(function . ,_) form) - (`(quote . ,_) form) - (`(lambda . ,_) form) - - ;; Function calls and special forms not handled above. - (`(,head . ,args) - `(,head . ,(byte-optimize--rename-var-body var new-var args))) - (_ form))) + (let ((fn (car-safe form))) + (pcase form + ((pred symbolp) (if (eq form var) new-var form)) + (`(setq . ,args) + (let ((new-args nil)) + (while args + (push (byte-optimize--rename-var var new-var (car args)) new-args) + (push (byte-optimize--rename-var var new-var (cadr args)) new-args) + (setq args (cddr args))) + `(,fn . ,(nreverse new-args)))) + ;; In binding constructs like `let', `let*' and `condition-case' we + ;; rename everything for simplicity, even new bindings named VAR. + (`(,(and head (or 'let 'let*)) ,bindings . ,body) + `(,head + ,(mapcar (lambda (b) (byte-optimize--rename-var-body var new-var b)) + bindings) + ,@(byte-optimize--rename-var-body var new-var body))) + (`(condition-case ,res-var ,protected-form . ,handlers) + `(,fn ,(byte-optimize--rename-var var new-var res-var) + ,(byte-optimize--rename-var var new-var protected-form) + ,@(mapcar (lambda (h) + (cons (car h) + (byte-optimize--rename-var-body var new-var (cdr h)))) + handlers))) + (`(internal-make-closure ,vars ,env . ,rest) + `(,fn + ,vars ,(byte-optimize--rename-var-body var new-var env) . ,rest)) + (`(defvar ,name . ,rest) + ;; NAME is not renamed here; we only care about lexical variables. + `(,fn ,name . ,(byte-optimize--rename-var-body var new-var rest))) + + (`(cond . ,clauses) + `(,fn ,@(mapcar (lambda (c) + (byte-optimize--rename-var-body var new-var c)) + clauses))) + + (`(function . ,_) form) + (`(quote . ,_) form) + (`(lambda . ,_) form) + + ;; Function calls and special forms not handled above. + (`(,head . ,args) + `(,head . ,(byte-optimize--rename-var-body var new-var args))) + (_ form)))) (defun byte-optimize-let-form (head form for-effect) ;; Recursively enter the optimizer for the bindings and body @@ -1174,21 +1175,21 @@ See Info node `(elisp) Integer Basics'." (proper-list-p clause)) (if (null (cddr clause)) ;; A trivial `progn'. - (byte-optimize-if `(if ,(cadr clause) ,@(nthcdr 2 form))) + (byte-optimize-if `(,(car form) ,(cadr clause) ,@(nthcdr 2 form))) (nconc (butlast clause) (list (byte-optimize-if - `(if ,(car (last clause)) ,@(nthcdr 2 form))))))) + `(,(car form) ,(car (last clause)) ,@(nthcdr 2 form))))))) ((byte-compile-trueconstp clause) `(progn ,clause ,(nth 2 form))) ((byte-compile-nilconstp clause) `(progn ,clause ,@(nthcdr 3 form))) ((nth 2 form) (if (equal '(nil) (nthcdr 3 form)) - (list 'if clause (nth 2 form)) + (list (car form) clause (nth 2 form)) form)) ((or (nth 3 form) (nthcdr 4 form)) - (list 'if + (list (car form) ;; Don't make a double negative; ;; instead, take away the one that is there. (if (and (consp clause) (memq (car clause) '(not null)) @@ -1267,7 +1268,7 @@ See Info node `(elisp) Integer Basics'." (and (consp binding) (cadr binding))) bindings) ,const) - `(let* ,(butlast bindings) + `(,head ,(butlast bindings) ,@(and (consp (car (last bindings))) (cdar (last bindings))) ,const))) @@ -1282,7 +1283,7 @@ See Info node `(elisp) Integer Basics'." `(progn ,@(mapcar (lambda (binding) (and (consp binding) (cadr binding))) bindings)) - `(let* ,(butlast bindings) + `(,head ,(butlast bindings) ,@(and (consp (car (last bindings))) (cdar (last bindings)))))) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index f97324f3a8f..28237d67d29 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -471,7 +471,7 @@ Return the compile-time value of FORM." (let ((print-symbols-bare t)) ; Possibly redundant binding. (setf form (macroexp-macroexpand form byte-compile-macro-environment))) (if (eq (car-safe form) 'progn) - (cons 'progn + (cons (car form) (mapcar (lambda (subform) (byte-compile-recurse-toplevel subform non-toplevel-case)) @@ -3084,7 +3084,7 @@ lambda-expression." ;; which may include "calls" to ;; internal-make-closure (Bug#29988). lexical-binding) - (setq int `(interactive ,newform))))) + (setq int `(,(car int) ,newform))))) ((cdr int) ; Invalid (interactive . something). (byte-compile-warn-x int "malformed interactive spec: %s" int)))) diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el index be4fea7be14..4535f1aa6eb 100644 --- a/lisp/emacs-lisp/cconv.el +++ b/lisp/emacs-lisp/cconv.el @@ -500,11 +500,11 @@ places where they originally did not directly appear." args))) (`(cond . ,cond-forms) ; cond special form - `(cond . ,(mapcar (lambda (branch) - (mapcar (lambda (form) - (cconv-convert form env extend)) - branch)) - cond-forms))) + `(,(car form) . ,(mapcar (lambda (branch) + (mapcar (lambda (form) + (cconv-convert form env extend)) + branch)) + cond-forms))) (`(function (lambda ,args . ,body) . ,_) (let ((docstring (if (eq :documentation (car-safe (car body))) @@ -538,7 +538,7 @@ places where they originally did not directly appear." (msg (when (eq class :unused) (cconv--warn-unused-msg var "variable"))) (newprotform (cconv-convert protected-form env extend))) - `(condition-case ,var + `(,(car form) ,var ,(if msg (macroexp--warn-wrap var msg newprotform 'lexical) newprotform) @@ -554,9 +554,9 @@ places where they originally did not directly appear." `((let ((,var (list ,var))) ,@body)))))) handlers)))) - (`(unwind-protect ,form . ,body) - `(unwind-protect ,(cconv-convert form env extend) - :fun-body ,(cconv--convert-function () body env form))) + (`(unwind-protect ,form1 . ,body) + `(,(car form) ,(cconv-convert form1 env extend) + :fun-body ,(cconv--convert-function () body env form1))) (`(setq . ,forms) ; setq special form (if (= (logand (length forms) 1) 1) @@ -568,7 +568,7 @@ places where they originally did not directly appear." (sym-new (or (cdr (assq sym env)) sym)) (value (cconv-convert (pop forms) env extend))) (push (pcase sym-new - ((pred symbolp) `(setq ,sym-new ,value)) + ((pred symbolp) `(,(car form) ,sym-new ,value)) (`(car-safe ,iexp) `(setcar ,iexp ,value)) ;; This "should never happen", but for variables which are ;; mutated+captured+unused, we may end up trying to `setq' @@ -604,7 +604,7 @@ places where they originally did not directly appear." (cons fun args))))))) (`(interactive . ,forms) - `(interactive . ,(mapcar (lambda (form) + `(,(car form) . ,(mapcar (lambda (form) (cconv-convert form nil nil)) forms))) diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index e4bc2df2803..51c6e8e0ca2 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -330,108 +330,109 @@ Assumes the caller has bound `macroexpand-all-environment'." (setq form (macroexp-macroexpand form macroexpand-all-environment)) ;; FIXME: It'd be nice to use `byte-optimize--pcase' here, but when ;; I tried it, it broke the bootstrap :-( - (pcase form - (`(cond . ,clauses) - (macroexp--cons 'cond (macroexp--all-clauses clauses) form)) - (`(condition-case . ,(or `(,err ,body . ,handlers) pcase--dontcare)) - (macroexp--cons - 'condition-case - (macroexp--cons err - (macroexp--cons (macroexp--expand-all body) - (macroexp--all-clauses handlers 1) - (cddr form)) - (cdr form)) - form)) - (`(,(or 'defvar 'defconst) ,(and name (pred symbolp)) . ,_) - (push name macroexp--dynvars) - (macroexp--all-forms form 2)) - (`(function ,(and f `(lambda . ,_))) - (let ((macroexp--dynvars macroexp--dynvars)) - (macroexp--cons 'function - (macroexp--cons (macroexp--all-forms f 2) - nil - (cdr form)) - form))) - (`(,(or 'function 'quote) . ,_) form) - (`(,(and fun (or 'let 'let*)) . ,(or `(,bindings . ,body) - pcase--dontcare)) - (let ((macroexp--dynvars macroexp--dynvars)) + (let ((fn (car-safe form))) + (pcase form + (`(cond . ,clauses) + (macroexp--cons fn (macroexp--all-clauses clauses) form)) + (`(condition-case . ,(or `(,err ,body . ,handlers) pcase--dontcare)) (macroexp--cons - fun - (macroexp--cons - (macroexp--all-clauses bindings 1) - (if (null body) - (macroexp-unprogn - (macroexp-warn-and-return - (format "Empty %s body" fun) - nil nil 'compile-only fun)) - (macroexp--all-forms body)) - (cdr form)) - form))) - (`(,(and fun `(lambda . ,_)) . ,args) - ;; Embedded lambda in function position. - ;; If the byte-optimizer is loaded, try to unfold this, - ;; i.e. rewrite it to (let () ). We'd do it in the optimizer - ;; anyway, but doing it here (i.e. earlier) can sometimes avoid the - ;; creation of a closure, thus resulting in much better code. - (let ((newform (macroexp--unfold-lambda form))) - (if (eq newform form) - ;; Unfolding failed for some reason, avoid infinite recursion. - (macroexp--cons (macroexp--all-forms fun 2) - (macroexp--all-forms args) - form) - (macroexp--expand-all newform)))) - (`(funcall ,exp . ,args) - (let ((eexp (macroexp--expand-all exp)) - (eargs (macroexp--all-forms args))) - ;; Rewrite (funcall #'foo bar) to (foo bar), in case `foo' - ;; has a compiler-macro, or to unfold it. - (pcase eexp - ((and `#',f - (guard (not (or (special-form-p f) (macrop f))))) ;; bug#46636 - (macroexp--expand-all `(,f . ,eargs))) - (_ `(funcall ,eexp . ,eargs))))) - (`(funcall . ,_) form) ;bug#53227 - (`(,func . ,_) - (let ((handler (function-get func 'compiler-macro)) - (funargs (function-get func 'funarg-positions))) - ;; Check functions quoted with ' rather than with #' - (dolist (funarg funargs) - (let ((arg (nth funarg form))) - (when (and (eq 'quote (car-safe arg)) - (eq 'lambda (car-safe (cadr arg)))) - (setcar (nthcdr funarg form) - (macroexp-warn-and-return - (format "%S quoted with ' rather than with #'" - (let ((f (cadr arg))) - (if (symbolp f) f `(lambda ,(nth 1 f) ...)))) - arg nil nil (cadr arg)))))) - ;; Macro expand compiler macros. This cannot be delayed to - ;; byte-optimize-form because the output of the compiler-macro can - ;; use macros. - (if (null handler) - ;; No compiler macro. We just expand each argument (for - ;; setq/setq-default this works alright because the variable names - ;; are symbols). - (macroexp--all-forms form 1) - ;; If the handler is not loaded yet, try (auto)loading the - ;; function itself, which may in turn load the handler. - (unless (functionp handler) - (with-demoted-errors "macroexp--expand-all: %S" - (autoload-do-load (indirect-function func) func))) - (let ((newform (macroexp--compiler-macro handler form))) - (if (eq form newform) - ;; The compiler macro did not find anything to do. - (if (equal form (setq newform (macroexp--all-forms form 1))) - form - ;; Maybe after processing the args, some new opportunities - ;; appeared, so let's try the compiler macro again. - (setq form (macroexp--compiler-macro handler newform)) - (if (eq newform form) - newform - (macroexp--expand-all newform))) - (macroexp--expand-all newform)))))) - (_ form))) + fn + (macroexp--cons err + (macroexp--cons (macroexp--expand-all body) + (macroexp--all-clauses handlers 1) + (cddr form)) + (cdr form)) + form)) + (`(,(or 'defvar 'defconst) ,(and name (pred symbolp)) . ,_) + (push name macroexp--dynvars) + (macroexp--all-forms form 2)) + (`(function ,(and f `(lambda . ,_))) + (let ((macroexp--dynvars macroexp--dynvars)) + (macroexp--cons fn + (macroexp--cons (macroexp--all-forms f 2) + nil + (cdr form)) + form))) + (`(,(or 'function 'quote) . ,_) form) + (`(,(and fun (or 'let 'let*)) . ,(or `(,bindings . ,body) + pcase--dontcare)) + (let ((macroexp--dynvars macroexp--dynvars)) + (macroexp--cons + fun + (macroexp--cons + (macroexp--all-clauses bindings 1) + (if (null body) + (macroexp-unprogn + (macroexp-warn-and-return + (format "Empty %s body" fun) + nil nil 'compile-only fun)) + (macroexp--all-forms body)) + (cdr form)) + form))) + (`(,(and fun `(lambda . ,_)) . ,args) + ;; Embedded lambda in function position. + ;; If the byte-optimizer is loaded, try to unfold this, + ;; i.e. rewrite it to (let () ). We'd do it in the optimizer + ;; anyway, but doing it here (i.e. earlier) can sometimes avoid the + ;; creation of a closure, thus resulting in much better code. + (let ((newform (macroexp--unfold-lambda form))) + (if (eq newform form) + ;; Unfolding failed for some reason, avoid infinite recursion. + (macroexp--cons (macroexp--all-forms fun 2) + (macroexp--all-forms args) + form) + (macroexp--expand-all newform)))) + (`(funcall ,exp . ,args) + (let ((eexp (macroexp--expand-all exp)) + (eargs (macroexp--all-forms args))) + ;; Rewrite (funcall #'foo bar) to (foo bar), in case `foo' + ;; has a compiler-macro, or to unfold it. + (pcase eexp + ((and `#',f + (guard (not (or (special-form-p f) (macrop f))))) ;; bug#46636 + (macroexp--expand-all `(,f . ,eargs))) + (_ `(funcall ,eexp . ,eargs))))) + (`(funcall . ,_) form) ;bug#53227 + (`(,func . ,_) + (let ((handler (function-get func 'compiler-macro)) + (funargs (function-get func 'funarg-positions))) + ;; Check functions quoted with ' rather than with #' + (dolist (funarg funargs) + (let ((arg (nth funarg form))) + (when (and (eq 'quote (car-safe arg)) + (eq 'lambda (car-safe (cadr arg)))) + (setcar (nthcdr funarg form) + (macroexp-warn-and-return + (format "%S quoted with ' rather than with #'" + (let ((f (cadr arg))) + (if (symbolp f) f `(lambda ,(nth 1 f) ...)))) + arg nil nil (cadr arg)))))) + ;; Macro expand compiler macros. This cannot be delayed to + ;; byte-optimize-form because the output of the compiler-macro can + ;; use macros. + (if (null handler) + ;; No compiler macro. We just expand each argument (for + ;; setq/setq-default this works alright because the variable names + ;; are symbols). + (macroexp--all-forms form 1) + ;; If the handler is not loaded yet, try (auto)loading the + ;; function itself, which may in turn load the handler. + (unless (functionp handler) + (with-demoted-errors "macroexp--expand-all: %S" + (autoload-do-load (indirect-function func) func))) + (let ((newform (macroexp--compiler-macro handler form))) + (if (eq form newform) + ;; The compiler macro did not find anything to do. + (if (equal form (setq newform (macroexp--all-forms form 1))) + form + ;; Maybe after processing the args, some new opportunities + ;; appeared, so let's try the compiler macro again. + (setq form (macroexp--compiler-macro handler newform)) + (if (eq newform form) + newform + (macroexp--expand-all newform))) + (macroexp--expand-all newform)))))) + (_ form)))) (pop byte-compile-form-stack))) ;; Record which arguments expect functions, so we can warn when those -- 2.39.2