mirror of
git://git.sv.gnu.org/emacs.git
synced 2025-12-09 07:40:39 -08:00
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.
This commit is contained in:
Stefan Monnier
parent
e0f57e6569
commit
3e21b6a72b
13 changed files with 263 additions and 210 deletions
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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."
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue