diff options
Diffstat (limited to 'lisp/emacs-lisp/byte-opt.el')
| -rw-r--r-- | lisp/emacs-lisp/byte-opt.el | 142 |
1 files changed, 45 insertions, 97 deletions
diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 6a04dfb2507..35c9a5ddf45 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -244,25 +244,6 @@ 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))) @@ -280,54 +261,42 @@ (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 (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)))) @@ -341,10 +310,6 @@ (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 @@ -353,6 +318,7 @@ (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... @@ -430,8 +396,7 @@ (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 @@ -564,7 +529,10 @@ ;; Neeeded 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" @@ -1328,16 +1296,6 @@ (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) - (defconst byte-constref-ops '(byte-constant byte-constant2 byte-varref byte-varset byte-varbind)) @@ -1405,18 +1363,17 @@ ;; 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) (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)) + offset (disassemble-offset bytes)) (setq bytedecomp-op (aref byte-code-vector bytedecomp-op)) (cond ((memq bytedecomp-op byte-goto-ops) ;; It's a pc. @@ -1437,12 +1394,6 @@ (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)) @@ -1467,9 +1418,6 @@ (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) ]* ) |