-;;; byte-opt.el --- the optimization passes of the emacs-lisp byte compiler
+;;; 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-2014 Free Software Foundation, Inc.
;; Author: Jamie Zawinski <jwz@lucid.com>
;; Hallvard Furuseth <hbf@ulrik.uio.no>
-;; Maintainer: FSF
+;; Maintainer: emacs-devel@gnu.org
;; Keywords: internal
;; Package: emacs
;; We'd have to notice defvars and defconsts, since those variables should
;; always be dynamic, and attempting to do a lexical binding of them
;; should simply do a dynamic binding instead.
-;; But! We need to know about variables that were not necessarily defvarred
+;; But! We need to know about variables that were not necessarily defvared
;; in the file being compiled (doing a boundp check isn't good enough.)
;; Fdefvar() would have to be modified to add something to the plist.
;;
;;; 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.
sexp)))
(cdr form))))
-
-;; Splice the given lap code into the current instruction stream.
-;; If it has any labels in it, you're responsible for making sure there
-;; are no collisions, and that byte-compile-tag-number is reasonable
-;; after this is spliced in. The provided list is destroyed.
-(defun byte-inline-lapcode (lap)
- ;; "Replay" the operations: we used to just do
- ;; (setq byte-compile-output (nconc (nreverse lap) byte-compile-output))
- ;; but that fails to update byte-compile-depth, so we had to assume
- ;; that `lap' ends up adding exactly 1 element to the stack. This
- ;; happens to be true for byte-code generated by bytecomp.el without
- ;; lexical-binding, but it's not true in general, and it's not true for
- ;; code output by bytecomp.el with lexical-binding.
- (dolist (op lap)
- (cond
- ((eq (car op) 'TAG) (byte-compile-out-tag op))
- ((memq (car op) byte-goto-ops) (byte-compile-goto (car op) (cdr op)))
- (t (byte-compile-out (car op) (cdr op))))))
-
(defun byte-compile-inline-expand (form)
(let* ((name (car form))
- (fn (or (cdr (assq name byte-compile-function-environment))
- (and (fboundp name) (symbol-function name)))))
- (if (null fn)
- (progn
- (byte-compile-warn "attempt to inline `%s' before it was defined"
- name)
- form)
- ;; else
- (when (and (consp fn) (eq (car fn) 'autoload))
- (load (nth 1 fn))
- (setq fn (or (and (fboundp name) (symbol-function name))
- (cdr (assq name byte-compile-function-environment)))))
- (if (and (consp fn) (eq (car fn) 'autoload))
- (error "File `%s' didn't define `%s'" (nth 1 fn) name))
- (cond
- ((and (symbolp fn) (not (eq fn t))) ;A function alias.
- (byte-compile-inline-expand (cons fn (cdr form))))
- ((and (byte-code-function-p fn)
- ;; FIXME: This works to inline old-style-byte-codes into
- ;; old-style-byte-codes, but not mixed cases (not sure
- ;; about new-style into new-style).
- (not lexical-binding)
- (not (and (>= (length fn) 7)
- (aref fn 6)))) ;6 = COMPILED_PUSH_ARGS
- ;; (message "Inlining %S byte-code" name)
- (fetch-bytecode fn)
- (let ((string (aref fn 1)))
- ;; Isn't it an error for `string' not to be unibyte?? --stef
- (if (fboundp 'string-as-unibyte)
- (setq string (string-as-unibyte string)))
- ;; `byte-compile-splice-in-already-compiled-code'
- ;; takes care of inlining the body.
- (cons `(lambda ,(aref fn 0)
- (byte-code ,string ,(aref fn 2) ,(aref fn 3)))
- (cdr form))))
- ((eq (car-safe fn) 'lambda)
- (macroexpand-all (cons fn (cdr form))
- byte-compile-macro-environment))
- (t ;; Give up on inlining.
- form)))))
+ (localfn (cdr (assq name byte-compile-function-environment)))
+ (fn (or localfn (symbol-function name))))
+ (when (autoloadp fn)
+ (autoload-do-load fn)
+ (setq fn (or (symbol-function name)
+ (cdr (assq name byte-compile-function-environment)))))
+ (pcase fn
+ (`nil
+ (byte-compile-warn "attempt to inline `%s' before it was defined"
+ name)
+ form)
+ (`(autoload . ,_)
+ (error "File `%s' didn't define `%s'" (nth 1 fn) name))
+ ((and (pred symbolp) (guard (not (eq fn t)))) ;A function alias.
+ (byte-compile-inline-expand (cons fn (cdr form))))
+ ((pred byte-code-function-p)
+ ;; (message "Inlining byte-code for %S!" name)
+ ;; The byte-code will be really inlined in byte-compile-unfold-bcf.
+ `(,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)
+ (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-log-warning
+ (format "Inlining closure %S failed" name))
+ form))))
+
+ (t ;; 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). 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.
+ ;; (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)))
- (if (byte-code-function-p lambda)
- (setq lambda (list 'lambda (aref lambda 0)
- (list 'byte-code (aref lambda 1)
- (aref lambda 2) (aref lambda 3)))))
(let ((arglist (nth 1 lambda))
(body (cdr (cdr lambda)))
optionalp restp
(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...
(and (nth 1 form)
(not for-effect)
form))
- ((or (byte-code-function-p fn)
- (eq 'lambda (car-safe fn)))
+ ((eq 'lambda (car-safe fn))
(let ((newform (byte-compile-unfold-lambda form)))
(if (eq newform form)
;; Some error occurred, avoid infinite recursion
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))
(byte-optimize-form (nth 2 form) for-effect)
(byte-optimize-body (nthcdr 3 form) for-effect)))))
- ((memq fn '(and or)) ; remember, and/or are control structures.
- ;; take forms off the back until we can't any more.
+ ((memq fn '(and or)) ; Remember, and/or are control structures.
+ ;; Take forms off the back until we can't any more.
;; In the future it could conceivably be a problem that the
;; subexpressions of these forms are optimized in the reverse
;; order, but it's ok for now.
(byte-compile-log
" all subforms of %s called for effect; deleted" form))
(and backwards
- (cons fn (nreverse (mapcar 'byte-optimize-form backwards)))))
+ (cons fn (nreverse (mapcar 'byte-optimize-form
+ backwards)))))
(cons fn (mapcar 'byte-optimize-form (cdr form)))))
((eq fn 'interactive)
(prin1-to-string form))
nil)
- ((memq fn '(defun defmacro function condition-case))
- ;; These forms are compiled as constants or by breaking out
+ ((eq fn 'function)
+ ;; This forms is compiled as constant or by breaking out
;; all the subexpressions and compiling them separately.
form)
+ ((eq fn 'condition-case)
+ (if byte-compile--use-old-handlers
+ ;; Will be optimized later.
+ form
+ `(condition-case ,(nth 1 form) ;Not evaluated.
+ ,(byte-optimize-form (nth 2 form) for-effect)
+ ,@(mapcar (lambda (clause)
+ `(,(car clause)
+ ,@(byte-optimize-body (cdr clause) for-effect)))
+ (nthcdr 3 form)))))
+
((eq fn 'unwind-protect)
;; the "protected" part of an unwind-protect is compiled (and thus
;; optimized) as a top-level form, so don't do it here. But the
(cdr (cdr form)))))
((eq fn 'catch)
- ;; the body of a catch is compiled (and thus optimized) as a
- ;; top-level form, so don't do it here. The tag is never
- ;; for-effect. The body should have the same for-effect status
- ;; as the catch form itself, but that isn't handled properly yet.
(cons fn
(cons (byte-optimize-form (nth 1 form) nil)
- (cdr (cdr form)))))
+ (if byte-compile--use-old-handlers
+ ;; The body of a catch is compiled (and thus
+ ;; optimized) as a top-level form, so don't do it
+ ;; here.
+ (cdr (cdr form))
+ (byte-optimize-body (cdr form) for-effect)))))
((eq fn 'ignore)
;; Don't treat the args to `ignore' as being
;; However, don't actually bother calling `ignore'.
`(prog1 nil . ,(mapcar 'byte-optimize-form (cdr form))))
- ((eq fn 'internal-make-closure)
- form)
-
+ ;; Needed as long as we run byte-optimize-form after cconv.
+ ((eq fn 'internal-make-closure) form)
+
+ ((byte-code-function-p fn)
+ (cons fn (mapcar #'byte-optimize-form (cdr form))))
+
((not (symbolp fn))
- (debug)
(byte-compile-warn "`%s' is a malformed function"
(prin1-to-string fn))
form)
((and for-effect (setq tmp (get fn 'side-effect-free))
(or byte-compile-delete-errors
(eq tmp 'error-free)
- ;; Detect the expansion of (pop foo).
- ;; There is no need to compile the call to `car' there.
- (and (eq fn 'car)
- (eq (car-safe (cadr form)) 'prog1)
- (let ((var (cadr (cadr form)))
- (last (nth 2 (cadr form))))
- (and (symbolp var)
- (null (nthcdr 3 (cadr form)))
- (eq (car-safe last) 'setq)
- (eq (cadr last) var)
- (eq (car-safe (nth 2 last)) 'cdr)
- (eq (cadr (nth 2 last)) var))))
(progn
(byte-compile-warn "value returned from %s is unused"
(prin1-to-string form))
(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))
(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))
(defun byte-optimize-body (forms all-for-effect)
- ;; optimize the cdr of a progn or implicit progn; all forms is a list of
+ ;; Optimize the cdr of a progn or implicit progn; all forms is a list of
;; forms, all but the last of which are optimized with the assumption that
;; they are being called for effect. the last is for-effect as well if
;; all-for-effect is true. returns a new list of forms.
(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))
(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))))
(defun byte-optimize-binary-predicate (form)
- (if (byte-compile-constp (nth 1 form))
- (if (byte-compile-constp (nth 2 form))
- (condition-case ()
- (list 'quote (eval form))
- (error form))
- ;; This can enable some lapcode optimizations.
- (list (car form) (nth 2 form) (nth 1 form)))
- form))
+ (cond
+ ((or (not (macroexp-const-p (nth 1 form)))
+ (nthcdr 3 form)) ;; In case there are more than 2 args.
+ form)
+ ((macroexp-const-p (nth 2 form))
+ (condition-case ()
+ (list 'quote (eval form))
+ (error form)))
+ (t ;; This can enable some lapcode optimizations.
+ (list (car form) (nth 2 form) (nth 1 form)))))
(defun byte-optimize-predicate (form)
(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 ()
(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)))
(let ((fn (nth 1 form)))
(if (memq (car-safe fn) '(quote function))
(cons (nth 1 fn) (cdr (cdr form)))
- form)))
+ form)))
(defun byte-optimize-apply (form)
;; If the last arg is a literal constant, turn this into a funcall.
;; 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))))
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
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
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
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)))
(put (car pure-fns) 'pure t)
(setq pure-fns (cdr pure-fns)))
nil)
-
-(defun byte-compile-splice-in-already-compiled-code (form)
- ;; form is (byte-code "..." [...] n)
- (if (not (memq byte-optimize '(t lap)))
- (byte-compile-normal-call form)
- (byte-inline-lapcode
- (byte-decompile-bytecode-1 (nth 1 form) (nth 2 form) t))))
-
-(put 'byte-code 'byte-compile 'byte-compile-splice-in-already-compiled-code)
-
\f
(defconst byte-constref-ops
'(byte-constant byte-constant2 byte-varref byte-varset byte-varbind))
;; Used and set dynamically in byte-decompile-bytecode-1.
(defvar bytedecomp-op)
(defvar bytedecomp-ptr)
-(defvar bytedecomp-bytes)
;; This function extracts the bitfields from variable-length opcodes.
;; Originally defined in disass.el (which no longer uses it.)
-(defun disassemble-offset ()
+(defun disassemble-offset (bytes)
"Don't call this!"
- ;; fetch and return the offset for the current opcode.
- ;; return nil if this opcode has no offset
- (cond ((< bytedecomp-op byte-nth)
+ ;; Fetch and return the offset for the current opcode.
+ ;; Return nil if this opcode has no offset.
+ (cond ((< bytedecomp-op byte-pophandler)
(let ((tem (logand bytedecomp-op 7)))
(setq bytedecomp-op (logand bytedecomp-op 248))
(cond ((eq tem 6)
;; Offset in next byte.
(setq bytedecomp-ptr (1+ bytedecomp-ptr))
- (aref bytedecomp-bytes bytedecomp-ptr))
+ (aref bytes bytedecomp-ptr))
((eq tem 7)
;; Offset in next 2 bytes.
(setq bytedecomp-ptr (1+ bytedecomp-ptr))
- (+ (aref bytedecomp-bytes bytedecomp-ptr)
+ (+ (aref bytes bytedecomp-ptr)
(progn (setq bytedecomp-ptr (1+ bytedecomp-ptr))
- (lsh (aref bytedecomp-bytes bytedecomp-ptr) 8))))
- (t tem)))) ;offset was in opcode
+ (lsh (aref bytes bytedecomp-ptr) 8))))
+ (t tem)))) ;Offset was in opcode.
((>= bytedecomp-op byte-constant)
- (prog1 (- bytedecomp-op byte-constant) ;offset in opcode
+ (prog1 (- bytedecomp-op byte-constant) ;Offset in opcode.
(setq bytedecomp-op byte-constant)))
((or (and (>= bytedecomp-op byte-constant2)
(<= bytedecomp-op byte-goto-if-not-nil-else-pop))
- (= bytedecomp-op byte-stack-set2))
+ (memq bytedecomp-op (eval-when-compile
+ (list byte-stack-set2 byte-pushcatch
+ byte-pushconditioncase))))
;; Offset in next 2 bytes.
(setq bytedecomp-ptr (1+ bytedecomp-ptr))
- (+ (aref bytedecomp-bytes bytedecomp-ptr)
+ (+ (aref bytes bytedecomp-ptr)
(progn (setq bytedecomp-ptr (1+ bytedecomp-ptr))
- (lsh (aref bytedecomp-bytes bytedecomp-ptr) 8))))
+ (lsh (aref bytes bytedecomp-ptr) 8))))
((and (>= bytedecomp-op byte-listN)
(<= bytedecomp-op byte-discardN))
- (setq bytedecomp-ptr (1+ bytedecomp-ptr)) ;offset in next byte
- (aref bytedecomp-bytes bytedecomp-ptr))))
+ (setq bytedecomp-ptr (1+ bytedecomp-ptr)) ;Offset in next byte.
+ (aref bytes bytedecomp-ptr))))
+(defvar byte-compile-tag-number)
;; This de-compiler is used for inline expansion of compiled functions,
;; and by the disassembler.
;; If MAKE-SPLICEABLE is nil, we are being called for the disassembler.
;; In that case, we put a pc value into the list
;; before each insn (or its label).
-(defun byte-decompile-bytecode-1 (bytedecomp-bytes constvec
- &optional make-spliceable)
- (let ((length (length bytedecomp-bytes))
- (bytedecomp-ptr 0) optr tags bytedecomp-op offset
- lap tmp
- endtag)
+(defun byte-decompile-bytecode-1 (bytes constvec &optional make-spliceable)
+ (let ((length (length bytes))
+ (bytedecomp-ptr 0) optr tags bytedecomp-op offset
+ lap tmp)
(while (not (= bytedecomp-ptr length))
(or make-spliceable
- (setq lap (cons bytedecomp-ptr lap)))
- (setq bytedecomp-op (aref bytedecomp-bytes bytedecomp-ptr)
+ (push bytedecomp-ptr lap))
+ (setq bytedecomp-op (aref bytes bytedecomp-ptr)
optr bytedecomp-ptr
- offset (disassemble-offset)) ; this does dynamic-scope magic
- (setq bytedecomp-op (aref byte-code-vector bytedecomp-op))
+ ;; This uses dynamic-scope magic.
+ offset (disassemble-offset bytes))
+ (let ((opcode (aref byte-code-vector bytedecomp-op)))
+ (cl-assert opcode)
+ (setq bytedecomp-op opcode))
(cond ((memq bytedecomp-op byte-goto-ops)
- ;; it's a pc
+ ;; It's a pc.
(setq offset
(cdr (or (assq offset tags)
- (car (setq tags
- (cons (cons offset
- (byte-compile-make-tag))
- tags)))))))
+ (let ((new (cons offset (byte-compile-make-tag))))
+ (push new tags)
+ new)))))
((cond ((eq bytedecomp-op 'byte-constant2)
(setq bytedecomp-op 'byte-constant) t)
((memq bytedecomp-op byte-constref-ops)))
offset (if (eq bytedecomp-op 'byte-constant)
(byte-compile-get-constant tmp)
(or (assq tmp byte-compile-variables)
- (car (setq byte-compile-variables
- (cons (list tmp)
- byte-compile-variables)))))))
- ((and make-spliceable
- (eq bytedecomp-op 'byte-return))
- (if (= bytedecomp-ptr (1- length))
- (setq bytedecomp-op nil)
- (setq offset (or endtag (setq endtag (byte-compile-make-tag)))
- bytedecomp-op 'byte-goto)))
+ (let ((new (list tmp)))
+ (push new byte-compile-variables)
+ new)))))
((eq bytedecomp-op 'byte-stack-set2)
(setq bytedecomp-op 'byte-stack-set))
((and (eq bytedecomp-op 'byte-discardN) (>= offset #x80))
(setq bytedecomp-op 'byte-discardN-preserve-tos)
(setq offset (- offset #x80))))
;; lap = ( [ (pc . (op . arg)) ]* )
- (setq lap (cons (cons optr (cons bytedecomp-op (or offset 0)))
- lap))
+ (push (cons optr (cons bytedecomp-op (or offset 0)))
+ lap)
(setq bytedecomp-ptr (1+ bytedecomp-ptr)))
- ;; take off the dummy nil op that we replaced a trailing "return" with.
(let ((rest lap))
(while rest
(cond ((numberp (car rest)))
((setq tmp (assq (car (car rest)) tags))
- ;; this addr is jumped to
+ ;; This addr is jumped to.
(setcdr rest (cons (cons nil (cdr tmp))
(cdr rest)))
(setq tags (delq tmp tags))
(setq rest (cdr rest))))
(setq rest (cdr rest))))
(if tags (error "optimizer error: missed tags %s" tags))
- (if (null (car (cdr (car lap))))
- (setq lap (cdr lap)))
- (if endtag
- (setq lap (cons (cons nil endtag) lap)))
- ;; remove addrs, lap = ( [ (op . arg) | (TAG tagno) ]* )
+ ;; Remove addrs, lap = ( [ (op . arg) | (TAG tagno) ]* )
(mapcar (function (lambda (elt)
(if (numberp elt)
elt
byte-cdr-safe byte-cons byte-list1 byte-list2 byte-point byte-point-max
byte-point-min byte-following-char byte-preceding-char
byte-current-column byte-eolp byte-eobp byte-bolp byte-bobp
- byte-current-buffer byte-stack-ref ;; byte-closed-var
- ))
+ byte-current-buffer byte-stack-ref))
(defconst byte-compile-side-effect-free-ops
(nconc
;; The variable `byte-boolean-vars' is now primitive and updated
;; automatically by DEFVAR_BOOL.
-(defun byte-optimize-lapcode (lap &optional for-effect)
+(defun byte-optimize-lapcode (lap &optional _for-effect)
"Simple peephole optimizer. LAP is both modified and returned.
If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
(let (lap0
;; 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)))
(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))
(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
;; it is wrong to do the same thing for the -else-pop variants.
;;
((and (eq 'byte-not (car lap0))
- (or (eq 'byte-goto-if-nil (car lap1))
- (eq 'byte-goto-if-not-nil (car lap1))))
+ (memq (car lap1) '(byte-goto-if-nil byte-goto-if-not-nil)))
(byte-compile-log-lap " not %s\t-->\t%s"
lap1
(cons
;;
;; it is wrong to do the same thing for the -else-pop variants.
;;
- ((and (or (eq 'byte-goto-if-nil (car lap0))
- (eq 'byte-goto-if-not-nil (car lap0))) ; gotoX
+ ((and (memq (car lap0)
+ '(byte-goto-if-nil byte-goto-if-not-nil)) ; gotoX
(eq 'byte-goto (car lap1)) ; gotoY
(eq (cdr lap0) lap2)) ; TAG X
(let ((inverse (if (eq 'byte-goto-if-nil (car lap0))
;; only be known when the closure will be built at
;; run-time).
(consp (cdr lap0)))
- (cond ((if (or (eq (car lap1) 'byte-goto-if-nil)
- (eq (car lap1) 'byte-goto-if-nil-else-pop))
+ (cond ((if (memq (car lap1) '(byte-goto-if-nil
+ byte-goto-if-nil-else-pop))
(car (cdr lap0))
(not (car (cdr lap0))))
(byte-compile-log-lap " %s %s\t-->\t<deleted>"
(setq lap0 (car rest)
lap1 (nth 1 rest))
(if (memq (car lap0) byte-constref-ops)
- (if (or (eq (car lap0) 'byte-constant)
- (eq (car lap0) 'byte-constant2))
+ (if (memq (car lap0) '(byte-constant byte-constant2))
(unless (memq (cdr lap0) byte-compile-constants)
(setq byte-compile-constants (cons (cdr lap0)
byte-compile-constants)))
(+ (cdr lap0) (cdr lap1))))
(setq lap (delq lap0 lap))
(setcdr lap1 (+ (cdr lap1) (cdr lap0))))
-
+
;;
;; stack-set-M [discard/discardN ...] --> discardN-preserve-tos
;; stack-set-M [discard/discardN ...] --> discardN
(setq lap (delq lap0 lap))
(setcar lap1
(if (= tmp2 tmp3)
- ;; The value stored is the new TOS, so pop
- ;; one more value (to get rid of the old
- ;; value) using the TOS-preserving
- ;; discard operator.
+ ;; The value stored is the new TOS, so pop one more
+ ;; value (to get rid of the old value) using the
+ ;; TOS-preserving discard operator.
'byte-discardN-preserve-tos
;; Otherwise, the value stored is lost, so just use a
;; normal discard.
;; discardN-(X+Y)
;;
((and (memq (car lap0)
- '(byte-discard
- byte-discardN
+ '(byte-discard byte-discardN
byte-discardN-preserve-tos))
(memq (car lap1) '(byte-discard byte-discardN)))
(setq lap (delq lap0 lap))