-;;; 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-2012 Free Software Foundation, Inc.
;; Author: Jamie Zawinski <jwz@lucid.com>
;; Hallvard Furuseth <hbf@ulrik.uio.no>
;; 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.
;;
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 (and (fboundp name) (symbol-function name)))))
+ (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)))))
+ (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 (and `(lambda ,args . ,body) (let env nil))
+ `(closure ,env ,args . ,body))
+ (if (not (or (eq fn localfn) ;From the same file => same mode.
+ (eq (not lexical-binding) (not env)))) ;Same mode.
+ ;; 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.
+ ;; FIXME: we could of course byte-compile the inlined function
+ ;; first, and then inline its byte-code.
+ form
+ (let ((renv ()))
+ ;; Turn the function's closed vars (if any) into local let bindings.
+ (dolist (binding env)
+ (cond
+ ((consp binding)
+ ;; We check shadowing by the args, so that the `let' can be
+ ;; moved within the lambda, which can then be unfolded.
+ ;; FIXME: Some of those bindings might be unused in `body'.
+ (unless (memq (car binding) args) ;Shadowed.
+ (push `(,(car binding) ',(cdr binding)) renv)))
+ ((eq binding t))
+ (t (push `(defvar ,binding) body))))
+ (let ((newfn (if (eq fn localfn)
+ ;; If `fn' is from the same file, it has already
+ ;; been preprocessed!
+ `(function ,fn)
+ (byte-compile-preprocess
+ (if (null renv)
+ `(lambda ,args ,@body)
+ `(lambda ,args (let ,(nreverse renv) ,@body)))))))
+ (if (eq (car-safe newfn) 'function)
+ (byte-compile-unfold-lambda `(,(cadr newfn) ,@(cdr form)))
+ (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). 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
(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))
+ ((memq fn '(function condition-case))
;; These forms are compiled as constants or by breaking out
;; all the subexpressions and compiling them separately.
form)
;; However, don't actually bother calling `ignore'.
`(prog1 nil . ,(mapcar 'byte-optimize-form (cdr 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))
(byte-compile-warn "`%s' is a malformed function"
(prin1-to-string fn))
(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.
(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.
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
(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
+ ;; Fetch and return the offset for the current opcode.
+ ;; Return nil if this opcode has no offset.
(cond ((< bytedecomp-op byte-nth)
(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))
;; 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)))
+ (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
;; 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)))
;; 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))
;; const goto-if-* --> whatever
;;
((and (eq 'byte-constant (car lap0))
- (memq (car lap1) byte-conditional-ops))
- (cond ((if (or (eq (car lap1) 'byte-goto-if-nil)
- (eq (car lap1) 'byte-goto-if-nil-else-pop))
- (car (cdr lap0))
- (not (car (cdr lap0))))
+ (memq (car lap1) byte-conditional-ops)
+ ;; If the `byte-constant's cdr is not a cons cell, it has
+ ;; to be an index into the constant pool); even though
+ ;; it'll be a constant, that constant is not known yet
+ ;; (it's typically a free variable of a closure, so will
+ ;; only be known when the closure will be built at
+ ;; run-time).
+ (consp (cdr lap0)))
+ (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>"
lap0 lap1)
(setq rest (cdr rest)
(when (memq (car lap1) byte-goto-always-pop-ops)
(setq lap (delq lap0 lap)))
(setcar lap1 'byte-goto)))
- (setq keep-going t))
+ (setq keep-going t))
;;
;; varref-X varref-X --> varref-X dup
;; varref-X [dup ...] varref-X --> varref-X [dup ...] dup
- ;; stackref-X [dup ...] stackref-X+N --> stackref-X [dup ...] dup
+ ;; stackref-X [dup ...] stackref-X+N --> stackref-X [dup ...] dup
;; We don't optimize the const-X variations on this here,
;; because that would inhibit some goto optimizations; we
;; optimize the const-X case after all other optimizations.
(cons 'byte-discard byte-conditional-ops)))
(not (eq lap1 (car tmp))))
(setq tmp2 (car tmp))
- (cond ((memq (car tmp2)
- (if (null (car (cdr lap0)))
- '(byte-goto-if-nil byte-goto-if-nil-else-pop)
- '(byte-goto-if-not-nil
- byte-goto-if-not-nil-else-pop)))
+ (cond ((when (consp (cdr lap0))
+ (memq (car tmp2)
+ (if (null (car (cdr lap0)))
+ '(byte-goto-if-nil byte-goto-if-nil-else-pop)
+ '(byte-goto-if-not-nil
+ byte-goto-if-not-nil-else-pop))))
(byte-compile-log-lap " %s goto [%s]\t-->\t%s %s"
lap0 tmp2 lap0 tmp2)
(setcar lap1 (car tmp2))
(setcdr lap1 (cdr tmp2))
;; Let next step fix the (const,goto-if*) sequence.
- (setq rest (cons nil rest)))
- (t
+ (setq rest (cons nil rest))
+ (setq keep-going t))
+ ((or (consp (cdr lap0))
+ (eq (car tmp2) 'byte-discard))
;; Jump one step further
(byte-compile-log-lap
" %s goto [%s]\t-->\t<deleted> goto <skip>"
(setcdr tmp (cons (byte-compile-make-tag)
(cdr tmp))))
(setcdr lap1 (car (cdr tmp)))
- (setq lap (delq lap0 lap))))
- (setq keep-going t))
+ (setq lap (delq lap0 lap))
+ (setq keep-going t))))
;;
;; X: varref-Y ... varset-Y goto-X -->
;; X: varref-Y Z: ... dup varset-Y goto-Z
(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))
HCoop / bpt / emacs.git / blobdiff