From 3e21b6a72b87787e2327513a44623b250054f77d Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Mon, 21 Feb 2011 15:12:44 -0500 Subject: [PATCH] Use offsets relative to top rather than bottom for stack refs * lisp/emacs-lisp/byte-opt.el (byte-compile-side-effect-and-error-free-ops): Remove interactive-p. (byte-optimize-lapcode): Update optimizations now that stack-refs are relative to the top rather than to the bottom. * lisp/emacs-lisp/bytecomp.el (byte-compile-lapcode): Turn stack-ref-0 into dup. (byte-compile-form): Don't indirect-function since it can signal errors. (byte-compile-stack-ref, byte-compile-stack-set): Adjust to stack-refs being relative to top rather than to bottom in the byte-code. (with-output-to-temp-buffer): Remove. (byte-compile-with-output-to-temp-buffer): Remove. * lisp/emacs-lisp/cconv.el: Use lexical-binding. (cconv--lookup-let): Rename from cconv-lookup-let. (cconv-closure-convert-rec): Fix handling of captured+mutated arguments in defun/defmacro. * lisp/emacs-lisp/eieio-comp.el (eieio-byte-compile-file-form-defmethod): Rename from byte-compile-file-form-defmethod. Don't byte-compile-lambda. (eieio-byte-compile-defmethod-param-convert): Rename from byte-compile-defmethod-param-convert. * lisp/emacs-lisp/eieio.el (eieio-defgeneric-form-primary-only-one): Call byte-compile rather than byte-compile-lambda. * src/alloc.c (Fgarbage_collect): Don't mark the byte-stack redundantly. * src/bytecode.c (exec_byte_code): Change stack_ref and stack_set to use offsets relative to top rather than to bottom. * lisp/subr.el (with-output-to-temp-buffer): New macro. * lisp/simple.el (count-words-region): Don't use interactive-p. --- lisp/ChangeLog | 39 ++++++++++ lisp/emacs-lisp/byte-opt.el | 143 ++++++++++++++++------------------ lisp/emacs-lisp/bytecomp.el | 34 ++++---- lisp/emacs-lisp/cconv.el | 45 ++++++----- lisp/emacs-lisp/eieio-comp.el | 11 ++- lisp/emacs-lisp/eieio.el | 17 ++-- lisp/simple.el | 3 +- lisp/subr.el | 51 ++++++++++-- src/ChangeLog | 7 ++ src/alloc.c | 2 +- src/bytecode.c | 52 ++++++++----- src/print.c | 57 +------------- src/window.c | 12 ++- 13 files changed, 263 insertions(+), 210 deletions(-) diff --git a/lisp/ChangeLog b/lisp/ChangeLog index ae91513937..4e2e87ab60 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,42 @@ +2011-02-21 Stefan Monnier + + * subr.el (with-output-to-temp-buffer): New macro. + + * simple.el (count-words-region): Don't use interactive-p. + + * minibuffer.el: Use lexical-binding. Replace all uses of lexical-let. + + * emacs-lisp/eieio.el (eieio-defgeneric-form-primary-only-one): + Call byte-compile rather than byte-compile-lambda. + + * emacs-lisp/eieio-comp.el (eieio-byte-compile-file-form-defmethod): + Rename from byte-compile-file-form-defmethod. + Don't byte-compile-lambda. + (eieio-byte-compile-defmethod-param-convert): Rename from + byte-compile-defmethod-param-convert. + + * emacs-lisp/cl-extra.el (cl-macroexpand-all): Don't assume that the + value of (function (lambda ...)) is self-quoting. + + * emacs-lisp/cconv.el: Use lexical-binding. + (cconv--lookup-let): Rename from cconv-lookup-let. + (cconv-closure-convert-rec): Fix handling of captured+mutated + arguments in defun/defmacro. + + * emacs-lisp/bytecomp.el (byte-compile-lapcode): + Turn stack-ref-0 into dup. + (byte-compile-form): Don't indirect-function since it can signal + errors. + (byte-compile-stack-ref, byte-compile-stack-set): Adjust to stack-refs + being relative to top rather than to bottom in the byte-code. + (with-output-to-temp-buffer): Remove. + (byte-compile-with-output-to-temp-buffer): Remove. + + * emacs-lisp/byte-opt.el (byte-compile-side-effect-and-error-free-ops): + Remove interactive-p. + (byte-optimize-lapcode): Update optimizations now that stack-refs are + relative to the top rather than to the bottom. + 2011-02-19 Stefan Monnier * subr.el (save-window-excursion): New macro, moved from C. diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 038db29235..e415b5edde 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -1470,7 +1470,7 @@ 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-interactive-p byte-stack-ref)) + byte-current-buffer byte-stack-ref)) (defconst byte-compile-side-effect-free-ops (nconc @@ -1628,14 +1628,15 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." ;; const/dup varbind-X varref-X --> const/dup varbind-X const/dup ;; The latter two can enable other optimizations. ;; - ((or (and (eq 'byte-varref (car lap2)) - (eq (cdr lap1) (cdr lap2)) - (memq (car lap1) '(byte-varset byte-varbind))) - (and (eq (car lap2) 'byte-stack-ref) - (eq (car lap1) 'byte-stack-set) - (eq (cdr lap1) (cdr lap2)))) - (if (and (eq 'byte-varref (car lap2)) - (setq tmp (memq (car (cdr lap2)) byte-boolean-vars)) + ;; For lexical variables, we could do the same + ;; 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. + ((and (eq 'byte-varref (car lap2)) + (eq (cdr lap1) (cdr lap2)) + (memq (car lap1) '(byte-varset byte-varbind))) + (if (and (setq tmp (memq (car (cdr lap2)) byte-boolean-vars)) (not (eq (car lap0) 'byte-constant))) nil (setq keep-going t) @@ -1663,15 +1664,18 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." ;; ;; dup varset-X discard --> varset-X ;; dup varbind-X discard --> varbind-X + ;; dup stack-set-X discard --> stack-set-X-1 ;; (the varbind variant can emerge from other optimizations) ;; ((and (eq 'byte-dup (car lap0)) (eq 'byte-discard (car lap2)) - (memq (car lap1) '(byte-varset byte-varbind byte-stack-set))) + (memq (car lap1) '(byte-varset byte-varbind + byte-stack-set))) (byte-compile-log-lap " dup %s discard\t-->\t%s" lap1 lap1) (setq keep-going t rest (cdr rest) stack-adjust -1) + (if (eq 'byte-stack-set (car lap1)) (decf (cdr lap1))) (setq lap (delq lap0 (delq lap2 lap)))) ;; ;; not goto-X-if-nil --> goto-X-if-non-nil @@ -1739,18 +1743,24 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." ;; ;; 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 ;; 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. ;; ((and (memq (car lap0) '(byte-varref byte-stack-ref)) (progn - (setq tmp (cdr rest) tmp2 0) + (setq tmp (cdr rest)) + (setq tmp2 0) (while (eq (car (car tmp)) 'byte-dup) - (setq tmp (cdr tmp) tmp2 (1+ tmp2))) + (setq tmp2 (1+ tmp2)) + (setq tmp (cdr tmp))) t) - (eq (car lap0) (car (car tmp))) - (eq (cdr lap0) (cdr (car tmp)))) + (eq (if (eq 'byte-stack-ref (car lap0)) + (+ tmp2 1 (cdr lap0)) + (cdr lap0)) + (cdr (car tmp))) + (eq (car lap0) (car (car tmp)))) (if (memq byte-optimize-log '(t byte)) (let ((str "")) (setq tmp2 (cdr rest)) @@ -1857,14 +1867,6 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." "")) (setq keep-going t)) ;; - ;; stack-ref-N --> dup ; where N is TOS - ;; - ((and stack-depth (eq (car lap0) 'byte-stack-ref) - (= (cdr lap0) (1- stack-depth))) - (setcar lap0 'byte-dup) - (setcdr lap0 nil) - (setq keep-going t)) - ;; ;; goto*-X ... X: goto-Y --> goto*-Y ;; goto-X ... X: return --> return ;; @@ -1948,12 +1950,19 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." ;; X: varref-Y Z: ... dup varset-Y goto-Z ;; (varset-X goto-BACK, BACK: varref-X --> copy the varref down.) ;; (This is so usual for while loops that it is worth handling). + ;; + ;; Here again, we could do it for stack-ref/stack-set, but + ;; that's replacing a stack-ref-Y with a stack-ref-0, which + ;; is a very minor improvement (if any), at the cost of + ;; more stack use and more byte-code. Let's not do it. ;; - ((and (memq (car lap1) '(byte-varset byte-stack-set)) + ((and (eq (car lap1) 'byte-varset) (eq (car lap2) 'byte-goto) (not (memq (cdr lap2) rest)) ;Backwards jump (eq (car (car (setq tmp (cdr (memq (cdr lap2) lap))))) - (if (eq (car lap1) 'byte-varset) 'byte-varref 'byte-stack-ref)) + (if (eq (car lap1) 'byte-varset) 'byte-varref + ;; 'byte-stack-ref + )) (eq (cdr (car tmp)) (cdr lap1)) (not (and (eq (car lap1) 'byte-varref) (memq (car (cdr lap1)) byte-boolean-vars)))) @@ -2026,7 +2035,7 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." ;; Rebuild byte-compile-constants / byte-compile-variables. ;; Simple optimizations that would inhibit other optimizations if they ;; were done in the optimizing loop, and optimizations which there is no - ;; need to do more than once. + ;; need to do more than once. (setq byte-compile-constants nil byte-compile-variables nil) (setq rest lap @@ -2089,38 +2098,38 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." ;; stack-set-M [discard/discardN ...] --> discardN-preserve-tos ;; stack-set-M [discard/discardN ...] --> discardN ;; - ((and stack-depth ;Make sure we know the stack depth. - (eq (car lap0) 'byte-stack-set) - (memq (car lap1) '(byte-discard byte-discardN)) - (progn - ;; See if enough discard operations follow to expose or - ;; destroy the value stored by the stack-set. - (setq tmp (cdr rest)) - (setq tmp2 (- stack-depth 2 (cdr lap0))) - (setq tmp3 0) - (while (memq (car (car tmp)) '(byte-discard byte-discardN)) - (if (eq (car (car tmp)) 'byte-discard) - (setq tmp3 (1+ tmp3)) - (setq tmp3 (+ tmp3 (cdr (car tmp))))) - (setq tmp (cdr tmp))) - (>= tmp3 tmp2))) - ;; Do the optimization + ((and (eq (car lap0) 'byte-stack-set) + (memq (car lap1) '(byte-discard byte-discardN)) + (progn + ;; See if enough discard operations follow to expose or + ;; destroy the value stored by the stack-set. + (setq tmp (cdr rest)) + (setq tmp2 (1- (cdr lap0))) + (setq tmp3 0) + (while (memq (car (car tmp)) '(byte-discard byte-discardN)) + (setq tmp3 + (+ tmp3 (if (eq (car (car tmp)) 'byte-discard) + 1 + (cdr (car tmp))))) + (setq tmp (cdr tmp))) + (>= tmp3 tmp2))) + ;; Do the optimization. (setq lap (delq lap0 lap)) - (cond ((= 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. - (setcar lap1 'byte-discardN-preserve-tos) - (setcdr lap1 (1+ tmp3))) - (t - ;; Otherwise, the value stored is lost, so just use a - ;; normal discard. - (setcar lap1 'byte-discardN) - (setcdr lap1 tmp3))) + (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. + 'byte-discardN-preserve-tos + ;; Otherwise, the value stored is lost, so just use a + ;; normal discard. + 'byte-discardN)) + (setcdr lap1 (1+ tmp3)) (setcdr (cdr rest) tmp) (setq stack-adjust 0) (byte-compile-log-lap " %s [discard/discardN]...\t-->\t%s" - lap0 lap1)) + lap0 lap1)) ;; ;; discard/discardN/discardN-preserve-tos-X discard/discardN-Y --> @@ -2158,30 +2167,16 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." ;; dup return --> return ;; stack-set-N return --> return ; where N is TOS-1 ;; - ((and stack-depth ;Make sure we know the stack depth. - (eq (car lap1) 'byte-return) - (or (memq (car lap0) '(byte-discardN-preserve-tos byte-dup)) - (and (eq (car lap0) 'byte-stack-set) - (= (cdr lap0) (- stack-depth 2))))) - ;; the byte-code interpreter will pop the stack for us, so - ;; we can just leave stuff on it + ((and (eq (car lap1) 'byte-return) + (or (memq (car lap0) '(byte-discardN-preserve-tos byte-dup)) + (and (eq (car lap0) 'byte-stack-set) + (= (cdr lap0) 1)))) + ;; The byte-code interpreter will pop the stack for us, so + ;; we can just leave stuff on it. (setq lap (delq lap0 lap)) (setq stack-adjust 0) (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 lap1)) - - ;; - ;; dup stack-set-N return --> return ; where N is TOS - ;; - ((and stack-depth ;Make sure we know the stack depth. - (eq (car lap0) 'byte-dup) - (eq (car lap1) 'byte-stack-set) - (eq (car (car (cdr (cdr rest)))) 'byte-return) - (= (cdr lap1) (1- stack-depth))) - (setq lap (delq lap0 (delq lap1 lap))) - (setq rest (cdr rest)) - (setq stack-adjust 0) - (byte-compile-log-lap " dup %s return\t-->\treturn" lap1)) - ) + ) (setq stack-depth (and stack-depth stack-adjust (+ stack-depth stack-adjust))) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 54a1912169..8892a27b29 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -636,13 +636,13 @@ otherwise pop it") ;; Takes, on stack, the buffer name. ;; Binds standard-output and does some other things. ;; Returns with temp buffer on the stack in place of buffer name. -(byte-defop 144 0 byte-temp-output-buffer-setup) +;; (byte-defop 144 0 byte-temp-output-buffer-setup) ;; For exit from with-output-to-temp-buffer. ;; Expects the temp buffer on the stack underneath value to return. ;; Pops them both, then pushes the value back on. ;; Unbinds standard-output and makes the temp buffer visible. -(byte-defop 145 -1 byte-temp-output-buffer-show) +;; (byte-defop 145 -1 byte-temp-output-buffer-show) ;; these ops are new to v19 @@ -826,6 +826,10 @@ CONST2 may be evaulated multiple times." ((null off) ;; opcode that doesn't use OFF (byte-compile-push-bytecodes opcode bytes pc)) + ((and (eq opcode byte-stack-ref) (eq off 0)) + ;; (stack-ref 0) is really just another name for `dup'. + (debug) ;FIXME: When would this happen? + (byte-compile-push-bytecodes byte-dup bytes pc)) ;; The following three cases are for the special ;; insns that encode their operand into 0, 1, or 2 ;; extra bytes depending on its magnitude. @@ -2530,13 +2534,13 @@ If FORM is a lambda or a macro, byte-compile it as a function." (if macro (setq fun (cdr fun))) (cond ((eq (car-safe fun) 'lambda) - ;; expand macros + ;; Expand macros. (setq fun (macroexpand-all fun byte-compile-initial-macro-environment)) (if lexical-binding (setq fun (cconv-closure-convert fun))) - ;; get rid of the `function' quote added by the `lambda' macro + ;; Get rid of the `function' quote added by the `lambda' macro. (setq fun (cadr fun)) (setq fun (if macro (cons 'macro (byte-compile-lambda fun)) @@ -2953,7 +2957,7 @@ That command is designed for interactive use only" bytecomp-fn)) (byte-compile-nogroup-warn form)) (byte-compile-callargs-warn form)) (if (and (fboundp (car form)) - (eq (car-safe (indirect-function (car form))) 'macro)) + (eq (car-safe (symbol-function (car form))) 'macro)) (byte-compile-report-error (format "Forgot to expand macro %s" (car form)))) (if (and bytecomp-handler @@ -3324,15 +3328,16 @@ discarding." (defun byte-compile-stack-ref (stack-pos) "Output byte codes to push the value at position STACK-POS in the stack, on the top of the stack." - (if (= byte-compile-depth (1+ stack-pos)) - ;; A simple optimization - (byte-compile-out 'byte-dup) - ;; normal case - (byte-compile-out 'byte-stack-ref stack-pos))) + (let ((dist (- byte-compile-depth (1+ stack-pos)))) + (if (zerop dist) + ;; A simple optimization + (byte-compile-out 'byte-dup) + ;; normal case + (byte-compile-out 'byte-stack-ref dist)))) (defun byte-compile-stack-set (stack-pos) "Output byte codes to store the top-of-stack value at position STACK-POS in the stack." - (byte-compile-out 'byte-stack-set stack-pos)) + (byte-compile-out 'byte-stack-set (- byte-compile-depth (1+ stack-pos)))) ;; Compile a function that accepts one or more args and is right-associative. @@ -3946,7 +3951,6 @@ binding slots have been popped." (byte-defop-compiler-1 save-excursion) (byte-defop-compiler-1 save-current-buffer) (byte-defop-compiler-1 save-restriction) -(byte-defop-compiler-1 with-output-to-temp-buffer) (byte-defop-compiler-1 track-mouse) (defun byte-compile-catch (form) @@ -4045,12 +4049,6 @@ binding slots have been popped." (byte-compile-out 'byte-save-current-buffer 0) (byte-compile-body-do-effect (cdr form)) (byte-compile-out 'byte-unbind 1)) - -(defun byte-compile-with-output-to-temp-buffer (form) - (byte-compile-form (car (cdr form))) - (byte-compile-out 'byte-temp-output-buffer-setup 0) - (byte-compile-body (cdr (cdr form))) - (byte-compile-out 'byte-temp-output-buffer-show 0)) ;;; top-level forms elsewhere diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el index 4e42e9f3c1..66e5051c2f 100644 --- a/lisp/emacs-lisp/cconv.el +++ b/lisp/emacs-lisp/cconv.el @@ -1,4 +1,4 @@ -;;; cconv.el --- Closure conversion for statically scoped Emacs lisp. -*- lexical-binding: nil -*- +;;; cconv.el --- Closure conversion for statically scoped Emacs lisp. -*- lexical-binding: t -*- ;; Copyright (C) 2011 Free Software Foundation, Inc. @@ -71,13 +71,17 @@ ;;; Code: ;;; TODO: +;; - Change new byte-code representation, so it directly gives the +;; number of mandatory and optional arguments as well as whether or +;; not there's a &rest arg. ;; - Use abstract `make-closure' and `closure-ref' expressions, which bytecomp ;; should turn into building corresponding byte-code function. ;; - don't use `curry', instead build a new compiled-byte-code object ;; (merge the closure env into the static constants pool). -;; - use relative addresses for byte-code-stack-ref. ;; - warn about unused lexical vars. ;; - clean up cconv-closure-convert-rec, especially the `let' binding part. +;; - new byte codes for unwind-protect, catch, and condition-case so that +;; closures aren't needed at all. (eval-when-compile (require 'cl)) @@ -215,7 +219,7 @@ Returns a form where all lambdas don't have any free variables." '() ))) -(defun cconv-lookup-let (table var binder form) +(defun cconv--lookup-let (table var binder form) (let ((res nil)) (dolist (elem table) (when (and (eq (nth 2 elem) binder) @@ -312,7 +316,7 @@ Returns a form where all lambdas don't have any free variables." (new-val (cond ;; Check if var is a candidate for lambda lifting. - ((cconv-lookup-let cconv-lambda-candidates var binder form) + ((cconv--lookup-let cconv-lambda-candidates var binder form) (let* ((fv (delete-dups (cconv-freevars value '()))) (funargs (cadr (cadr value))) @@ -341,7 +345,7 @@ Returns a form where all lambdas don't have any free variables." ,(reverse funcbodies-new)))))))) ;; Check if it needs to be turned into a "ref-cell". - ((cconv-lookup-let cconv-captured+mutated var binder form) + ((cconv--lookup-let cconv-captured+mutated var binder form) ;; Declared variable is mutated and captured. (prog1 `(list ,(cconv-closure-convert-rec @@ -478,9 +482,9 @@ Returns a form where all lambdas don't have any free variables." (cons 'cond (reverse cond-forms-new)))) - (`(quote . ,_) form) ; quote form + (`(quote . ,_) form) - (`(function . ((lambda ,vars . ,body-forms))) ; function form + (`(function (lambda ,vars . ,body-forms)) ; function form (let* ((fvrs-new (cconv--set-diff fvrs vars)) ; Remove vars from fvrs. (fv (delete-dups (cconv-freevars form '()))) (leave fvrs-new) ; leave=non-nil if we should leave env unchanged. @@ -493,8 +497,8 @@ Returns a form where all lambdas don't have any free variables." ;; If outer closure contains all ;; free variables of this function(and nothing else) ;; then we use the same environment vector as for outer closure, - ;; i.e. we leave the environment vector unchanged - ;; otherwise we build a new environmet vector + ;; i.e. we leave the environment vector unchanged, + ;; otherwise we build a new environment vector. (if (eq (length envs) (length fv)) (let ((fv-temp fv)) (while (and fv-temp leave) @@ -552,7 +556,7 @@ Returns a form where all lambdas don't have any free variables." (function (lambda (,cconv--env-var . ,vars) . ,body-forms-new)) (vector . ,envector)))))) - (`(function . ,_) form) ; same as quote + (`(function . ,_) form) ; Same as quote. ;defconst, defvar (`(,(and sym (or `defconst `defvar)) ,definedsymbol . ,body-forms) @@ -568,23 +572,23 @@ Returns a form where all lambdas don't have any free variables." ;defun, defmacro (`(,(and sym (or `defun `defmacro)) ,func ,vars . ,body-forms) - (let ((body-new '()) ; the whole body - (body-forms-new '()) ; body w\o docstring and interactive + (let ((body-new '()) ; The whole body. + (body-forms-new '()) ; Body w\o docstring and interactive. (letbind '())) - ; find mutable arguments - (let ((lmutated cconv-captured+mutated) ismutated) - (dolist (elm vars) - (setq ismutated nil) + ; Find mutable arguments. + (dolist (elm vars) + (let ((lmutated cconv-captured+mutated) + (ismutated nil)) (while (and lmutated (not ismutated)) (when (and (eq (caar lmutated) elm) - (eq (cadar lmutated) form)) + (eq (caddar lmutated) form)) (setq ismutated t)) (setq lmutated (cdr lmutated))) (when ismutated (push elm letbind) (push elm emvrs)))) - ;transform body-forms - (when (stringp (car body-forms)) ; treat docstring well + ;Transform body-forms. + (when (stringp (car body-forms)) ; Treat docstring well. (push (car body-forms) body-new) (setq body-forms (cdr body-forms))) (when (eq (car-safe (car body-forms)) 'interactive) @@ -601,7 +605,7 @@ Returns a form where all lambdas don't have any free variables." (setq body-forms-new (reverse body-forms-new)) (if letbind - ; letbind mutable arguments + ; Letbind mutable arguments. (let ((binders-new '())) (dolist (elm letbind) (push `(,elm (list ,elm)) binders-new)) @@ -655,6 +659,7 @@ Returns a form where all lambdas don't have any free variables." (push `(setcar ,sym-new ,value) prognlist) (if (symbolp sym-new) (push `(setq ,sym-new ,value) prognlist) + (debug) ;FIXME: When can this be right? (push `(set ,sym-new ,value) prognlist))) (setq forms (cddr forms))) (if (cdr prognlist) diff --git a/lisp/emacs-lisp/eieio-comp.el b/lisp/emacs-lisp/eieio-comp.el index ed6fb6f1c4..244c431842 100644 --- a/lisp/emacs-lisp/eieio-comp.el +++ b/lisp/emacs-lisp/eieio-comp.el @@ -45,9 +45,9 @@ ) ;; This teaches the byte compiler how to do this sort of thing. -(put 'defmethod 'byte-hunk-handler 'byte-compile-file-form-defmethod) +(put 'defmethod 'byte-hunk-handler 'eieio-byte-compile-file-form-defmethod) -(defun byte-compile-file-form-defmethod (form) +(defun eieio-byte-compile-file-form-defmethod (form) "Mumble about the method we are compiling. This function is mostly ripped from `byte-compile-file-form-defun', but it's been modified to handle the special syntax of the `defmethod' @@ -74,7 +74,7 @@ that is called but rarely. Argument FORM is the body of the method." ":static ") (t "")))) (params (car form)) - (lamparams (byte-compile-defmethod-param-convert params)) + (lamparams (eieio-byte-compile-defmethod-param-convert params)) (arg1 (car params)) (class (if (listp arg1) (nth 1 arg1) nil)) (my-outbuffer (if (eval-when-compile (featurep 'xemacs)) @@ -98,6 +98,9 @@ that is called but rarely. Argument FORM is the body of the method." ;; Byte compile the body. For the byte compiled forms, add the ;; rest arguments, which will get ignored by the engine which will ;; add them later (I hope) + ;; FIXME: This relies on compiler's internal. Make sure it still + ;; works with lexical-binding code. Maybe calling `byte-compile' + ;; would be preferable. (let* ((new-one (byte-compile-lambda (append (list 'lambda lamparams) (cdr form)))) @@ -125,7 +128,7 @@ that is called but rarely. Argument FORM is the body of the method." ;; nil prevents cruft from appearing in the output buffer. nil)) -(defun byte-compile-defmethod-param-convert (paramlist) +(defun eieio-byte-compile-defmethod-param-convert (paramlist) "Convert method params into the params used by the `defmethod' thingy. Argument PARAMLIST is the parameter list to convert." (let ((argfix nil)) diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el index d958bfbd45..82c0e1319f 100644 --- a/lisp/emacs-lisp/eieio.el +++ b/lisp/emacs-lisp/eieio.el @@ -182,9 +182,9 @@ Stored outright without modifications or stripping.") )) ;; How to specialty compile stuff. -(autoload 'byte-compile-file-form-defmethod "eieio-comp" +(autoload 'eieio-byte-compile-file-form-defmethod "eieio-comp" "This function is used to byte compile methods in a nice way.") -(put 'defmethod 'byte-hunk-handler 'byte-compile-file-form-defmethod) +(put 'defmethod 'byte-hunk-handler 'eieio-byte-compile-file-form-defmethod) ;;; Important macros used in eieio. ;; @@ -1192,10 +1192,8 @@ IMPL is the symbol holding the method implementation." ;; is faster to execute this for not byte-compiled. ie, install this, ;; then measure calls going through here. I wonder why. (require 'bytecomp) - (let ((byte-compile-free-references nil) - (byte-compile-warnings nil) - ) - (byte-compile-lambda + (let ((byte-compile-warnings nil)) + (byte-compile `(lambda (&rest local-args) ,doc-string ;; This is a cool cheat. Usually we need to look up in the @@ -1205,7 +1203,8 @@ IMPL is the symbol holding the method implementation." ;; of that one implementation, then clearly, there is no method def. (if (not (eieio-object-p (car local-args))) ;; Not an object. Just signal. - (signal 'no-method-definition (list ,(list 'quote method) local-args)) + (signal 'no-method-definition + (list ,(list 'quote method) local-args)) ;; We do have an object. Make sure it is the right type. (if ,(if (eq class eieio-default-superclass) @@ -1228,9 +1227,7 @@ IMPL is the symbol holding the method implementation." ) (apply ,(list 'quote impl) local-args) ;(,impl local-args) - )))) - ) - )) + ))))))) (defsubst eieio-defgeneric-reset-generic-form-primary-only-one (method) "Setup METHOD to call the generic form." diff --git a/lisp/simple.el b/lisp/simple.el index 456318de21..4776cf3793 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -990,7 +990,7 @@ When called interactively, the word count is printed in echo area." (goto-char (point-min)) (while (forward-word 1) (setq count (1+ count))))) - (if (interactive-p) + (if (called-interactively-p 'interactive) (message "Region has %d words" count)) count)) @@ -6641,6 +6641,7 @@ saving the value of `buffer-invisibility-spec' and setting it to nil." ;; Partial application of functions (similar to "currying"). ;; This function is here rather than in subr.el because it uses CL. +;; (defalias 'apply-partially #'curry) (defun apply-partially (fun &rest args) "Return a function that is a partial application of FUN to ARGS. ARGS is a list of the first N arguments to pass to FUN. diff --git a/lisp/subr.el b/lisp/subr.el index 626128c62b..a493c31b25 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -426,12 +426,6 @@ Non-strings in LIST are ignored." (setq list (cdr list))) list) -;; Remove this since we don't know how to handle it in the byte-compiler yet. -;; (defmacro with-lexical-binding (&rest body) -;; "Execute the statements in BODY using lexical binding." -;; `(let ((internal-interpreter-environment '(t))) -;; ,@body)) - (defun assq-delete-all (key alist) "Delete from ALIST all elements whose car is `eq' to KEY. Return the modified alist. @@ -2786,6 +2780,51 @@ in which case `save-window-excursion' cannot help." (unwind-protect (progn ,@body) (set-window-configuration ,c))))) +(defmacro with-output-to-temp-buffer (bufname &rest body) + "Bind `standard-output' to buffer BUFNAME, eval BODY, then show that buffer. + +This construct makes buffer BUFNAME empty before running BODY. +It does not make the buffer current for BODY. +Instead it binds `standard-output' to that buffer, so that output +generated with `prin1' and similar functions in BODY goes into +the buffer. + +At the end of BODY, this marks buffer BUFNAME unmodifed and displays +it in a window, but does not select it. The normal way to do this is +by calling `display-buffer', then running `temp-buffer-show-hook'. +However, if `temp-buffer-show-function' is non-nil, it calls that +function instead (and does not run `temp-buffer-show-hook'). The +function gets one argument, the buffer to display. + +The return value of `with-output-to-temp-buffer' is the value of the +last form in BODY. If BODY does not finish normally, the buffer +BUFNAME is not displayed. + +This runs the hook `temp-buffer-setup-hook' before BODY, +with the buffer BUFNAME temporarily current. It runs the hook +`temp-buffer-show-hook' after displaying buffer BUFNAME, with that +buffer temporarily current, and the window that was used to display it +temporarily selected. But it doesn't run `temp-buffer-show-hook' +if it uses `temp-buffer-show-function'." + (let ((old-dir (make-symbol "old-dir")) + (buf (make-symbol "buf"))) + `(let ((,old-dir default-directory)) + (with-current-buffer (get-buffer-create ,bufname) + (kill-all-local-variables) + ;; FIXME: delete_all_overlays + (setq default-directory ,old-dir) + (setq buffer-read-only nil) + (setq buffer-file-name nil) + (setq buffer-undo-list t) + (let ((,buf (current-buffer))) + (let ((inhibit-read-only t) + (inhibit-modification-hooks t)) + (erase-buffer) + (run-hooks 'temp-buffer-setup-hook)) + (let ((standard-output ,buf)) + (prog1 (progn ,@body) + (internal-temp-output-buffer-show ,buf)))))))) + (defmacro with-temp-file (file &rest body) "Create a new buffer, evaluate BODY there, and write the buffer to FILE. The value returned is the value of the last form in BODY. diff --git a/src/ChangeLog b/src/ChangeLog index 6bebce0aba..d522b6c55d 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,3 +1,10 @@ +2011-02-21 Stefan Monnier + + * bytecode.c (exec_byte_code): Change stack_ref and stack_set to use + offsets relative to top rather than to bottom. + + * alloc.c (Fgarbage_collect): Don't mark the byte-stack redundantly. + 2011-02-19 Stefan Monnier * window.c (Fsave_window_excursion): Remove. Moved to Lisp. diff --git a/src/alloc.c b/src/alloc.c index 36c849418f..4c29ce0b4e 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -5029,9 +5029,9 @@ returns nil, because real GC can't be done. */) for (i = 0; i < tail->nvars; i++) mark_object (tail->var[i]); } + mark_byte_stack (); #endif - mark_byte_stack (); for (catch = catchlist; catch; catch = catch->next) { mark_object (catch->tag); diff --git a/src/bytecode.c b/src/bytecode.c index ad2f7d18ad..b2e9e3c5b5 100644 --- a/src/bytecode.c +++ b/src/bytecode.c @@ -51,7 +51,7 @@ by Hallvard: * * define BYTE_CODE_METER to enable generation of a byte-op usage histogram. */ -/* #define BYTE_CODE_SAFE */ +#define BYTE_CODE_SAFE /* #define BYTE_CODE_METER */ @@ -88,7 +88,7 @@ extern Lisp_Object Qand_optional, Qand_rest; /* Byte codes: */ -#define Bstack_ref 0 +#define Bstack_ref 0 /* Actually, Bstack_ref+0 is not implemented: use dup. */ #define Bvarref 010 #define Bvarset 020 #define Bvarbind 030 @@ -189,8 +189,8 @@ extern Lisp_Object Qand_optional, Qand_rest; #define Bunwind_protect 0216 #define Bcondition_case 0217 -#define Btemp_output_buffer_setup 0220 -#define Btemp_output_buffer_show 0221 +#define Btemp_output_buffer_setup 0220 /* Obsolete. */ +#define Btemp_output_buffer_show 0221 /* Obsolete. */ #define Bunbind_all 0222 /* Obsolete. */ @@ -898,9 +898,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, case Bsave_window_excursion: /* Obsolete. */ { - register Lisp_Object val; register int count = SPECPDL_INDEX (); - record_unwind_protect (Fset_window_configuration, Fcurrent_window_configuration (Qnil)); BEFORE_POTENTIAL_GC (); @@ -940,7 +938,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, break; } - case Btemp_output_buffer_setup: + case Btemp_output_buffer_setup: /* Obsolete. */ BEFORE_POTENTIAL_GC (); CHECK_STRING (TOP); temp_output_buffer_setup (SSDATA (TOP)); @@ -948,7 +946,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, TOP = Vstandard_output; break; - case Btemp_output_buffer_show: + case Btemp_output_buffer_show: /* Obsolete. */ { Lisp_Object v1; BEFORE_POTENTIAL_GC (); @@ -1710,26 +1708,42 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, #endif /* Handy byte-codes for lexical binding. */ - case Bstack_ref: + /* case Bstack_ref: */ /* Use `dup' instead. */ case Bstack_ref+1: case Bstack_ref+2: case Bstack_ref+3: case Bstack_ref+4: case Bstack_ref+5: - PUSH (stack.bottom[op - Bstack_ref]); - break; + { + Lisp_Object *ptr = top - (op - Bstack_ref); + PUSH (*ptr); + break; + } case Bstack_ref+6: - PUSH (stack.bottom[FETCH]); - break; + { + Lisp_Object *ptr = top - (FETCH); + PUSH (*ptr); + break; + } case Bstack_ref+7: - PUSH (stack.bottom[FETCH2]); - break; + { + Lisp_Object *ptr = top - (FETCH2); + PUSH (*ptr); + break; + } + /* stack-set-0 = discard; stack-set-1 = discard-1-preserve-tos. */ case Bstack_set: - stack.bottom[FETCH] = POP; - break; + { + Lisp_Object *ptr = top - (FETCH); + *ptr = POP; + break; + } case Bstack_set2: - stack.bottom[FETCH2] = POP; - break; + { + Lisp_Object *ptr = top - (FETCH2); + *ptr = POP; + break; + } case BdiscardN: op = FETCH; if (op & 0x80) diff --git a/src/print.c b/src/print.c index 2c4762047a..f48b618775 100644 --- a/src/print.c +++ b/src/print.c @@ -524,6 +524,7 @@ temp_output_buffer_setup (const char *bufname) specbind (Qstandard_output, buf); } +/* FIXME: Use Lisp's with-output-to-temp-buffer instead! */ Lisp_Object internal_with_output_to_temp_buffer (const char *bufname, Lisp_Object (*function) (Lisp_Object), Lisp_Object args) { @@ -545,60 +546,6 @@ internal_with_output_to_temp_buffer (const char *bufname, Lisp_Object (*function return unbind_to (count, val); } - -DEFUN ("with-output-to-temp-buffer", - Fwith_output_to_temp_buffer, Swith_output_to_temp_buffer, - 1, UNEVALLED, 0, - doc: /* Bind `standard-output' to buffer BUFNAME, eval BODY, then show that buffer. - -This construct makes buffer BUFNAME empty before running BODY. -It does not make the buffer current for BODY. -Instead it binds `standard-output' to that buffer, so that output -generated with `prin1' and similar functions in BODY goes into -the buffer. - -At the end of BODY, this marks buffer BUFNAME unmodifed and displays -it in a window, but does not select it. The normal way to do this is -by calling `display-buffer', then running `temp-buffer-show-hook'. -However, if `temp-buffer-show-function' is non-nil, it calls that -function instead (and does not run `temp-buffer-show-hook'). The -function gets one argument, the buffer to display. - -The return value of `with-output-to-temp-buffer' is the value of the -last form in BODY. If BODY does not finish normally, the buffer -BUFNAME is not displayed. - -This runs the hook `temp-buffer-setup-hook' before BODY, -with the buffer BUFNAME temporarily current. It runs the hook -`temp-buffer-show-hook' after displaying buffer BUFNAME, with that -buffer temporarily current, and the window that was used to display it -temporarily selected. But it doesn't run `temp-buffer-show-hook' -if it uses `temp-buffer-show-function'. - -usage: (with-output-to-temp-buffer BUFNAME BODY...) */) - (Lisp_Object args) -{ - struct gcpro gcpro1; - Lisp_Object name; - int count = SPECPDL_INDEX (); - Lisp_Object buf, val; - - GCPRO1(args); - name = eval_sub (Fcar (args)); - CHECK_STRING (name); - temp_output_buffer_setup (SSDATA (name)); - buf = Vstandard_output; - UNGCPRO; - - val = Fprogn (XCDR (args)); - - GCPRO1 (val); - temp_output_buffer_show (buf); - UNGCPRO; - - return unbind_to (count, val); -} - static void print (Lisp_Object obj, register Lisp_Object printcharfun, int escapeflag); static void print_preprocess (Lisp_Object obj); @@ -2310,6 +2257,4 @@ priorities. */); print_prune_charset_plist = Qnil; staticpro (&print_prune_charset_plist); - - defsubr (&Swith_output_to_temp_buffer); } diff --git a/src/window.c b/src/window.c index c90cc268a9..d21cbb164e 100644 --- a/src/window.c +++ b/src/window.c @@ -3655,7 +3655,6 @@ displaying that buffer. */) return Qnil; } - void temp_output_buffer_show (register Lisp_Object buf) { @@ -3715,6 +3714,16 @@ temp_output_buffer_show (register Lisp_Object buf) } } } + +DEFUN ("internal-temp-output-buffer-show", + Ftemp_output_buffer_show, Stemp_output_buffer_show, + 1, 1, 0, + doc: /* Internal function for `with-output-to-temp-buffer''. */) + (Lisp_Object buf) +{ + temp_output_buffer_show (buf); + return Qnil; +} static void make_dummy_parent (Lisp_Object window) @@ -7155,6 +7164,7 @@ frame to be redrawn only if it is a tty frame. */); defsubr (&Sset_window_buffer); defsubr (&Sselect_window); defsubr (&Sforce_window_update); + defsubr (&Stemp_output_buffer_show); defsubr (&Ssplit_window); defsubr (&Senlarge_window); defsubr (&Sshrink_window); -- 2.20.1