;;; 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))
(localfn (cdr (assq name byte-compile-function-environment)))
(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))))
- ((and (pred byte-code-function-p)
- ;; FIXME: This only works to inline old-style-byte-codes into
- ;; old-style-byte-codes.
- (guard (not (or lexical-binding
- (integerp (aref fn 0))))))
- ;; (message "Inlining %S byte-code" name)
- (fetch-bytecode fn)
- (let ((string (aref fn 1)))
- (assert (not (multibyte-string-p 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))))
- ((and `(lambda . ,_)
- ;; With lexical-binding we have several problems:
- ;; - if `fn' comes from byte-compile-function-environment, we
- ;; need to preprocess `fn', so we handle it below.
- ;; - else, it means that `fn' is dyn-bound (otherwise it would
- ;; start with `closure') so copying the code here would cause
- ;; it to be mis-interpreted.
- (guard (not lexical-binding)))
- (macroexpand-all (cons fn (cdr form))
- byte-compile-macro-environment))
- ((and (or (and `(lambda ,args . ,body)
- (let env nil)
- (guard (eq fn localfn)))
- `(closure ,env ,args . ,body))
- (guard lexical-binding))
- (let ((renv ()))
- (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))))
- ;; (message "Inlining closure %S" (car form))
- (let ((newfn (byte-compile-preprocess
- `(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))))
+ ((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))))
(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
(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))))
- ;; Neeeded as long as we run byte-optimize-form after cconv.
+ ;; 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)
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))
;; In that case, we put a pc value into the list
;; before each insn (or its label).
(defun byte-decompile-bytecode-1 (bytes constvec &optional make-spliceable)
- (let ((bytedecomp-bytes bytes)
- (length (length bytes))
+ (let ((length (length bytes))
(bytedecomp-ptr 0) optr tags bytedecomp-op offset
- lap tmp
- endtag)
+ lap tmp)
(while (not (= bytedecomp-ptr length))
(or make-spliceable
(push bytedecomp-ptr lap))
- (setq bytedecomp-op (aref bytedecomp-bytes bytedecomp-ptr)
+ (setq bytedecomp-op (aref bytes bytedecomp-ptr)
optr bytedecomp-ptr
;; This uses dynamic-scope magic.
- offset (disassemble-offset bytedecomp-bytes))
- (setq bytedecomp-op (aref byte-code-vector bytedecomp-op))
+ 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.
(setq offset
(let ((new (list tmp)))
(push new byte-compile-variables)
new)))))
- ((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)))
((eq bytedecomp-op 'byte-stack-set2)
(setq bytedecomp-op 'byte-stack-set))
((and (eq bytedecomp-op 'byte-discardN) (>= offset #x80))
(setq rest (cdr rest))))
(setq rest (cdr rest))))
(if tags (error "optimizer error: missed tags %s" tags))
- ;; Take off the dummy nil op that we replaced a trailing "return" with.
- (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) ]* )
(mapcar (function (lambda (elt)
(if (numberp 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
;; 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)))
(+ (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