diff options
Diffstat (limited to 'lisp/emacs-lisp/byte-opt.el')
| -rw-r--r-- | lisp/emacs-lisp/byte-opt.el | 248 |
1 files changed, 172 insertions, 76 deletions
diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index ff512cca36f..966ef266b9a 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -310,13 +310,6 @@ Earlier variables shadow later ones with the same name.") ;;; implementing source-level optimizers -(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, -since their contents in sequentially later code depends on the path taken -and may no longer be statically known. -Same format as `byte-optimize--lexvars', with shared structure and contents.") - (defvar byte-optimize--vars-outside-loop nil "Alist of variables lexically bound outside the innermost `while' loop. Variables here are sensitive to mutation inside the loop, since this can @@ -327,6 +320,13 @@ Same format as `byte-optimize--lexvars', with shared structure and contents.") (defvar byte-optimize--dynamic-vars nil "List of variables declared as dynamic during optimisation.") +(defvar byte-optimize--aliased-vars nil + "List of variables which may be aliased by other lexical variables. +If an entry in `byte-optimize--lexvars' has another variable as its VALUE, +then that other variable must be in this list. +This variable thus carries no essential information but is maintained +for speeding up processing.") + (defun byte-optimize--substitutable-p (expr) "Whether EXPR is a constant that can be propagated." ;; Only consider numbers, symbols and strings to be values for substitution @@ -425,19 +425,19 @@ Same format as `byte-optimize--lexvars', with shared structure and contents.") (`(,(or 'let 'let*) . ,rest) (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)))) + ;; FIXME: The condition in the first clause is always executed, and + ;; clause bodies are mutually exclusive -- use this for improved + ;; optimisation (see comment about `if' below). + (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))) (`(progn . ,exps) ;; As an extra added bonus, this simplifies (progn <x>) --> <x>. (if (cdr exps) @@ -463,22 +463,15 @@ Same format as `byte-optimize--lexvars', with shared structure and contents.") ;; 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)) (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))) - (`(,(or 'and 'or) . ,exps) ; Remember, and/or are control structures. + (`(,(or 'and 'or) . ,exps) ;; FIXME: We have to traverse the expressions in left-to-right ;; order (because that is the order of evaluation and variable ;; mutations must be found prior to their use), but doing so we miss @@ -487,19 +480,11 @@ Same format as `byte-optimize--lexvars', with shared structure and contents.") ;; Then A could be optimised in a for-effect context too. (let ((tail exps) (args nil)) - (when tail - ;; The first argument is always unconditional. + (while tail (push (byte-optimize-form (car tail) (and for-effect (null (cdr tail)))) args) - (setq tail (cdr tail)) - ;; Remaining arguments are conditional. - (let ((byte-optimize--vars-outside-condition byte-optimize--lexvars)) - (while tail - (push (byte-optimize-form - (car tail) (and for-effect (null (cdr tail)))) - args) - (setq tail (cdr tail))))) + (setq tail (cdr tail))) (cons fn (nreverse args)))) (`(while ,exp . ,exps) @@ -508,13 +493,11 @@ Same format as `byte-optimize--lexvars', with shared structure and contents.") ;; but this misses many opportunities: variables not mutated in the ;; loop at all, and variables affecting the initial condition (which ;; is always executed unconditionally). - (let* ((byte-optimize--vars-outside-condition byte-optimize--lexvars) - (byte-optimize--vars-outside-loop byte-optimize--lexvars) + (let* ((byte-optimize--vars-outside-loop byte-optimize--lexvars) (condition (byte-optimize-form exp nil)) (body (byte-optimize-body exps t))) `(while ,condition . ,body))) - (`(interactive . ,_) (byte-compile-warn "misplaced interactive spec: `%s'" (prin1-to-string form)) @@ -526,19 +509,18 @@ Same format as `byte-optimize--lexvars', with shared structure and contents.") form) (`(condition-case ,var ,exp . ,clauses) - (let ((byte-optimize--vars-outside-condition byte-optimize--lexvars)) - `(condition-case ,var ;Not evaluated. - ,(byte-optimize-form exp for-effect) - ,@(mapcar (lambda (clause) - (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)))) + `(condition-case ,var ;Not evaluated. + ,(byte-optimize-form exp for-effect) + ,@(mapcar (lambda (clause) + (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) ;; The unwinding part of an unwind-protect is compiled (and thus @@ -547,8 +529,7 @@ Same format as `byte-optimize--lexvars', with shared structure and contents.") ;; protected part has the same for-effect status as the ;; unwind-protect itself. (The unwinding part is always for effect, ;; but that isn't handled properly yet.) - (let* ((byte-optimize--vars-outside-condition byte-optimize--lexvars) - (bodyform (byte-optimize-form exp for-effect))) + (let ((bodyform (byte-optimize-form exp for-effect))) (pcase exps (`(:fun-body ,f) `(unwind-protect ,bodyform @@ -558,9 +539,8 @@ Same format as `byte-optimize--lexvars', with shared structure and contents.") . ,(byte-optimize-body exps t)))))) (`(catch ,tag . ,exps) - (let ((byte-optimize--vars-outside-condition byte-optimize--lexvars)) - `(catch ,(byte-optimize-form tag nil) - . ,(byte-optimize-body exps for-effect)))) + `(catch ,(byte-optimize-form tag nil) + . ,(byte-optimize-body exps for-effect))) ;; Needed as long as we run byte-optimize-form after cconv. (`(internal-make-closure . ,_) @@ -595,7 +575,15 @@ Same format as `byte-optimize--lexvars', with shared structure and contents.") (value (byte-optimize-form expr nil))) (when lexvar (setcar (cdr lexvar) t) ; Mark variable to be kept. - (setcdr (cdr lexvar) nil)) ; Inhibit further substitution. + (setcdr (cdr lexvar) nil) ; Inhibit further substitution. + + (when (memq var byte-optimize--aliased-vars) + ;; Cancel aliasing of variables aliased to this one. + (dolist (v byte-optimize--lexvars) + (when (eq (nth 2 v) var) + ;; V is bound to VAR but VAR is now mutated: + ;; cancel aliasing. + (setcdr (cdr v) nil))))) (push var var-expr-list) (push value var-expr-list)) @@ -666,34 +654,142 @@ Same format as `byte-optimize--lexvars', with shared structure and contents.") (not (eq new old)))))))) form) +(defun byte-optimize--rename-var-body (var new-var body) + "Replace VAR with NEW-VAR in BODY." + (mapcar (lambda (form) (byte-optimize--rename-var var new-var form)) body)) + +(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))) + (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 lexical-binding (let* ((byte-optimize--lexvars byte-optimize--lexvars) + (byte-optimize--aliased-vars byte-optimize--aliased-vars) (new-lexvars nil) - (let-vars nil)) - (dolist (binding (car form)) - (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))))) + (new-aliased-vars nil) + (let-vars nil) + (body (cdr form)) + (bindings (car form))) + (while bindings + (let* ((binding (car bindings)) + (name (car binding)) + (expr (byte-optimize-form (cadr binding) nil))) + (setq bindings (cdr bindings)) + (when (and (eq head 'let*) + (memq name byte-optimize--aliased-vars)) + ;; New variable shadows an aliased variable -- α-rename + ;; it in this and all subsequent bindings. + (let ((new-name (make-symbol (symbol-name name)))) + (setq bindings + (mapcar (lambda (b) + (list (byte-optimize--rename-var + name new-name (car b)) + (byte-optimize--rename-var + name new-name (cadr b)))) + bindings)) + (setq body (byte-optimize--rename-var-body name new-name body)) + (setq name new-name))) + (let* ((aliased nil) + (value (and + (or (byte-optimize--substitutable-p expr) + ;; Aliasing another lexvar. + (setq aliased + (and (symbolp expr) + (assq expr byte-optimize--lexvars)))) + (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))) + (when aliased + (push expr (if (eq head 'let*) + byte-optimize--aliased-vars + new-aliased-vars)))))) + + (setq byte-optimize--aliased-vars + (append new-aliased-vars byte-optimize--aliased-vars)) + (when (and (eq head 'let) byte-optimize--aliased-vars) + ;; Find new variables that shadow aliased variables. + (let ((shadowing-vars nil)) + (dolist (lexvar new-lexvars) + (let ((name (car lexvar))) + (when (and (memq name byte-optimize--aliased-vars) + (not (memq name shadowing-vars))) + (push name shadowing-vars)))) + ;; α-rename them + (dolist (name shadowing-vars) + (let ((new-name (make-symbol (symbol-name name)))) + (setq new-lexvars + (mapcar (lambda (lexvar) + (if (eq (car lexvar) name) + (cons new-name (cdr lexvar)) + lexvar)) + new-lexvars)) + (setq let-vars + (mapcar (lambda (v) + (if (eq (car v) name) + (cons new-name (cdr v)) + v)) + let-vars)) + (setq body (byte-optimize--rename-var-body + name new-name body)))))) (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* ((byte-optimize--dynamic-vars byte-optimize--dynamic-vars) - (opt-body (byte-optimize-body (cdr form) for-effect)) + (opt-body (byte-optimize-body body for-effect)) (bindings nil)) (dolist (var let-vars) ;; VAR is (NAME EXPR [KEEP [VALUE]]) |