\f
;;; 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--vars-outside-condition nil
"Alist of variables lexically bound outside conditionally executed code.
Variables here are sensitive to mutation inside the conditional code,
;; 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)
- (if (atom binding)
- (setq name binding)
- (setq name (car binding))
- (setq expr (byte-optimize-form (cadr binding) nil)))
- (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,
(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)))
"Malformed `%S' binding: %S"
letsym binder))
(setq value (cadr binder))
- (car binder)))
- (_ (cond
- ((not (symbolp var))
- (byte-compile-warn "attempt to let-bind nonvariable `%S'"
- var))
- ((or (booleanp var) (keywordp var))
- (byte-compile-warn "attempt to let-bind constant `%S'"
- var))))
- (new-val
- (pcase (cconv--var-classification binder form)
- ;; Check if var is a candidate for lambda lifting.
- ((and :lambda-candidate
- (guard
- (progn
- (cl-assert (and (eq (car value) 'function)
- (eq (car (cadr value)) 'lambda)))
- (cl-assert (equal (cddr (cadr value))
- (caar cconv-freevars-alist)))
- ;; Peek at the freevars to decide whether to λ-lift.
- (let* ((fvs (cdr (car cconv-freevars-alist)))
- (fun (cadr value))
- (funargs (cadr fun))
- (funcvars (append fvs funargs)))
+ (car binder))))
+ (cond
+ ;; Ignore bindings without a valid name.
+ ((not (symbolp var))
+ (byte-compile-warn "attempt to let-bind nonvariable `%S'" var))
+ ((or (booleanp var) (keywordp var))
+ (byte-compile-warn "attempt to let-bind constant `%S'" var))
+ (t
+ (let ((new-val
+ (pcase (cconv--var-classification binder form)
+ ;; Check if var is a candidate for lambda lifting.
+ ((and :lambda-candidate
+ (guard
+ (progn
+ (cl-assert (and (eq (car value) 'function)
+ (eq (car (cadr value)) 'lambda)))
+ (cl-assert (equal (cddr (cadr value))
+ (caar cconv-freevars-alist)))
+ ;; Peek at the freevars to decide whether
+ ;; to λ-lift.
+ (let* ((fvs (cdr (car cconv-freevars-alist)))
+ (fun (cadr value))
+ (funargs (cadr fun))
+ (funcvars (append fvs funargs)))
; lambda lifting condition
- (and fvs (>= cconv-liftwhen
- (length funcvars)))))))
+ (and fvs (>= cconv-liftwhen
+ (length funcvars)))))))
; Lift.
- (let* ((fvs (cdr (pop cconv-freevars-alist)))
- (fun (cadr value))
- (funargs (cadr fun))
- (funcvars (append fvs funargs))
- (funcbody (cddr fun))
- (funcbody-env ()))
- (push `(,var . (apply-partially ,var . ,fvs)) new-env)
- (dolist (fv fvs)
- (cl-pushnew fv new-extend)
- (if (and (eq 'car-safe (car-safe (cdr (assq fv env))))
- (not (memq fv funargs)))
- (push `(,fv . (car-safe ,fv)) funcbody-env)))
- `(function (lambda ,funcvars .
- ,(cconv--convert-funcbody
- funargs funcbody funcbody-env value)))))
-
- ;; Check if it needs to be turned into a "ref-cell".
- (:captured+mutated
- ;; Declared variable is mutated and captured.
- (push `(,var . (car-safe ,var)) new-env)
- `(list ,(cconv-convert value env extend)))
-
- ;; Check if it needs to be turned into a "ref-cell".
- (:unused
- ;; Declared variable is unused.
- (if (assq var new-env) (push `(,var) new-env)) ;FIXME:Needed?
- (let ((newval
- `(ignore ,(cconv-convert value env extend)))
- (msg (cconv--warn-unused-msg var "variable")))
- (if (null msg) newval
- (macroexp--warn-wrap msg newval 'lexical))))
-
- ;; Normal default case.
- (_
- (if (assq var new-env) (push `(,var) new-env))
- (cconv-convert value env extend)))))
-
- (when (and (eq letsym 'let*) (memq var new-extend))
- ;; One of the lambda-lifted vars is shadowed, so add
- ;; a reference to the outside binding and arrange to use
- ;; that reference.
- (let ((closedsym (make-symbol (format "closed-%s" var))))
- (setq new-env (cconv--remap-llv new-env var closedsym))
- (setq new-extend (cons closedsym (remq var new-extend)))
- (push `(,closedsym ,var) binders-new)))
-
- ;; We push the element after redefined free variables are
- ;; processed. This is important to avoid the bug when free
- ;; variable and the function have the same name.
- (push (list var new-val) binders-new)
-
- (when (eq letsym 'let*)
- (setq env new-env)
- (setq extend new-extend))
- )) ; end of dolist over binders
+ (let* ((fvs (cdr (pop cconv-freevars-alist)))
+ (fun (cadr value))
+ (funargs (cadr fun))
+ (funcvars (append fvs funargs))
+ (funcbody (cddr fun))
+ (funcbody-env ()))
+ (push `(,var . (apply-partially ,var . ,fvs)) new-env)
+ (dolist (fv fvs)
+ (cl-pushnew fv new-extend)
+ (if (and (eq 'car-safe (car-safe
+ (cdr (assq fv env))))
+ (not (memq fv funargs)))
+ (push `(,fv . (car-safe ,fv)) funcbody-env)))
+ `(function (lambda ,funcvars .
+ ,(cconv--convert-funcbody
+ funargs funcbody funcbody-env value)))))
+
+ ;; Check if it needs to be turned into a "ref-cell".
+ (:captured+mutated
+ ;; Declared variable is mutated and captured.
+ (push `(,var . (car-safe ,var)) new-env)
+ `(list ,(cconv-convert value env extend)))
+
+ ;; Check if it needs to be turned into a "ref-cell".
+ (:unused
+ ;; Declared variable is unused.
+ (if (assq var new-env)
+ (push `(,var) new-env)) ;FIXME:Needed?
+ (let ((newval
+ `(ignore ,(cconv-convert value env extend)))
+ (msg (cconv--warn-unused-msg var "variable")))
+ (if (null msg) newval
+ (macroexp--warn-wrap msg newval 'lexical))))
+
+ ;; Normal default case.
+ (_
+ (if (assq var new-env) (push `(,var) new-env))
+ (cconv-convert value env extend)))))
+
+ (when (and (eq letsym 'let*) (memq var new-extend))
+ ;; One of the lambda-lifted vars is shadowed, so add
+ ;; a reference to the outside binding and arrange to use
+ ;; that reference.
+ (let ((closedsym (make-symbol (format "closed-%s" var))))
+ (setq new-env (cconv--remap-llv new-env var closedsym))
+ (setq new-extend (cons closedsym (remq var new-extend)))
+ (push `(,closedsym ,var) binders-new)))
+
+ ;; We push the element after redefined free variables are
+ ;; processed. This is important to avoid the bug when free
+ ;; variable and the function have the same name.
+ (push (list var new-val) binders-new)
+
+ (when (eq letsym 'let*)
+ (setq env new-env)
+ (setq extend new-extend))))))
+ ) ; end of dolist over binders
(when (not (eq letsym 'let*))
;; We can't do the cconv--remap-llv at the same place for let and
projects / emacs.git / commitdiff