summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorStefan Monnier <monnier@iro.umontreal.ca>2011-02-21 15:12:44 -0500
committerStefan Monnier <monnier@iro.umontreal.ca>2011-02-21 15:12:44 -0500
commit3e21b6a72b87787e2327513a44623b250054f77d (patch)
tree26831a9b700810d4f9cebe90afe2a090ae865604
parente0f57e65692ed73a86926f737388b60faec92767 (diff)
downloademacs-3e21b6a72b87787e2327513a44623b250054f77d.tar.gz
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.
-rw-r--r--lisp/ChangeLog39
-rw-r--r--lisp/emacs-lisp/byte-opt.el143
-rw-r--r--lisp/emacs-lisp/bytecomp.el34
-rw-r--r--lisp/emacs-lisp/cconv.el45
-rw-r--r--lisp/emacs-lisp/eieio-comp.el11
-rw-r--r--lisp/emacs-lisp/eieio.el17
-rw-r--r--lisp/simple.el3
-rw-r--r--lisp/subr.el51
-rw-r--r--src/ChangeLog7
-rw-r--r--src/alloc.c2
-rw-r--r--src/bytecode.c52
-rw-r--r--src/print.c57
-rw-r--r--src/window.c12
13 files changed, 263 insertions, 210 deletions
diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index ae91513937c..4e2e87ab60f 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,3 +1,42 @@
+2011-02-21 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * 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 <monnier@iro.umontreal.ca>
* 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 038db292350..e415b5edde2 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 54a1912169a..8892a27b29c 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 4e42e9f3c1d..66e5051c2f1 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 ed6fb6f1c41..244c4318425 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 d958bfbd45c..82c0e1319fe 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 456318de213..4776cf37931 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 626128c62b3..a493c31b254 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 6bebce0abaa..d522b6c55dc 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,3 +1,10 @@
+2011-02-21 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * 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 <monnier@iro.umontreal.ca>
* window.c (Fsave_window_excursion): Remove. Moved to Lisp.
diff --git a/src/alloc.c b/src/alloc.c
index 36c849418f3..4c29ce0b4ec 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 ad2f7d18ade..b2e9e3c5b56 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 2c4762047ac..f48b618775d 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 c90cc268a92..d21cbb164ea 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);