diff options
Diffstat (limited to 'lisp/emacs-lisp')
| -rw-r--r-- | lisp/emacs-lisp/byte-opt.el | 249 | ||||
| -rw-r--r-- | lisp/emacs-lisp/bytecomp.el | 969 | ||||
| -rw-r--r-- | lisp/emacs-lisp/cconv.el | 878 | ||||
| -rw-r--r-- | lisp/emacs-lisp/cl-extra.el | 9 | ||||
| -rw-r--r-- | lisp/emacs-lisp/cl-loaddefs.el | 4 | ||||
| -rw-r--r-- | lisp/emacs-lisp/cl-macs.el | 8 | ||||
| -rw-r--r-- | lisp/emacs-lisp/disass.el | 15 | ||||
| -rw-r--r-- | lisp/emacs-lisp/edebug.el | 17 | ||||
| -rw-r--r-- | lisp/emacs-lisp/eieio-comp.el | 11 | ||||
| -rw-r--r-- | lisp/emacs-lisp/eieio.el | 17 | ||||
| -rw-r--r-- | lisp/emacs-lisp/lisp-mode.el | 19 | ||||
| -rw-r--r-- | lisp/emacs-lisp/macroexp.el | 13 | ||||
| -rw-r--r-- | lisp/emacs-lisp/pcase.el | 89 |
13 files changed, 1810 insertions, 488 deletions
diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 0f4018dc8da..c9cc4618967 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -186,8 +186,10 @@ (eval-when-compile (require 'cl)) (defun byte-compile-log-lap-1 (format &rest args) - (if (aref byte-code-vector 0) - (error "The old version of the disassembler is loaded. Reload new-bytecomp as well")) + ;; Newer byte codes for stack-ref make the slot 0 non-nil again. + ;; But the "old disassembler" is *really* ancient by now. + ;; (if (aref byte-code-vector 0) + ;; (error "The old version of the disassembler is loaded. Reload new-bytecomp as well")) (byte-compile-log-1 (apply 'format format (let (c a) @@ -248,7 +250,18 @@ ;; are no collisions, and that byte-compile-tag-number is reasonable ;; after this is spliced in. The provided list is destroyed. (defun byte-inline-lapcode (lap) - (setq byte-compile-output (nconc (nreverse lap) byte-compile-output))) + ;; "Replay" the operations: we used to just do + ;; (setq byte-compile-output (nconc (nreverse lap) byte-compile-output)) + ;; but that fails to update byte-compile-depth, so we had to assume + ;; that `lap' ends up adding exactly 1 element to the stack. This + ;; happens to be true for byte-code generated by bytecomp.el without + ;; lexical-binding, but it's not true in general, and it's not true for + ;; code output by bytecomp.el with lexical-binding. + (dolist (op lap) + (cond + ((eq (car op) 'TAG) (byte-compile-out-tag op)) + ((memq (car op) byte-goto-ops) (byte-compile-goto (car op) (cdr op))) + (t (byte-compile-out (car op) (cdr op)))))) (defun byte-compile-inline-expand (form) (let* ((name (car form)) @@ -266,24 +279,32 @@ (cdr (assq name byte-compile-function-environment))))) (if (and (consp fn) (eq (car fn) 'autoload)) (error "File `%s' didn't define `%s'" (nth 1 fn) name)) - (if (and (symbolp fn) (not (eq fn t))) - (byte-compile-inline-expand (cons fn (cdr form))) - (if (byte-code-function-p fn) - (let (string) - (fetch-bytecode fn) - (setq string (aref fn 1)) - ;; Isn't it an error for `string' not to be unibyte?? --stef - (if (fboundp 'string-as-unibyte) - (setq string (string-as-unibyte string))) - ;; `byte-compile-splice-in-already-compiled-code' - ;; takes care of inlining the body. - (cons `(lambda ,(aref fn 0) - (byte-code ,string ,(aref fn 2) ,(aref fn 3))) - (cdr form))) - (if (eq (car-safe fn) 'lambda) - (cons fn (cdr form)) - ;; Give up on inlining. - form)))))) + (cond + ((and (symbolp fn) (not (eq fn t))) ;A function alias. + (byte-compile-inline-expand (cons fn (cdr form)))) + ((and (byte-code-function-p fn) + ;; FIXME: This works to inline old-style-byte-codes into + ;; old-style-byte-codes, but not mixed cases (not sure + ;; about new-style into new-style). + (not lexical-binding) + (not (and (>= (length fn) 7) + (aref fn 6)))) ;6 = COMPILED_PUSH_ARGS + ;; (message "Inlining %S byte-code" name) + (fetch-bytecode fn) + (let ((string (aref fn 1))) + ;; Isn't it an error for `string' not to be unibyte?? --stef + (if (fboundp 'string-as-unibyte) + (setq string (string-as-unibyte string))) + ;; `byte-compile-splice-in-already-compiled-code' + ;; takes care of inlining the body. + (cons `(lambda ,(aref fn 0) + (byte-code ,string ,(aref fn 2) ,(aref fn 3))) + (cdr form)))) + ((eq (car-safe fn) 'lambda) + (macroexpand-all (cons fn (cdr form)) + byte-compile-macro-environment)) + (t ;; Give up on inlining. + form))))) ;; ((lambda ...) ...) (defun byte-compile-unfold-lambda (form &optional name) @@ -479,8 +500,7 @@ (prin1-to-string form)) nil) - ((memq fn '(defun defmacro function - condition-case save-window-excursion)) + ((memq fn '(defun defmacro function condition-case)) ;; These forms are compiled as constants or by breaking out ;; all the subexpressions and compiling them separately. form) @@ -511,24 +531,6 @@ ;; However, don't actually bother calling `ignore'. `(prog1 nil . ,(mapcar 'byte-optimize-form (cdr form)))) - ;; If optimization is on, this is the only place that macros are - ;; expanded. If optimization is off, then macroexpansion happens - ;; in byte-compile-form. Otherwise, the macros are already expanded - ;; by the time that is reached. - ((not (eq form - (setq form (macroexpand form - byte-compile-macro-environment)))) - (byte-optimize-form form for-effect)) - - ;; Support compiler macros as in cl.el. - ((and (fboundp 'compiler-macroexpand) - (symbolp (car-safe form)) - (get (car-safe form) 'cl-compiler-macro) - (not (eq form - (with-no-warnings - (setq form (compiler-macroexpand form)))))) - (byte-optimize-form form for-effect)) - ((not (symbolp fn)) (byte-compile-warn "`%s' is a malformed function" (prin1-to-string fn)) @@ -1297,10 +1299,7 @@ (if (not (memq byte-optimize '(t lap))) (byte-compile-normal-call form) (byte-inline-lapcode - (byte-decompile-bytecode-1 (nth 1 form) (nth 2 form) t)) - (setq byte-compile-maxdepth (max (+ byte-compile-depth (nth 3 form)) - byte-compile-maxdepth)) - (setq byte-compile-depth (1+ byte-compile-depth)))) + (byte-decompile-bytecode-1 (nth 1 form) (nth 2 form) t)))) (put 'byte-code 'byte-compile 'byte-compile-splice-in-already-compiled-code) @@ -1308,17 +1307,17 @@ (defconst byte-constref-ops '(byte-constant byte-constant2 byte-varref byte-varset byte-varbind)) +;; Used and set dynamically in byte-decompile-bytecode-1. +(defvar bytedecomp-op) +(defvar bytedecomp-ptr) +(defvar bytedecomp-bytes) + ;; This function extracts the bitfields from variable-length opcodes. ;; Originally defined in disass.el (which no longer uses it.) - (defun disassemble-offset () "Don't call this!" ;; fetch and return the offset for the current opcode. ;; return nil if this opcode has no offset - ;; Used and set dynamically in byte-decompile-bytecode-1. - (defvar bytedecomp-op) - (defvar bytedecomp-ptr) - (defvar bytedecomp-bytes) (cond ((< bytedecomp-op byte-nth) (let ((tem (logand bytedecomp-op 7))) (setq bytedecomp-op (logand bytedecomp-op 248)) @@ -1336,15 +1335,16 @@ ((>= bytedecomp-op byte-constant) (prog1 (- bytedecomp-op byte-constant) ;offset in opcode (setq bytedecomp-op byte-constant))) - ((and (>= bytedecomp-op byte-constant2) - (<= bytedecomp-op byte-goto-if-not-nil-else-pop)) + ((or (and (>= bytedecomp-op byte-constant2) + (<= bytedecomp-op byte-goto-if-not-nil-else-pop)) + (= bytedecomp-op byte-stack-set2)) ;; Offset in next 2 bytes. (setq bytedecomp-ptr (1+ bytedecomp-ptr)) (+ (aref bytedecomp-bytes bytedecomp-ptr) (progn (setq bytedecomp-ptr (1+ bytedecomp-ptr)) (lsh (aref bytedecomp-bytes bytedecomp-ptr) 8)))) ((and (>= bytedecomp-op byte-listN) - (<= bytedecomp-op byte-insertN)) + (<= bytedecomp-op byte-discardN)) (setq bytedecomp-ptr (1+ bytedecomp-ptr)) ;offset in next byte (aref bytedecomp-bytes bytedecomp-ptr)))) @@ -1407,7 +1407,16 @@ (if (= bytedecomp-ptr (1- length)) (setq bytedecomp-op nil) (setq offset (or endtag (setq endtag (byte-compile-make-tag))) - bytedecomp-op 'byte-goto)))) + bytedecomp-op 'byte-goto))) + ((eq bytedecomp-op 'byte-stack-set2) + (setq bytedecomp-op 'byte-stack-set)) + ((and (eq bytedecomp-op 'byte-discardN) (>= offset #x80)) + ;; The top bit of the operand for byte-discardN is a flag, + ;; saying whether the top-of-stack is preserved. In + ;; lapcode, we represent this by using a different opcode + ;; (with the flag removed from the operand). + (setq bytedecomp-op 'byte-discardN-preserve-tos) + (setq offset (- offset #x80)))) ;; lap = ( [ (pc . (op . arg)) ]* ) (setq lap (cons (cons optr (cons bytedecomp-op (or offset 0))) lap)) @@ -1463,7 +1472,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-current-buffer byte-stack-ref)) (defconst byte-compile-side-effect-free-ops (nconc @@ -1580,9 +1589,14 @@ 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. ;; + ;; 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))) + (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 @@ -1611,14 +1625,17 @@ 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))) + (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)) + (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 @@ -1673,30 +1690,34 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." (setq rest (cdr rest) lap (delq lap0 (delq lap1 lap)))) (t - (if (memq (car lap1) byte-goto-always-pop-ops) - (progn - (byte-compile-log-lap " %s %s\t-->\t%s" - lap0 lap1 (cons 'byte-goto (cdr lap1))) - (setq lap (delq lap0 lap))) - (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 - (cons 'byte-goto (cdr lap1)))) + (byte-compile-log-lap " %s %s\t-->\t%s" + lap0 lap1 + (cons 'byte-goto (cdr lap1))) + (when (memq (car lap1) byte-goto-always-pop-ops) + (setq lap (delq lap0 lap))) (setcar lap1 'byte-goto))) (setq keep-going t)) ;; ;; 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 (eq 'byte-varref (car lap0)) + ((and (memq (car lap0) '(byte-varref byte-stack-ref)) (progn (setq tmp (cdr rest)) + (setq tmp2 0) (while (eq (car (car tmp)) 'byte-dup) - (setq tmp (cdr tmp))) + (setq tmp2 (1+ tmp2)) + (setq tmp (cdr tmp))) t) - (eq (cdr lap0) (cdr (car tmp))) - (eq 'byte-varref (car (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)) @@ -1883,6 +1904,11 @@ 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 (eq (car lap1) 'byte-varset) (eq (car lap2) 'byte-goto) @@ -1955,10 +1981,11 @@ 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) + (byte-compile-log-lap " ---- final pass") (while rest (setq lap0 (car rest) lap1 (nth 1 rest)) @@ -2008,10 +2035,88 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 (cons 'byte-unbind (+ (cdr lap0) (cdr lap1)))) - (setq keep-going t) (setq lap (delq lap0 lap)) (setcdr lap1 (+ (cdr lap1) (cdr lap0)))) - ) + + ;; + ;; stack-set-M [discard/discardN ...] --> discardN-preserve-tos + ;; stack-set-M [discard/discardN ...] --> discardN + ;; + ((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)) + (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) + (byte-compile-log-lap " %s [discard/discardN]...\t-->\t%s" + lap0 lap1)) + + ;; + ;; discard/discardN/discardN-preserve-tos-X discard/discardN-Y --> + ;; discardN-(X+Y) + ;; + ((and (memq (car lap0) + '(byte-discard + byte-discardN + byte-discardN-preserve-tos)) + (memq (car lap1) '(byte-discard byte-discardN))) + (setq lap (delq lap0 lap)) + (byte-compile-log-lap + " %s %s\t-->\t(discardN %s)" + lap0 lap1 + (+ (if (eq (car lap0) 'byte-discard) 1 (cdr lap0)) + (if (eq (car lap1) 'byte-discard) 1 (cdr lap1)))) + (setcdr lap1 (+ (if (eq (car lap0) 'byte-discard) 1 (cdr lap0)) + (if (eq (car lap1) 'byte-discard) 1 (cdr lap1)))) + (setcar lap1 'byte-discardN)) + + ;; + ;; discardN-preserve-tos-X discardN-preserve-tos-Y --> + ;; discardN-preserve-tos-(X+Y) + ;; + ((and (eq (car lap0) 'byte-discardN-preserve-tos) + (eq (car lap1) 'byte-discardN-preserve-tos)) + (setq lap (delq lap0 lap)) + (setcdr lap1 (+ (cdr lap0) (cdr lap1))) + (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 (car rest))) + + ;; + ;; discardN-preserve-tos return --> return + ;; dup return --> return + ;; stack-set-N return --> return ; where N is TOS-1 + ;; + ((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)) + (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 lap1)) + ) (setq rest (cdr rest))) (setq byte-compile-maxdepth (+ byte-compile-maxdepth add-depth))) lap) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 199927d536e..8892a27b29c 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -118,12 +118,20 @@ ;; Some versions of `file' can be customized to recognize that. (require 'backquote) +(require 'macroexp) +(require 'cconv) (eval-when-compile (require 'cl)) (or (fboundp 'defsubst) ;; This really ought to be loaded already! (load "byte-run")) +;; The feature of compiling in a specific target Emacs version +;; has been turned off because compile time options are a bad idea. +(defmacro byte-compile-single-version () nil) +(defmacro byte-compile-version-cond (cond) cond) + + (defgroup bytecomp nil "Emacs Lisp byte-compiler." :group 'lisp) @@ -395,13 +403,15 @@ specify different fields to sort on." :type '(choice (const name) (const callers) (const calls) (const calls+callers) (const nil))) -(defvar byte-compile-debug nil) +(defvar byte-compile-debug t) +(setq debug-on-error t) + (defvar byte-compile-constants nil "List of all constants encountered during compilation of this form.") (defvar byte-compile-variables nil "List of all variables encountered during compilation of this form.") (defvar byte-compile-bound-variables nil - "List of variables bound in the context of the current form. + "List of dynamic variables bound in the context of the current form. This list lives partly on the stack.") (defvar byte-compile-const-variables nil "List of variables declared as constants during compilation of this file.") @@ -415,9 +425,13 @@ This list lives partly on the stack.") ;; (byte-compiler-options . (lambda (&rest forms) ;; (apply 'byte-compiler-options-handler forms))) (eval-when-compile . (lambda (&rest body) - (list 'quote - (byte-compile-eval (byte-compile-top-level - (cons 'progn body)))))) + (list + 'quote + (byte-compile-eval + (byte-compile-top-level + (macroexpand-all + (cons 'progn body) + byte-compile-initial-macro-environment)))))) (eval-and-compile . (lambda (&rest body) (byte-compile-eval-before-compile (cons 'progn body)) (cons 'progn body)))) @@ -450,6 +464,10 @@ defined with incorrect args.") Used for warnings about calling a function that is defined during compilation but won't necessarily be defined when the compiled file is loaded.") +;; Variables for lexical binding +(defvar byte-compile-lexical-environment nil + "The current lexical environment.") + (defvar byte-compile-tag-number 0) (defvar byte-compile-output nil "Alist describing contents to put in byte code string. @@ -495,11 +513,10 @@ Each element is (INDEX . VALUE)") (put 'byte-stack+-info 'tmp-compile-time-value nil))) -;; unused: 0-7 - ;; These opcodes are special in that they pack their argument into the ;; opcode word. ;; +(byte-defop 0 1 byte-stack-ref "for stack reference") (byte-defop 8 1 byte-varref "for variable reference") (byte-defop 16 -1 byte-varset "for setting a variable") (byte-defop 24 -1 byte-varbind "for binding a variable") @@ -569,7 +586,6 @@ Each element is (INDEX . VALUE)") (byte-defop 114 0 byte-save-current-buffer "To make a binding to record the current buffer") (byte-defop 115 0 byte-set-mark-OBSOLETE) -(byte-defop 116 1 byte-interactive-p) ;; These ops are new to v19 (byte-defop 117 0 byte-forward-char) @@ -605,8 +621,6 @@ otherwise pop it") (byte-defop 138 0 byte-save-excursion "to make a binding to record the buffer, point and mark") -(byte-defop 139 0 byte-save-window-excursion - "to make a binding to record entire window configuration") (byte-defop 140 0 byte-save-restriction "to make a binding to record the current buffer clipping restrictions") (byte-defop 141 -1 byte-catch @@ -622,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 @@ -661,11 +675,26 @@ otherwise pop it") (byte-defop 168 0 byte-integerp) ;; unused: 169-174 + (byte-defop 175 nil byte-listN) (byte-defop 176 nil byte-concatN) (byte-defop 177 nil byte-insertN) -;; unused: 178-191 +(byte-defop 178 -1 byte-stack-set) ; stack offset in following one byte +(byte-defop 179 -1 byte-stack-set2) ; stack offset in following two bytes + +;; if (following one byte & 0x80) == 0 +;; discard (following one byte & 0x7F) stack entries +;; else +;; discard (following one byte & 0x7F) stack entries _underneath_ the top of stack +;; (that is, if the operand = 0x83, ... X Y Z T => ... T) +(byte-defop 182 nil byte-discardN) +;; `byte-discardN-preserve-tos' is a pseudo-op that gets turned into +;; `byte-discardN' with the high bit in the operand set (by +;; `byte-compile-lapcode'). +(defconst byte-discardN-preserve-tos byte-discardN) + +;; unused: 182-191 (byte-defop 192 1 byte-constant "for reference to a constant") ;; codes 193-255 are consumed by byte-constant. @@ -712,71 +741,116 @@ otherwise pop it") ;; front of the constants-vector than the constant-referencing instructions. ;; Also, this lets us notice references to free variables. +(defmacro byte-compile-push-bytecodes (&rest args) + "Push BYTE... onto BYTES, and increment PC by the number of bytes pushed. +ARGS is of the form (BYTE... BYTES PC), where BYTES and PC are variable names. +BYTES and PC are updated after evaluating all the arguments." + (let ((byte-exprs (butlast args 2)) + (bytes-var (car (last args 2))) + (pc-var (car (last args)))) + `(setq ,bytes-var ,(if (null (cdr byte-exprs)) + `(progn (assert (<= 0 ,(car byte-exprs))) + (cons ,@byte-exprs ,bytes-var)) + `(nconc (list ,@(reverse byte-exprs)) ,bytes-var)) + ,pc-var (+ ,(length byte-exprs) ,pc-var)))) + +(defmacro byte-compile-push-bytecode-const2 (opcode const2 bytes pc) + "Push OPCODE and the two-byte constant CONST2 onto BYTES, and add 3 to PC. +CONST2 may be evaulated multiple times." + `(byte-compile-push-bytecodes ,opcode (logand ,const2 255) (lsh ,const2 -8) + ,bytes ,pc)) + (defun byte-compile-lapcode (lap) "Turns lapcode into bytecode. The lapcode is destroyed." ;; Lapcode modifications: changes the ID of a tag to be the tag's PC. (let ((pc 0) ; Program counter op off ; Operation & offset + opcode ; numeric value of OP (bytes '()) ; Put the output bytes here - (patchlist nil)) ; List of tags and goto's to patch - (while lap - (setq op (car (car lap)) - off (cdr (car lap))) - (cond ((not (symbolp op)) - (error "Non-symbolic opcode `%s'" op)) - ((eq op 'TAG) - (setcar off pc) - (setq patchlist (cons off patchlist))) - ((memq op byte-goto-ops) - (setq pc (+ pc 3)) - (setq bytes (cons (cons pc (cdr off)) - (cons nil - (cons (symbol-value op) bytes)))) - (setq patchlist (cons bytes patchlist))) - (t - (setq bytes - (cond ((cond ((consp off) - ;; Variable or constant reference - (setq off (cdr off)) - (eq op 'byte-constant))) - (cond ((< off byte-constant-limit) - (setq pc (1+ pc)) - (cons (+ byte-constant off) bytes)) - (t - (setq pc (+ 3 pc)) - (cons (lsh off -8) - (cons (logand off 255) - (cons byte-constant2 bytes)))))) - ((<= byte-listN (symbol-value op)) - (setq pc (+ 2 pc)) - (cons off (cons (symbol-value op) bytes))) - ((< off 6) - (setq pc (1+ pc)) - (cons (+ (symbol-value op) off) bytes)) - ((< off 256) - (setq pc (+ 2 pc)) - (cons off (cons (+ (symbol-value op) 6) bytes))) - (t - (setq pc (+ 3 pc)) - (cons (lsh off -8) - (cons (logand off 255) - (cons (+ (symbol-value op) 7) - bytes)))))))) - (setq lap (cdr lap))) + (patchlist nil)) ; List of gotos to patch + (dolist (lap-entry lap) + (setq op (car lap-entry) + off (cdr lap-entry)) + (cond + ((not (symbolp op)) + (error "Non-symbolic opcode `%s'" op)) + ((eq op 'TAG) + (setcar off pc)) + ((null op) + ;; a no-op added by `byte-compile-delay-out' + (unless (zerop off) + (error + "Placeholder added by `byte-compile-delay-out' not filled in.") + )) + (t + (setq opcode + (if (eq op 'byte-discardN-preserve-tos) + ;; byte-discardN-preserve-tos is a pseudo op, which + ;; is actually the same as byte-discardN + ;; with a modified argument. + byte-discardN + (symbol-value op))) + (cond ((memq op byte-goto-ops) + ;; goto + (byte-compile-push-bytecodes opcode nil (cdr off) bytes pc) + (push bytes patchlist)) + ((and (consp off) + ;; Variable or constant reference + (progn (setq off (cdr off)) + (eq op 'byte-constant))) + ;; constant ref + (if (< off byte-constant-limit) + (byte-compile-push-bytecodes (+ byte-constant off) + bytes pc) + (byte-compile-push-bytecode-const2 byte-constant2 off + bytes pc))) + ((and (= opcode byte-stack-set) + (> off 255)) + ;; Use the two-byte version of byte-stack-set if the + ;; offset is too large for the normal version. + (byte-compile-push-bytecode-const2 byte-stack-set2 off + bytes pc)) + ((and (>= opcode byte-listN) + (< opcode byte-discardN)) + ;; These insns all put their operand into one extra byte. + (byte-compile-push-bytecodes opcode off bytes pc)) + ((= opcode byte-discardN) + ;; byte-discardN is weird in that it encodes a flag in the + ;; top bit of its one-byte argument. If the argument is + ;; too large to fit in 7 bits, the opcode can be repeated. + (let ((flag (if (eq op 'byte-discardN-preserve-tos) #x80 0))) + (while (> off #x7f) + (byte-compile-push-bytecodes opcode (logior #x7f flag) bytes pc) + (setq off (- off #x7f))) + (byte-compile-push-bytecodes opcode (logior off flag) bytes pc))) + ((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. + ((< off 6) + (byte-compile-push-bytecodes (+ opcode off) bytes pc)) + ((< off 256) + (byte-compile-push-bytecodes (+ opcode 6) off bytes pc)) + (t + (byte-compile-push-bytecode-const2 (+ opcode 7) off + bytes pc)))))) ;;(if (not (= pc (length bytes))) ;; (error "Compiler error: pc mismatch - %s %s" pc (length bytes))) - ;; Patch PC into jumps - (let (bytes) - (while patchlist - (setq bytes (car patchlist)) - (cond ((atom (car bytes))) ; Tag - (t ; Absolute jump - (setq pc (car (cdr (car bytes)))) ; Pick PC from tag - (setcar (cdr bytes) (logand pc 255)) - (setcar bytes (lsh pc -8)) - ;; FIXME: Replace this by some workaround. - (if (> (car bytes) 255) (error "Bytecode overflow")))) - (setq patchlist (cdr patchlist)))) + + ;; Patch tag PCs into absolute jumps + (dolist (bytes-tail patchlist) + (setq pc (caar bytes-tail)) ; Pick PC from goto's tag + (setcar (cdr bytes-tail) (logand pc 255)) + (setcar bytes-tail (lsh pc -8)) + ;; FIXME: Replace this by some workaround. + (if (> (car bytes) 255) (error "Bytecode overflow"))) + (apply 'unibyte-string (nreverse bytes)))) @@ -1258,11 +1332,11 @@ extra args." (eq 'lambda (car-safe (cdr-safe old))) (setq old (cdr old))) (let ((sig1 (byte-compile-arglist-signature - (if (eq 'lambda (car-safe old)) - (nth 1 old) - (if (byte-code-function-p old) - (aref old 0) - '(&rest def))))) + (pcase old + (`(lambda ,args . ,_) args) + (`(closure ,_ ,_ ,args . ,_) args) + ((pred byte-code-function-p) (aref old 0)) + (t '(&rest def))))) (sig2 (byte-compile-arglist-signature (nth 2 form)))) (unless (byte-compile-arglist-signatures-congruent-p sig1 sig2) (byte-compile-set-symbol-position (nth 1 form)) @@ -1330,14 +1404,7 @@ extra args." ;; but such warnings are never useful, ;; so don't warn about them. macroexpand cl-macroexpand-all - cl-compiling-file))) - ;; Avoid warnings for things which are safe because they - ;; have suitable compiler macros, but those aren't - ;; expanded at this stage. There should probably be more - ;; here than caaar and friends. - (not (and (eq (get func 'byte-compile) - 'cl-byte-compile-compiler-macro) - (string-match "\\`c[ad]+r\\'" (symbol-name func))))) + cl-compiling-file)))) (byte-compile-warn "function `%s' from cl package called at runtime" func))) form) @@ -1574,7 +1641,7 @@ that already has a `.elc' file." "Non-nil to prevent byte-compiling of Emacs Lisp code. This is normally set in local file variables at the end of the elisp file: -;; Local Variables:\n;; no-byte-compile: t\n;; End: ") +\;; Local Variables:\n;; no-byte-compile: t\n;; End: ") ;Backslash for compile-main. ;;;###autoload(put 'no-byte-compile 'safe-local-variable 'booleanp) (defun byte-recompile-file (bytecomp-filename &optional bytecomp-force bytecomp-arg load) @@ -2118,18 +2185,18 @@ list that represents a doc string reference. (defun byte-compile-file-form (form) (let ((byte-compile-current-form nil) ; close over this for warnings. bytecomp-handler) - (cond - ((not (consp form)) - (byte-compile-keep-pending form)) - ((and (symbolp (car form)) - (setq bytecomp-handler (get (car form) 'byte-hunk-handler))) - (cond ((setq form (funcall bytecomp-handler form)) - (byte-compile-flush-pending) - (byte-compile-output-file-form form)))) - ((eq form (setq form (macroexpand form byte-compile-macro-environment))) - (byte-compile-keep-pending form)) - (t - (byte-compile-file-form form))))) + (setq form (macroexpand-all form byte-compile-macro-environment)) + (if lexical-binding + (setq form (cconv-closure-convert form))) + (cond ((not (consp form)) + (byte-compile-keep-pending form)) + ((and (symbolp (car form)) + (setq bytecomp-handler (get (car form) 'byte-hunk-handler))) + (cond ((setq form (funcall bytecomp-handler form)) + (byte-compile-flush-pending) + (byte-compile-output-file-form form)))) + (t + (byte-compile-keep-pending form))))) ;; Functions and variables with doc strings must be output separately, ;; so make-docfile can recognise them. Most other things can be output @@ -2141,8 +2208,7 @@ list that represents a doc string reference. (setq byte-compile-current-form (nth 1 form)) (byte-compile-warn "defsubst `%s' was used before it was defined" (nth 1 form))) - (byte-compile-file-form - (macroexpand form byte-compile-macro-environment)) + (byte-compile-file-form form) ;; Return nil so the form is not output twice. nil) @@ -2468,6 +2534,14 @@ 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. + (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. + (setq fun (cadr fun)) (setq fun (if macro (cons 'macro (byte-compile-lambda fun)) (byte-compile-lambda fun))) @@ -2555,6 +2629,24 @@ If FORM is a lambda or a macro, byte-compile it as a function." (setq list (cdr list))))) +(defun byte-compile-arglist-vars (arglist) + "Return a list of the variables in the lambda argument list ARGLIST." + (remq '&rest (remq '&optional arglist))) + +(defun byte-compile-make-lambda-lexenv (form) + "Return a new lexical environment for a lambda expression FORM." + ;; See if this is a closure or not + (let ((args (byte-compile-arglist-vars (cadr form)))) + (let ((lexenv nil)) + ;; Fill in the initial stack contents + (let ((stackpos 0)) + ;; Add entries for each argument + (dolist (arg args) + (push (cons arg stackpos) lexenv) + (setq stackpos (1+ stackpos))) + ;; Return the new lexical environment + lexenv)))) + ;; Byte-compile a lambda-expression and return a valid function. ;; The value is usually a compiled function but may be the original ;; lambda-expression. @@ -2571,17 +2663,16 @@ If FORM is a lambda or a macro, byte-compile it as a function." (byte-compile-check-lambda-list (nth 1 bytecomp-fun)) (let* ((bytecomp-arglist (nth 1 bytecomp-fun)) (byte-compile-bound-variables - (nconc (and (byte-compile-warning-enabled-p 'free-vars) - (delq '&rest - (delq '&optional (copy-sequence bytecomp-arglist)))) - byte-compile-bound-variables)) + (append (and (not lexical-binding) + (byte-compile-arglist-vars bytecomp-arglist)) + byte-compile-bound-variables)) (bytecomp-body (cdr (cdr bytecomp-fun))) (bytecomp-doc (if (stringp (car bytecomp-body)) - (prog1 (car bytecomp-body) - ;; Discard the doc string - ;; unless it is the last element of the body. - (if (cdr bytecomp-body) - (setq bytecomp-body (cdr bytecomp-body)))))) + (prog1 (car bytecomp-body) + ;; Discard the doc string + ;; unless it is the last element of the body. + (if (cdr bytecomp-body) + (setq bytecomp-body (cdr bytecomp-body)))))) (bytecomp-int (assq 'interactive bytecomp-body))) ;; Process the interactive spec. (when bytecomp-int @@ -2605,26 +2696,35 @@ If FORM is a lambda or a macro, byte-compile it as a function." (if (eq (car-safe form) 'list) (byte-compile-top-level (nth 1 bytecomp-int)) (setq bytecomp-int (list 'interactive - (byte-compile-top-level - (nth 1 bytecomp-int))))))) + (byte-compile-top-level + (nth 1 bytecomp-int))))))) ((cdr bytecomp-int) (byte-compile-warn "malformed interactive spec: %s" (prin1-to-string bytecomp-int))))) ;; Process the body. - (let ((compiled (byte-compile-top-level - (cons 'progn bytecomp-body) nil 'lambda))) + (let* ((byte-compile-lexical-environment + ;; If doing lexical binding, push a new lexical environment + ;; containing just the args (since lambda expressions + ;; should be closed by now). + (and lexical-binding + (byte-compile-make-lambda-lexenv bytecomp-fun))) + (compiled + (byte-compile-top-level (cons 'progn bytecomp-body) nil 'lambda))) ;; Build the actual byte-coded function. (if (eq 'byte-code (car-safe compiled)) - (apply 'make-byte-code - (append (list bytecomp-arglist) - ;; byte-string, constants-vector, stack depth - (cdr compiled) - ;; optionally, the doc string. - (if (or bytecomp-doc bytecomp-int) - (list bytecomp-doc)) - ;; optionally, the interactive spec. - (if bytecomp-int - (list (nth 1 bytecomp-int))))) + (apply 'make-byte-code + (append (list bytecomp-arglist) + ;; byte-string, constants-vector, stack depth + (cdr compiled) + ;; optionally, the doc string. + (if (or bytecomp-doc bytecomp-int + lexical-binding) + (list bytecomp-doc)) + ;; optionally, the interactive spec. + (if (or bytecomp-int lexical-binding) + (list (nth 1 bytecomp-int))) + (if lexical-binding + '(t)))) (setq compiled (nconc (if bytecomp-int (list bytecomp-int)) (cond ((eq (car-safe compiled) 'progn) (cdr compiled)) @@ -2635,6 +2735,11 @@ If FORM is a lambda or a macro, byte-compile it as a function." (bytecomp-body (list nil)))) compiled)))))) +(defun byte-compile-closure (form &optional add-lambda) + (let ((code (byte-compile-lambda form add-lambda))) + ;; A simple lambda is just a constant. + (byte-compile-constant code))) + (defun byte-compile-constants-vector () ;; Builds the constants-vector from the current variables and constants. ;; This modifies the constants from (const . nil) to (const . offset). @@ -2678,18 +2783,31 @@ If FORM is a lambda or a macro, byte-compile it as a function." (byte-compile-tag-number 0) (byte-compile-depth 0) (byte-compile-maxdepth 0) + (byte-compile-lexical-environment + (when (eq output-type 'lambda) + byte-compile-lexical-environment)) (byte-compile-output nil)) - (if (memq byte-optimize '(t source)) - (setq form (byte-optimize-form form for-effect))) - (while (and (eq (car-safe form) 'progn) (null (cdr (cdr form)))) - (setq form (nth 1 form))) - (if (and (eq 'byte-code (car-safe form)) - (not (memq byte-optimize '(t byte))) - (stringp (nth 1 form)) (vectorp (nth 2 form)) - (natnump (nth 3 form))) - form - (byte-compile-form form for-effect) - (byte-compile-out-toplevel for-effect output-type)))) + (if (memq byte-optimize '(t source)) + (setq form (byte-optimize-form form for-effect))) + (while (and (eq (car-safe form) 'progn) (null (cdr (cdr form)))) + (setq form (nth 1 form))) + (if (and (eq 'byte-code (car-safe form)) + (not (memq byte-optimize '(t byte))) + (stringp (nth 1 form)) (vectorp (nth 2 form)) + (natnump (nth 3 form))) + form + ;; Set up things for a lexically-bound function. + (when (and lexical-binding (eq output-type 'lambda)) + ;; See how many arguments there are, and set the current stack depth + ;; accordingly. + (setq byte-compile-depth (length byte-compile-lexical-environment)) + ;; If there are args, output a tag to record the initial + ;; stack-depth for the optimizer. + (when (> byte-compile-depth 0) + (byte-compile-out-tag (byte-compile-make-tag)))) + ;; Now compile FORM + (byte-compile-form form for-effect) + (byte-compile-out-toplevel for-effect output-type)))) (defun byte-compile-out-toplevel (&optional for-effect output-type) (if for-effect @@ -2778,6 +2896,7 @@ If FORM is a lambda or a macro, byte-compile it as a function." ;; Given BYTECOMP-BODY, compile it and return a new body. (defun byte-compile-top-level-body (bytecomp-body &optional for-effect) + ;; FIXME: lexbind. Check all callers! (setq bytecomp-body (byte-compile-top-level (cons 'progn bytecomp-body) for-effect t)) (cond ((eq (car-safe bytecomp-body) 'progn) @@ -2811,7 +2930,6 @@ If FORM is a lambda or a macro, byte-compile it as a function." ;; (Use byte-compile-form-do-effect to reset the for-effect flag too.) ;; (defun byte-compile-form (form &optional for-effect) - (setq form (macroexpand form byte-compile-macro-environment)) (cond ((not (consp form)) (cond ((or (not (symbolp form)) (byte-compile-const-symbol-p form)) (when (symbolp form) @@ -2821,7 +2939,8 @@ If FORM is a lambda or a macro, byte-compile it as a function." (when (symbolp form) (byte-compile-set-symbol-position form)) (setq for-effect nil)) - (t (byte-compile-variable-ref 'byte-varref form)))) + (t + (byte-compile-variable-ref form)))) ((symbolp (car form)) (let* ((bytecomp-fn (car form)) (bytecomp-handler (get bytecomp-fn 'byte-compile))) @@ -2835,16 +2954,21 @@ That command is designed for interactive use only" bytecomp-fn)) (if (memq bytecomp-fn '(custom-declare-group custom-declare-variable custom-declare-face)) - (byte-compile-nogroup-warn form)) + (byte-compile-nogroup-warn form)) (byte-compile-callargs-warn form)) + (if (and (fboundp (car form)) + (eq (car-safe (symbol-function (car form))) 'macro)) + (byte-compile-report-error + (format "Forgot to expand macro %s" (car form)))) (if (and bytecomp-handler ;; Make sure that function exists. This is important ;; for CL compiler macros since the symbol may be ;; `cl-byte-compile-compiler-macro' but if CL isn't ;; loaded, this function doesn't exist. - (or (not (memq bytecomp-handler - '(cl-byte-compile-compiler-macro))) - (functionp bytecomp-handler))) + (and (not (eq bytecomp-handler + ;; Already handled by macroexpand-all. + 'cl-byte-compile-compiler-macro)) + (functionp bytecomp-handler))) (funcall bytecomp-handler form) (byte-compile-normal-call form)) (if (byte-compile-warning-enabled-p 'cl-functions) @@ -2872,44 +2996,67 @@ That command is designed for interactive use only" bytecomp-fn)) (mapc 'byte-compile-form (cdr form)) ; wasteful, but faster. (byte-compile-out 'byte-call (length (cdr form)))) -(defun byte-compile-variable-ref (base-op bytecomp-var) - (when (symbolp bytecomp-var) - (byte-compile-set-symbol-position bytecomp-var)) - (if (or (not (symbolp bytecomp-var)) - (byte-compile-const-symbol-p bytecomp-var - (not (eq base-op 'byte-varref)))) - (if (byte-compile-warning-enabled-p 'constants) - (byte-compile-warn - (cond ((eq base-op 'byte-varbind) "attempt to let-bind %s `%s'") - ((eq base-op 'byte-varset) "variable assignment to %s `%s'") - (t "variable reference to %s `%s'")) - (if (symbolp bytecomp-var) "constant" "nonvariable") - (prin1-to-string bytecomp-var))) - (and (get bytecomp-var 'byte-obsolete-variable) - (not (memq bytecomp-var byte-compile-not-obsolete-vars)) - (byte-compile-warn-obsolete bytecomp-var)) - (if (eq base-op 'byte-varbind) - (push bytecomp-var byte-compile-bound-variables) - (or (not (byte-compile-warning-enabled-p 'free-vars)) - (boundp bytecomp-var) - (memq bytecomp-var byte-compile-bound-variables) - (if (eq base-op 'byte-varset) - (or (memq bytecomp-var byte-compile-free-assignments) - (progn - (byte-compile-warn "assignment to free variable `%s'" - bytecomp-var) - (push bytecomp-var byte-compile-free-assignments))) - (or (memq bytecomp-var byte-compile-free-references) - (progn - (byte-compile-warn "reference to free variable `%s'" - bytecomp-var) - (push bytecomp-var byte-compile-free-references))))))) - (let ((tmp (assq bytecomp-var byte-compile-variables))) +(defun byte-compile-check-variable (var &optional binding) + "Do various error checks before a use of the variable VAR. +If BINDING is non-nil, VAR is being bound." + (when (symbolp var) + (byte-compile-set-symbol-position var)) + (cond ((or (not (symbolp var)) (byte-compile-const-symbol-p var)) + (when (byte-compile-warning-enabled-p 'constants) + (byte-compile-warn (if binding + "attempt to let-bind %s `%s`" + "variable reference to %s `%s'") + (if (symbolp var) "constant" "nonvariable") + (prin1-to-string var)))) + ((and (get var 'byte-obsolete-variable) + (not (memq var byte-compile-not-obsolete-vars))) + (byte-compile-warn-obsolete var)))) + +(defsubst byte-compile-dynamic-variable-op (base-op var) + (let ((tmp (assq var byte-compile-variables))) (unless tmp - (setq tmp (list bytecomp-var)) + (setq tmp (list var)) (push tmp byte-compile-variables)) (byte-compile-out base-op tmp))) +(defun byte-compile-dynamic-variable-bind (var) + "Generate code to bind the lexical variable VAR to the top-of-stack value." + (byte-compile-check-variable var t) + (push var byte-compile-bound-variables) + (byte-compile-dynamic-variable-op 'byte-varbind var)) + +(defun byte-compile-variable-ref (var) + "Generate code to push the value of the variable VAR on the stack." + (byte-compile-check-variable var) + (let ((lex-binding (assq var byte-compile-lexical-environment))) + (if lex-binding + ;; VAR is lexically bound + (byte-compile-stack-ref (cdr lex-binding)) + ;; VAR is dynamically bound + (unless (or (not (byte-compile-warning-enabled-p 'free-vars)) + (boundp var) + (memq var byte-compile-bound-variables) + (memq var byte-compile-free-references)) + (byte-compile-warn "reference to free variable `%s'" var) + (push var byte-compile-free-references)) + (byte-compile-dynamic-variable-op 'byte-varref var)))) + +(defun byte-compile-variable-set (var) + "Generate code to set the variable VAR from the top-of-stack value." + (byte-compile-check-variable var) + (let ((lex-binding (assq var byte-compile-lexical-environment))) + (if lex-binding + ;; VAR is lexically bound + (byte-compile-stack-set (cdr lex-binding)) + ;; VAR is dynamically bound + (unless (or (not (byte-compile-warning-enabled-p 'free-vars)) + (boundp var) + (memq var byte-compile-bound-variables) + (memq var byte-compile-free-assignments)) + (byte-compile-warn "assignment to free variable `%s'" var) + (push var byte-compile-free-assignments)) + (byte-compile-dynamic-variable-op 'byte-varset var)))) + (defmacro byte-compile-get-constant (const) `(or (if (stringp ,const) ;; In a string constant, treat properties as significant. @@ -2936,6 +3083,25 @@ That command is designed for interactive use only" bytecomp-fn)) (let ((for-effect nil)) (inline (byte-compile-constant const)))) +(defun byte-compile-push-unknown-constant (&optional id) + "Generate code to push a `constant' who's value isn't known yet. +A tag is returned which may then later be passed to +`byte-compile-resolve-unknown-constant' to finalize the value. +The optional argument ID is a tag returned by an earlier call to +`byte-compile-push-unknown-constant', in which case the same constant is +pushed again." + (unless id + (setq id (list (make-symbol "unknown"))) + (push id byte-compile-constants)) + (byte-compile-out 'byte-constant id) + id) + +(defun byte-compile-resolve-unknown-constant (id value) + "Give an `unknown constant' a value. +ID is the tag returned by `byte-compile-push-unknown-constant'. and VALUE +is the value it should have." + (setcar id value)) + ;; Compile those primitive ordinary functions ;; which have special byte codes just for speed. @@ -3006,7 +3172,6 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\"" (byte-defop-compiler bobp 0) (byte-defop-compiler current-buffer 0) ;;(byte-defop-compiler read-char 0) ;; obsolete -(byte-defop-compiler interactive-p 0) (byte-defop-compiler widen 0) (byte-defop-compiler end-of-line 0-1) (byte-defop-compiler forward-char 0-1) @@ -3139,8 +3304,40 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\"" (defun byte-compile-noop (form) (byte-compile-constant nil)) -(defun byte-compile-discard () - (byte-compile-out 'byte-discard 0)) +(defun byte-compile-discard (&optional num preserve-tos) + "Output byte codes to discard the NUM entries at the top of the stack (NUM defaults to 1). +If PRESERVE-TOS is non-nil, preserve the top-of-stack value, as if it were +popped before discarding the num values, and then pushed back again after +discarding." + (if (and (null num) (not preserve-tos)) + ;; common case + (byte-compile-out 'byte-discard) + ;; general case + (unless num + (setq num 1)) + (when (and preserve-tos (> num 0)) + ;; Preserve the top-of-stack value by writing it directly to the stack + ;; location which will be at the top-of-stack after popping. + (byte-compile-stack-set (1- (- byte-compile-depth num))) + ;; Now we actually discard one less value, since we want to keep + ;; the eventual TOS + (setq num (1- num))) + (while (> num 0) + (byte-compile-out 'byte-discard) + (setq num (1- num))))) + +(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." + (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 (- byte-compile-depth (1+ stack-pos)))) ;; Compile a function that accepts one or more args and is right-associative. @@ -3299,40 +3496,14 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\"" the syntax (function (lambda (...) ...)) instead."))))) (byte-compile-two-args form)) -(defun byte-compile-funarg (form) - ;; (mapcar '(lambda (x) ..) ..) ==> (mapcar (function (lambda (x) ..)) ..) - ;; for cases where it's guaranteed that first arg will be used as a lambda. - (byte-compile-normal-call - (let ((fn (nth 1 form))) - (if (and (eq (car-safe fn) 'quote) - (eq (car-safe (nth 1 fn)) 'lambda)) - (cons (car form) - (cons (cons 'function (cdr fn)) - (cdr (cdr form)))) - form)))) - -(defun byte-compile-funarg-2 (form) - ;; (sort ... '(lambda (x) ..)) ==> (sort ... (function (lambda (x) ..))) - ;; for cases where it's guaranteed that second arg will be used as a lambda. - (byte-compile-normal-call - (let ((fn (nth 2 form))) - (if (and (eq (car-safe fn) 'quote) - (eq (car-safe (nth 1 fn)) 'lambda)) - (cons (car form) - (cons (nth 1 form) - (cons (cons 'function (cdr fn)) - (cdr (cdr (cdr form)))))) - form)))) - ;; (function foo) must compile like 'foo, not like (symbol-function 'foo). ;; Otherwise it will be incompatible with the interpreter, ;; and (funcall (function foo)) will lose with autoloads. (defun byte-compile-function-form (form) - (byte-compile-constant - (cond ((symbolp (nth 1 form)) - (nth 1 form)) - ((byte-compile-lambda (nth 1 form)))))) + (if (symbolp (nth 1 form)) + (byte-compile-constant (nth 1 form)) + (byte-compile-closure (nth 1 form)))) (defun byte-compile-indent-to (form) (let ((len (length form))) @@ -3376,7 +3547,7 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\"" (byte-compile-form (car (cdr bytecomp-args))) (or for-effect (cdr (cdr bytecomp-args)) (byte-compile-out 'byte-dup 0)) - (byte-compile-variable-ref 'byte-varset (car bytecomp-args)) + (byte-compile-variable-set (car bytecomp-args)) (setq bytecomp-args (cdr (cdr bytecomp-args)))) ;; (setq), with no arguments. (byte-compile-form nil for-effect)) @@ -3442,18 +3613,8 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\"" (byte-defop-compiler-1 or) (byte-defop-compiler-1 while) (byte-defop-compiler-1 funcall) -(byte-defop-compiler-1 apply byte-compile-funarg) -(byte-defop-compiler-1 mapcar byte-compile-funarg) -(byte-defop-compiler-1 mapatoms byte-compile-funarg) -(byte-defop-compiler-1 mapconcat byte-compile-funarg) -(byte-defop-compiler-1 mapc byte-compile-funarg) -(byte-defop-compiler-1 maphash byte-compile-funarg) -(byte-defop-compiler-1 map-char-table byte-compile-funarg) -(byte-defop-compiler-1 map-char-table byte-compile-funarg-2) -;; map-charset-chars should be funarg but has optional third arg -(byte-defop-compiler-1 sort byte-compile-funarg-2) (byte-defop-compiler-1 let) -(byte-defop-compiler-1 let*) +(byte-defop-compiler-1 let* byte-compile-let) (defun byte-compile-progn (form) (byte-compile-body-do-effect (cdr form))) @@ -3518,9 +3679,7 @@ that suppresses all warnings during execution of BODY." ,condition (list 'boundp 'default-boundp))) ;; Maybe add to the bound list. (byte-compile-bound-variables - (if bound-list - (append bound-list byte-compile-bound-variables) - byte-compile-bound-variables))) + (append bound-list byte-compile-bound-variables))) (unwind-protect ;; If things not being bound at all is ok, so must them being obsolete. ;; Note that we add to the existing lists since Tramp (ab)uses @@ -3646,34 +3805,120 @@ that suppresses all warnings during execution of BODY." (mapc 'byte-compile-form (cdr form)) (byte-compile-out 'byte-call (length (cdr (cdr form))))) + +;; let binding + +(defun byte-compile-push-binding-init (clause) + "Emit byte-codes to push the initialization value for CLAUSE on the stack. +Return the offset in the form (VAR . OFFSET)." + (let* ((var (if (consp clause) (car clause) clause))) + ;; We record the stack position even of dynamic bindings and + ;; variables in non-stack lexical environments; we'll put + ;; them in the proper place below. + (prog1 (cons var byte-compile-depth) + (if (consp clause) + (byte-compile-form (cadr clause)) + (byte-compile-push-constant nil))))) + +(defun byte-compile-not-lexical-var-p (var) + (or (not (symbolp var)) + (special-variable-p var) + (memq var byte-compile-bound-variables) + (memq var '(nil t)) + (keywordp var))) + +(defun byte-compile-bind (var init-lexenv) + "Emit byte-codes to bind VAR and update `byte-compile-lexical-environment'. +INIT-LEXENV should be a lexical-environment alist describing the +positions of the init value that have been pushed on the stack. +Return non-nil if the TOS value was popped." + ;; The presence of lexical bindings mean that we may have to + ;; juggle things on the stack, to move them to TOS for + ;; dynamic binding. + (cond ((not (byte-compile-not-lexical-var-p var)) + ;; VAR is a simple stack-allocated lexical variable + (push (assq var init-lexenv) + byte-compile-lexical-environment) + nil) + ((eq var (caar init-lexenv)) + ;; VAR is dynamic and is on the top of the + ;; stack, so we can just bind it like usual + (byte-compile-dynamic-variable-bind var) + t) + (t + ;; VAR is dynamic, but we have to get its + ;; value out of the middle of the stack + (let ((stack-pos (cdr (assq var init-lexenv)))) + (byte-compile-stack-ref stack-pos) + (byte-compile-dynamic-variable-bind var) + ;; Now we have to store nil into its temporary + ;; stack position to avoid problems with GC + (byte-compile-push-constant nil) + (byte-compile-stack-set stack-pos)) + nil))) + +(defun byte-compile-unbind (clauses init-lexenv + &optional preserve-body-value) + "Emit byte-codes to unbind the variables bound by CLAUSES. +CLAUSES is a `let'-style variable binding list. INIT-LEXENV should be a +lexical-environment alist describing the positions of the init value that +have been pushed on the stack. If PRESERVE-BODY-VALUE is true, +then an additional value on the top of the stack, above any lexical binding +slots, is preserved, so it will be on the top of the stack after all +binding slots have been popped." + ;; Unbind dynamic variables + (let ((num-dynamic-bindings 0)) + (dolist (clause clauses) + (unless (assq (if (consp clause) (car clause) clause) + byte-compile-lexical-environment) + (setq num-dynamic-bindings (1+ num-dynamic-bindings)))) + (unless (zerop num-dynamic-bindings) + (byte-compile-out 'byte-unbind num-dynamic-bindings))) + ;; Pop lexical variables off the stack, possibly preserving the + ;; return value of the body. + (when init-lexenv + ;; INIT-LEXENV contains all init values left on the stack + (byte-compile-discard (length init-lexenv) preserve-body-value))) (defun byte-compile-let (form) - ;; First compute the binding values in the old scope. - (let ((varlist (car (cdr form)))) - (dolist (var varlist) - (if (consp var) - (byte-compile-form (car (cdr var))) - (byte-compile-push-constant nil)))) - (let ((byte-compile-bound-variables byte-compile-bound-variables) ;new scope - (varlist (reverse (car (cdr form))))) - (dolist (var varlist) - (byte-compile-variable-ref 'byte-varbind - (if (consp var) (car var) var))) - (byte-compile-body-do-effect (cdr (cdr form))) - (byte-compile-out 'byte-unbind (length (car (cdr form)))))) - -(defun byte-compile-let* (form) - (let ((byte-compile-bound-variables byte-compile-bound-variables) ;new scope - (varlist (copy-sequence (car (cdr form))))) - (dolist (var varlist) - (if (atom var) - (byte-compile-push-constant nil) - (byte-compile-form (car (cdr var))) - (setq var (car var))) - (byte-compile-variable-ref 'byte-varbind var)) - (byte-compile-body-do-effect (cdr (cdr form))) - (byte-compile-out 'byte-unbind (length (car (cdr form)))))) + "Generate code for the `let' form FORM." + (let ((clauses (cadr form)) + (init-lexenv nil)) + (when (eq (car form) 'let) + ;; First compute the binding values in the old scope. + (dolist (var clauses) + (push (byte-compile-push-binding-init var) init-lexenv))) + ;; New scope. + (let ((byte-compile-bound-variables byte-compile-bound-variables) + (byte-compile-lexical-environment byte-compile-lexical-environment)) + ;; Bind the variables. + ;; For `let', do it in reverse order, because it makes no + ;; semantic difference, but it is a lot more efficient since the + ;; values are now in reverse order on the stack. + (dolist (var (if (eq (car form) 'let) (reverse clauses) clauses)) + (unless (eq (car form) 'let) + (push (byte-compile-push-binding-init var) init-lexenv)) + (let ((var (if (consp var) (car var) var))) + (cond ((null lexical-binding) + ;; If there are no lexical bindings, we can do things simply. + (byte-compile-dynamic-variable-bind var)) + ((byte-compile-bind var init-lexenv) + (pop init-lexenv))))) + ;; Emit the body. + (let ((init-stack-depth byte-compile-depth)) + (byte-compile-body-do-effect (cdr (cdr form))) + ;; Unbind the variables. + (if lexical-binding + ;; Unbind both lexical and dynamic variables. + (progn + (assert (or (eq byte-compile-depth init-stack-depth) + (eq byte-compile-depth (1+ init-stack-depth)))) + (byte-compile-unbind clauses init-lexenv (> byte-compile-depth + init-stack-depth))) + ;; Unbind dynamic variables. + (byte-compile-out 'byte-unbind (length clauses))))))) + (byte-defop-compiler-1 /= byte-compile-negated) (byte-defop-compiler-1 atom byte-compile-negated) @@ -3696,6 +3941,7 @@ that suppresses all warnings during execution of BODY." "Compiler error: `%s' has no `byte-compile-negated-op' property" (car form))) (cdr form)))) + ;;; other tricky macro-like special-forms @@ -3705,70 +3951,84 @@ that suppresses all warnings during execution of BODY." (byte-defop-compiler-1 save-excursion) (byte-defop-compiler-1 save-current-buffer) (byte-defop-compiler-1 save-restriction) -(byte-defop-compiler-1 save-window-excursion) -(byte-defop-compiler-1 with-output-to-temp-buffer) (byte-defop-compiler-1 track-mouse) (defun byte-compile-catch (form) (byte-compile-form (car (cdr form))) - (byte-compile-push-constant - (byte-compile-top-level (cons 'progn (cdr (cdr form))) for-effect)) + (pcase (cddr form) + (`(:fun-body ,f) + (byte-compile-form `(list 'funcall ,f))) + (body + (byte-compile-push-constant + (byte-compile-top-level (cons 'progn body) for-effect)))) (byte-compile-out 'byte-catch 0)) (defun byte-compile-unwind-protect (form) - (byte-compile-push-constant - (byte-compile-top-level-body (cdr (cdr form)) t)) + (pcase (cddr form) + (`(:fun-body ,f) + (byte-compile-form `(list (list 'funcall ,f)))) + (handlers + (byte-compile-push-constant + (byte-compile-top-level-body handlers t)))) (byte-compile-out 'byte-unwind-protect 0) (byte-compile-form-do-effect (car (cdr form))) (byte-compile-out 'byte-unbind 1)) (defun byte-compile-track-mouse (form) (byte-compile-form - `(funcall '(lambda nil - (track-mouse ,@(byte-compile-top-level-body (cdr form))))))) + (pcase form + (`(,_ :fun-body ,f) `(eval (list 'track-mouse (list 'funcall ,f)))) + (_ `(eval '(track-mouse ,@(byte-compile-top-level-body (cdr form)))))))) (defun byte-compile-condition-case (form) (let* ((var (nth 1 form)) - (byte-compile-bound-variables - (if var (cons var byte-compile-bound-variables) + (fun-bodies (eq var :fun-body)) + (byte-compile-bound-variables + (if (and var (not fun-bodies)) + (cons var byte-compile-bound-variables) byte-compile-bound-variables))) (byte-compile-set-symbol-position 'condition-case) (unless (symbolp var) (byte-compile-warn "`%s' is not a variable-name or nil (in condition-case)" var)) + (if fun-bodies (setq var (make-symbol "err"))) (byte-compile-push-constant var) - (byte-compile-push-constant (byte-compile-top-level - (nth 2 form) for-effect)) - (let ((clauses (cdr (cdr (cdr form)))) - compiled-clauses) - (while clauses - (let* ((clause (car clauses)) - (condition (car clause))) - (cond ((not (or (symbolp condition) - (and (listp condition) - (let ((syms condition) (ok t)) - (while syms - (if (not (symbolp (car syms))) - (setq ok nil)) - (setq syms (cdr syms))) - ok)))) - (byte-compile-warn - "`%s' is not a condition name or list of such (in condition-case)" - (prin1-to-string condition))) -;; ((not (or (eq condition 't) -;; (and (stringp (get condition 'error-message)) -;; (consp (get condition 'error-conditions))))) -;; (byte-compile-warn -;; "`%s' is not a known condition name (in condition-case)" -;; condition)) - ) - (setq compiled-clauses - (cons (cons condition - (byte-compile-top-level-body - (cdr clause) for-effect)) - compiled-clauses))) - (setq clauses (cdr clauses))) - (byte-compile-push-constant (nreverse compiled-clauses))) + (if fun-bodies + (byte-compile-form `(list 'funcall ,(nth 2 form))) + (byte-compile-push-constant + (byte-compile-top-level (nth 2 form) for-effect))) + (let ((compiled-clauses + (mapcar + (lambda (clause) + (let ((condition (car clause))) + (cond ((not (or (symbolp condition) + (and (listp condition) + (let ((ok t)) + (dolist (sym condition) + (if (not (symbolp sym)) + (setq ok nil))) + ok)))) + (byte-compile-warn + "`%S' is not a condition name or list of such (in condition-case)" + condition)) + ;; (not (or (eq condition 't) + ;; (and (stringp (get condition 'error-message)) + ;; (consp (get condition + ;; 'error-conditions))))) + ;; (byte-compile-warn + ;; "`%s' is not a known condition name + ;; (in condition-case)" + ;; condition)) + ) + (if fun-bodies + `(list ',condition (list 'funcall ,(cadr clause) ',var)) + (cons condition + (byte-compile-top-level-body + (cdr clause) for-effect))))) + (cdr (cdr (cdr form)))))) + (if fun-bodies + (byte-compile-form `(list ,@compiled-clauses)) + (byte-compile-push-constant compiled-clauses))) (byte-compile-out 'byte-condition-case 0))) @@ -3789,17 +4049,6 @@ that suppresses all warnings during execution of BODY." (byte-compile-out 'byte-save-current-buffer 0) (byte-compile-body-do-effect (cdr form)) (byte-compile-out 'byte-unbind 1)) - -(defun byte-compile-save-window-excursion (form) - (byte-compile-push-constant - (byte-compile-top-level-body (cdr form) for-effect)) - (byte-compile-out 'byte-save-window-excursion 0)) - -(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 @@ -3816,28 +4065,23 @@ that suppresses all warnings during execution of BODY." (byte-compile-set-symbol-position (car form)) (byte-compile-set-symbol-position 'defun) (error "defun name must be a symbol, not %s" (car form))) - ;; We prefer to generate a defalias form so it will record the function - ;; definition just like interpreting a defun. - (byte-compile-form - (list 'defalias - (list 'quote (nth 1 form)) - (byte-compile-byte-code-maker - (byte-compile-lambda (cdr (cdr form)) t))) - t) - (byte-compile-constant (nth 1 form))) + (let ((for-effect nil)) + (byte-compile-push-constant 'defalias) + (byte-compile-push-constant (nth 1 form)) + (byte-compile-closure (cdr (cdr form)) t)) + (byte-compile-out 'byte-call 2)) (defun byte-compile-defmacro (form) ;; This is not used for file-level defmacros with doc strings. - (byte-compile-body-do-effect - (let ((decls (byte-compile-defmacro-declaration form)) - (code (byte-compile-byte-code-maker - (byte-compile-lambda (cdr (cdr form)) t)))) - `((defalias ',(nth 1 form) - ,(if (eq (car-safe code) 'make-byte-code) - `(cons 'macro ,code) - `'(macro . ,(eval code)))) - ,@decls - ',(nth 1 form))))) + ;; FIXME handle decls, use defalias? + (let ((decls (byte-compile-defmacro-declaration form)) + (code (byte-compile-lambda (cdr (cdr form)) t)) + (for-effect nil)) + (byte-compile-push-constant (nth 1 form)) + (byte-compile-push-constant (cons 'macro code)) + (byte-compile-out 'byte-fset) + (byte-compile-discard)) + (byte-compile-constant (nth 1 form))) (defun byte-compile-defvar (form) ;; This is not used for file-level defvar/consts with doc strings. @@ -3868,7 +4112,7 @@ that suppresses all warnings during execution of BODY." ;; Put the defined variable in this library's load-history entry ;; just as a real defvar would, but only in top-level forms. (when (and (cddr form) (null byte-compile-current-form)) - `(push ',var current-load-list)) + `(setq current-load-list (cons ',var current-load-list))) (when (> (length form) 3) (when (and string (not (stringp string))) (byte-compile-warn "third arg to `%s %s' is not a string: %s" @@ -3885,7 +4129,7 @@ that suppresses all warnings during execution of BODY." `(if (not (default-boundp ',var)) (setq-default ,var ,value)))) (when (eq fun 'defconst) ;; This will signal an appropriate error at runtime. - `(eval ',form))) + `(eval ',form))) ;FIXME: lexbind `',var)))) (defun byte-compile-autoload (form) @@ -3977,8 +4221,8 @@ that suppresses all warnings during execution of BODY." (progn ;; ## remove this someday (and byte-compile-depth - (not (= (cdr (cdr tag)) byte-compile-depth)) - (error "Compiler bug: depth conflict at tag %d" (car (cdr tag)))) + (not (= (cdr (cdr tag)) byte-compile-depth)) + (error "Compiler bug: depth conflict at tag %d" (car (cdr tag)))) (setq byte-compile-depth (cdr (cdr tag)))) (setcdr (cdr tag) byte-compile-depth))) @@ -3990,23 +4234,74 @@ that suppresses all warnings during execution of BODY." (setq byte-compile-depth (and (not (eq opcode 'byte-goto)) (1- byte-compile-depth)))) -(defun byte-compile-out (opcode offset) - (push (cons opcode offset) byte-compile-output) - (cond ((eq opcode 'byte-call) - (setq byte-compile-depth (- byte-compile-depth offset))) - ((eq opcode 'byte-return) - ;; This is actually an unnecessary case, because there should be - ;; no more opcodes behind byte-return. - (setq byte-compile-depth nil)) - (t - (setq byte-compile-depth (+ byte-compile-depth - (or (aref byte-stack+-info - (symbol-value opcode)) - (- (1- offset)))) - byte-compile-maxdepth (max byte-compile-depth - byte-compile-maxdepth)))) - ;;(if (< byte-compile-depth 0) (error "Compiler error: stack underflow")) - ) +(defun byte-compile-stack-adjustment (op operand) + "Return the amount by which an operation adjusts the stack. +OP and OPERAND are as passed to `byte-compile-out'." + (if (memq op '(byte-call byte-discardN byte-discardN-preserve-tos)) + ;; For calls, OPERAND is the number of args, so we pop OPERAND + 1 + ;; elements, and the push the result, for a total of -OPERAND. + ;; For discardN*, of course, we just pop OPERAND elements. + (- operand) + (or (aref byte-stack+-info (symbol-value op)) + ;; Ops with a nil entry in `byte-stack+-info' are byte-codes + ;; that take OPERAND values off the stack and push a result, for + ;; a total of 1 - OPERAND + (- 1 operand)))) + +(defun byte-compile-out (op &optional operand) + (push (cons op operand) byte-compile-output) + (if (eq op 'byte-return) + ;; This is actually an unnecessary case, because there should be no + ;; more ops behind byte-return. + (setq byte-compile-depth nil) + (setq byte-compile-depth + (+ byte-compile-depth (byte-compile-stack-adjustment op operand))) + (setq byte-compile-maxdepth (max byte-compile-depth byte-compile-maxdepth)) + ;;(if (< byte-compile-depth 0) (error "Compiler error: stack underflow")) + )) + +(defun byte-compile-delay-out (&optional stack-used stack-adjust) + "Add a placeholder to the output, which can be used to later add byte-codes. +Return a position tag that can be passed to `byte-compile-delayed-out' +to add the delayed byte-codes. STACK-USED is the maximum amount of +stack-spaced used by the delayed byte-codes (defaulting to 0), and +STACK-ADJUST is the amount by which the later-added code will adjust the +stack (defaulting to 0); the byte-codes added later _must_ adjust the +stack by this amount! If STACK-ADJUST is 0, then it's not necessary to +actually add anything later; the effect as if nothing was added at all." + ;; We just add a no-op to `byte-compile-output', and return a pointer to + ;; the tail of the list; `byte-compile-delayed-out' uses list surgery + ;; to add the byte-codes. + (when stack-used + (setq byte-compile-maxdepth + (max byte-compile-depth (+ byte-compile-depth (or stack-used 0))))) + (when stack-adjust + (setq byte-compile-depth + (+ byte-compile-depth stack-adjust))) + (push (cons nil (or stack-adjust 0)) byte-compile-output)) + +(defun byte-compile-delayed-out (position op &optional operand) + "Add at POSITION the byte-operation OP, with optional numeric arg OPERAND. +POSITION should a position returned by `byte-compile-delay-out'. +Return a new position, which can be used to add further operations." + (unless (null (caar position)) + (error "Bad POSITION arg to `byte-compile-delayed-out'")) + ;; This is kind of like `byte-compile-out', but we splice into the list + ;; where POSITION is. We don't bother updating `byte-compile-maxdepth' + ;; because that was already done by `byte-compile-delay-out', but we do + ;; update the relative operand stored in the no-op marker currently at + ;; POSITION; since we insert before that marker, this means that if the + ;; caller doesn't insert a sequence of byte-codes that matches the expected + ;; operand passed to `byte-compile-delay-out', then the nop will still have + ;; a non-zero operand when `byte-compile-lapcode' is called, which will + ;; cause an error to be signaled. + + ;; Adjust the cumulative stack-adjustment stored in the cdr of the no-op + (setcdr (car position) + (- (cdar position) (byte-compile-stack-adjustment op operand))) + ;; Add the new operation onto the list tail at POSITION + (setcdr position (cons (cons op operand) (cdr position))) + position) ;;; call tree stuff diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el new file mode 100644 index 00000000000..66e5051c2f1 --- /dev/null +++ b/lisp/emacs-lisp/cconv.el @@ -0,0 +1,878 @@ +;;; cconv.el --- Closure conversion for statically scoped Emacs lisp. -*- lexical-binding: t -*- + +;; Copyright (C) 2011 Free Software Foundation, Inc. + +;; Author: Igor Kuzmin <kzuminig@iro.umontreal.ca> +;; Maintainer: FSF +;; Keywords: lisp +;; Package: emacs + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This takes a piece of Elisp code, and eliminates all free variables from +;; lambda expressions. The user entry points are cconv-closure-convert and +;; cconv-closure-convert-toplevel(for toplevel forms). +;; All macros should be expanded beforehand. +;; +;; Here is a brief explanation how this code works. +;; Firstly, we analyse the tree by calling cconv-analyse-form. +;; This function finds all mutated variables, all functions that are suitable +;; for lambda lifting and all variables captured by closure. It passes the tree +;; once, returning a list of three lists. +;; +;; Then we calculate the intersection of first and third lists returned by +;; cconv-analyse form to find all mutated variables that are captured by +;; closure. + +;; Armed with this data, we call cconv-closure-convert-rec, that rewrites the +;; tree recursivly, lifting lambdas where possible, building closures where it +;; is needed and eliminating mutable variables used in closure. +;; +;; We do following replacements : +;; (lambda (v1 ...) ... fv1 fv2 ...) => (lambda (v1 ... fv1 fv2 ) ... fv1 fv2 .) +;; if the function is suitable for lambda lifting (if all calls are known) +;; +;; (lambda (v1 ...) ... fv ...) => +;; (curry (lambda (env v1 ...) ... env ...) env) +;; if the function has only 1 free variable +;; +;; and finally +;; (lambda (v1 ...) ... fv1 fv2 ...) => +;; (curry (lambda (env v1 ..) .. (aref env 0) (aref env 1) ..) (vector fv1 fv2)) +;; if the function has 2 or more free variables. +;; +;; If the function has no free variables, we don't do anything. +;; +;; If a variable is mutated (updated by setq), and it is used in a closure +;; we wrap it's definition with list: (list val) and we also replace +;; var => (car var) wherever this variable is used, and also +;; (setq var value) => (setcar var value) where it is updated. +;; +;; If defun argument is closure mutable, we letbind it and wrap it's +;; definition with list. +;; (defun foo (... mutable-arg ...) ...) => +;; (defun foo (... m-arg ...) (let ((m-arg (list m-arg))) ...)) +;; +;;; 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). +;; - 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)) + +(defconst cconv-liftwhen 3 + "Try to do lambda lifting if the number of arguments + free variables +is less than this number.") +(defvar cconv-mutated nil + "List of mutated variables in current form") +(defvar cconv-captured nil + "List of closure captured variables in current form") +(defvar cconv-captured+mutated nil + "An intersection between cconv-mutated and cconv-captured lists.") +(defvar cconv-lambda-candidates nil + "List of candidates for lambda lifting. +Each candidate has the form (VAR INCLOSURE BINDER PARENTFORM).") + +(defun cconv-freevars (form &optional fvrs) + "Find all free variables of given form. +Arguments: +-- FORM is a piece of Elisp code after macroexpansion. +-- FVRS(optional) is a list of variables already found. Used for recursive tree +traversal + +Returns a list of free variables." + ;; If a leaf in the tree is a symbol, but it is not a global variable, not a + ;; keyword, not 'nil or 't we consider this leaf as a variable. + ;; Free variables are the variables that are not declared above in this tree. + ;; For example free variables of (lambda (a1 a2 ..) body-forms) are + ;; free variables of body-forms excluding a1, a2 .. + ;; Free variables of (let ((v1 ..) (v2) ..)) body-forms) are + ;; free variables of body-forms excluding v1, v2 ... + ;; and so on. + + ;; A list of free variables already found(FVRS) is passed in parameter + ;; to try to use cons or push where possible, and to minimize the usage + ;; of append. + + ;; This function can return duplicates (because we use 'append instead + ;; of union of two sets - for performance reasons). + (pcase form + (`(let ,varsvalues . ,body-forms) ; let special form + (let ((fvrs-1 '())) + (dolist (exp body-forms) + (setq fvrs-1 (cconv-freevars exp fvrs-1))) + (dolist (elm varsvalues) + (setq fvrs-1 (delq (if (consp elm) (car elm) elm) fvrs-1))) + (setq fvrs (nconc fvrs-1 fvrs)) + (dolist (exp varsvalues) + (when (consp exp) (setq fvrs (cconv-freevars (cadr exp) fvrs)))) + fvrs)) + + (`(let* ,varsvalues . ,body-forms) ; let* special form + (let ((vrs '()) + (fvrs-1 '())) + (dolist (exp varsvalues) + (if (consp exp) + (progn + (setq fvrs-1 (cconv-freevars (cadr exp) fvrs-1)) + (dolist (elm vrs) (setq fvrs-1 (delq elm fvrs-1))) + (push (car exp) vrs)) + (progn + (dolist (elm vrs) (setq fvrs-1 (delq elm fvrs-1))) + (push exp vrs)))) + (dolist (exp body-forms) + (setq fvrs-1 (cconv-freevars exp fvrs-1))) + (dolist (elm vrs) (setq fvrs-1 (delq elm fvrs-1))) + (append fvrs fvrs-1))) + + (`((lambda . ,_) . ,_) ; first element is lambda expression + (dolist (exp `((function ,(car form)) . ,(cdr form))) + (setq fvrs (cconv-freevars exp fvrs))) fvrs) + + (`(cond . ,cond-forms) ; cond special form + (dolist (exp1 cond-forms) + (dolist (exp2 exp1) + (setq fvrs (cconv-freevars exp2 fvrs)))) fvrs) + + (`(quote . ,_) fvrs) ; quote form + + (`(function . ((lambda ,vars . ,body-forms))) + (let ((functionform (cadr form)) (fvrs-1 '())) + (dolist (exp body-forms) + (setq fvrs-1 (cconv-freevars exp fvrs-1))) + (dolist (elm vars) (setq fvrs-1 (delq elm fvrs-1))) + (append fvrs fvrs-1))) ; function form + + (`(function . ,_) fvrs) ; same as quote + ;condition-case + (`(condition-case ,var ,protected-form . ,conditions-bodies) + (let ((fvrs-1 '())) + (dolist (exp conditions-bodies) + (setq fvrs-1 (cconv-freevars (cadr exp) fvrs-1))) + (setq fvrs-1 (delq var fvrs-1)) + (setq fvrs-1 (cconv-freevars protected-form fvrs-1)) + (append fvrs fvrs-1))) + + (`(,(and sym (or `defun `defconst `defvar)) . ,_) + ;; We call cconv-freevars only for functions(lambdas) + ;; defun, defconst, defvar are not allowed to be inside + ;; a function (lambda). + ;; FIXME: should be a byte-compile-report-error! + (error "Invalid form: %s inside a function" sym)) + + (`(,_ . ,body-forms) ; First element is (like) a function. + (dolist (exp body-forms) + (setq fvrs (cconv-freevars exp fvrs))) fvrs) + + (_ (if (byte-compile-not-lexical-var-p form) + fvrs + (cons form fvrs))))) + +;;;###autoload +(defun cconv-closure-convert (form) + "Main entry point for closure conversion. +-- FORM is a piece of Elisp code after macroexpansion. +-- TOPLEVEL(optional) is a boolean variable, true if we are at the root of AST + +Returns a form where all lambdas don't have any free variables." + ;; (message "Entering cconv-closure-convert...") + (let ((cconv-mutated '()) + (cconv-lambda-candidates '()) + (cconv-captured '()) + (cconv-captured+mutated '())) + ;; Analyse form - fill these variables with new information. + (cconv-analyse-form form '() 0) + ;; Calculate an intersection of cconv-mutated and cconv-captured. + (dolist (mvr cconv-mutated) + (when (memq mvr cconv-captured) ; + (push mvr cconv-captured+mutated))) + (cconv-closure-convert-rec + form ; the tree + '() ; + '() ; fvrs initially empty + '() ; envs initially empty + '() + ))) + +(defun cconv--lookup-let (table var binder form) + (let ((res nil)) + (dolist (elem table) + (when (and (eq (nth 2 elem) binder) + (eq (nth 3 elem) form)) + (assert (eq (car elem) var)) + (setq res elem))) + res)) + +(defconst cconv--dummy-var (make-symbol "ignored")) +(defconst cconv--env-var (make-symbol "env")) + +(defun cconv--set-diff (s1 s2) + "Return elements of set S1 that are not in set S2." + (let ((res '())) + (dolist (x s1) + (unless (memq x s2) (push x res))) + (nreverse res))) + +(defun cconv--set-diff-map (s m) + "Return elements of set S that are not in Dom(M)." + (let ((res '())) + (dolist (x s) + (unless (assq x m) (push x res))) + (nreverse res))) + +(defun cconv--map-diff (m1 m2) + "Return the submap of map M1 that has Dom(M2) removed." + (let ((res '())) + (dolist (x m1) + (unless (assq (car x) m2) (push x res))) + (nreverse res))) + +(defun cconv--map-diff-elem (m x) + "Return the map M minus any mapping for X." + ;; Here we assume that X appears at most once in M. + (let* ((b (assq x m)) + (res (if b (remq b m) m))) + (assert (null (assq x res))) ;; Check the assumption was warranted. + res)) + +(defun cconv--map-diff-set (m s) + "Return the map M minus any mapping for elements of S." + ;; Here we assume that X appears at most once in M. + (let ((res '())) + (dolist (b m) + (unless (memq (car b) s) (push b res))) + (nreverse res))) + +(defun cconv-closure-convert-rec (form emvrs fvrs envs lmenvs) + ;; This function actually rewrites the tree. + "Eliminates all free variables of all lambdas in given forms. +Arguments: +-- FORM is a piece of Elisp code after macroexpansion. +-- LMENVS is a list of environments used for lambda-lifting. Initially empty. +-- EMVRS is a list that contains mutated variables that are visible +within current environment. +-- ENVS is an environment(list of free variables) of current closure. +Initially empty. +-- FVRS is a list of variables to substitute in each context. +Initially empty. + +Returns a form where all lambdas don't have any free variables." + ;; What's the difference between fvrs and envs? + ;; Suppose that we have the code + ;; (lambda (..) fvr (let ((fvr 1)) (+ fvr 1))) + ;; only the first occurrence of fvr should be replaced by + ;; (aref env ...). + ;; So initially envs and fvrs are the same thing, but when we descend to + ;; the 'let, we delete fvr from fvrs. Why we don't delete fvr from envs? + ;; Because in envs the order of variables is important. We use this list + ;; to find the number of a specific variable in the environment vector, + ;; so we never touch it(unless we enter to the other closure). + ;;(if (listp form) (print (car form)) form) + (pcase form + (`(,(and letsym (or `let* `let)) ,binders . ,body-forms) + + ; let and let* special forms + (let ((body-forms-new '()) + (binders-new '()) + ;; next for variables needed for delayed push + ;; because we should process <value(s)> + ;; before we change any arguments + (lmenvs-new '()) ;needed only in case of let + (emvrs-new '()) ;needed only in case of let + (emvr-push) ;needed only in case of let* + (lmenv-push)) ;needed only in case of let* + + (dolist (binder binders) + (let* ((value nil) + (var (if (not (consp binder)) + binder + (setq value (cadr binder)) + (car binder))) + (new-val + (cond + ;; Check if var is a candidate for lambda lifting. + ((cconv--lookup-let cconv-lambda-candidates var binder form) + + (let* ((fv (delete-dups (cconv-freevars value '()))) + (funargs (cadr (cadr value))) + (funcvars (append fv funargs)) + (funcbodies (cddadr value)) ; function bodies + (funcbodies-new '())) + ; lambda lifting condition + (if (or (not fv) (< cconv-liftwhen (length funcvars))) + ; do not lift + (cconv-closure-convert-rec + value emvrs fvrs envs lmenvs) + ; lift + (progn + (dolist (elm2 funcbodies) + (push ; convert function bodies + (cconv-closure-convert-rec + elm2 emvrs nil envs lmenvs) + funcbodies-new)) + (if (eq letsym 'let*) + (setq lmenv-push (cons var fv)) + (push (cons var fv) lmenvs-new)) + ; push lifted function + + `(function . + ((lambda ,funcvars . + ,(reverse funcbodies-new)))))))) + + ;; Check if it needs to be turned into a "ref-cell". + ((cconv--lookup-let cconv-captured+mutated var binder form) + ;; Declared variable is mutated and captured. + (prog1 + `(list ,(cconv-closure-convert-rec + value emvrs + fvrs envs lmenvs)) + (if (eq letsym 'let*) + (setq emvr-push var) + (push var emvrs-new)))) + + ;; Normal default case. + (t + (cconv-closure-convert-rec + value emvrs fvrs envs lmenvs))))) + + ;; this piece of code below letbinds free + ;; variables of a lambda lifted function + ;; if they are redefined in this let + ;; example: + ;; (let* ((fun (lambda (x) (+ x y))) (y 1)) (funcall fun 1)) + ;; Here we can not pass y as parameter because it is + ;; redefined. We add a (closed-y y) declaration. + ;; We do that even if the function is not used inside + ;; this let(*). The reason why we ignore this case is + ;; that we can't "look forward" to see if the function + ;; is called there or not. To treat well this case we + ;; need to traverse the tree one more time to collect this + ;; data, and I think that it's not worth it. + + (when (eq letsym 'let*) + (let ((closedsym '()) + (new-lmenv '()) + (old-lmenv '())) + (dolist (lmenv lmenvs) + (when (memq var (cdr lmenv)) + (setq closedsym + (make-symbol + (concat "closed-" (symbol-name var)))) + (setq new-lmenv (list (car lmenv))) + (dolist (frv (cdr lmenv)) (if (eq frv var) + (push closedsym new-lmenv) + (push frv new-lmenv))) + (setq new-lmenv (reverse new-lmenv)) + (setq old-lmenv lmenv))) + (when new-lmenv + (setq lmenvs (remq old-lmenv lmenvs)) + (push new-lmenv lmenvs) + (push `(,closedsym ,var) binders-new)))) + ;; We push the element after redefined free variables are + ;; processed. This is important to avoid the bug when free + ;; variable and the function have the same name. + (push (list var new-val) binders-new) + + (when (eq letsym 'let*) ; update fvrs + (setq fvrs (remq var fvrs)) + (setq emvrs (remq var emvrs)) ; remove if redefined + (when emvr-push + (push emvr-push emvrs) + (setq emvr-push nil)) + (setq lmenvs (cconv--map-diff-elem lmenvs var)) + (when lmenv-push + (push lmenv-push lmenvs) + (setq lmenv-push nil))) + )) ; end of dolist over binders + (when (eq letsym 'let) + + (let (var fvrs-1 emvrs-1 lmenvs-1) + ;; Here we update emvrs, fvrs and lmenvs lists + (setq fvrs (cconv--set-diff-map fvrs binders-new)) + (setq emvrs (cconv--set-diff-map emvrs binders-new)) + (setq emvrs (append emvrs emvrs-new)) + (setq lmenvs (cconv--set-diff-map lmenvs binders-new)) + (setq lmenvs (append lmenvs lmenvs-new))) + + ;; Here we do the same letbinding as for let* above + ;; to avoid situation when a free variable of a lambda lifted + ;; function got redefined. + + (let ((new-lmenv) + (var nil) + (closedsym nil) + (letbinds '())) + (dolist (binder binders) + (setq var (if (consp binder) (car binder) binder)) + + (let ((lmenvs-1 lmenvs)) ; just to avoid manipulating + (dolist (lmenv lmenvs-1) ; the counter inside the loop + (when (memq var (cdr lmenv)) + (setq closedsym (make-symbol + (concat "closed-" + (symbol-name var)))) + + (setq new-lmenv (list (car lmenv))) + (dolist (frv (cdr lmenv)) + (push (if (eq frv var) closedsym frv) + new-lmenv)) + (setq new-lmenv (reverse new-lmenv)) + (setq lmenvs (remq lmenv lmenvs)) + (push new-lmenv lmenvs) + (push `(,closedsym ,var) letbinds) + )))) + (setq binders-new (append binders-new letbinds)))) + + (dolist (elm body-forms) ; convert body forms + (push (cconv-closure-convert-rec + elm emvrs fvrs envs lmenvs) + body-forms-new)) + `(,letsym ,(reverse binders-new) . ,(reverse body-forms-new)))) + ;end of let let* forms + + ; first element is lambda expression + (`(,(and `(lambda . ,_) fun) . ,other-body-forms) + + (let ((other-body-forms-new '())) + (dolist (elm other-body-forms) + (push (cconv-closure-convert-rec + elm emvrs fvrs envs lmenvs) + other-body-forms-new)) + `(funcall + ,(cconv-closure-convert-rec + (list 'function fun) emvrs fvrs envs lmenvs) + ,@(nreverse other-body-forms-new)))) + + (`(cond . ,cond-forms) ; cond special form + (let ((cond-forms-new '())) + (dolist (elm cond-forms) + (push (let ((elm-new '())) + (dolist (elm-2 elm) + (push + (cconv-closure-convert-rec + elm-2 emvrs fvrs envs lmenvs) + elm-new)) + (reverse elm-new)) + cond-forms-new)) + (cons 'cond + (reverse cond-forms-new)))) + + (`(quote . ,_) 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. + (body-forms-new '()) + (letbind '()) + (mv nil) + (envector nil)) + (when fv + ;; Here we form our environment vector. + ;; 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 environment vector. + (if (eq (length envs) (length fv)) + (let ((fv-temp fv)) + (while (and fv-temp leave) + (when (not (memq (car fv-temp) fvrs-new)) (setq leave nil)) + (setq fv-temp (cdr fv-temp)))) + (setq leave nil)) + + (if (not leave) + (progn + (dolist (elm fv) + (push + (cconv-closure-convert-rec + ;; Remove `elm' from `emvrs' for this call because in case + ;; `elm' is a variable that's wrapped in a cons-cell, we + ;; want to put the cons-cell itself in the closure, rather + ;; than just a copy of its current content. + elm (remq elm emvrs) fvrs envs lmenvs) + envector)) ; Process vars for closure vector. + (setq envector (reverse envector)) + (setq envs fv)) + (setq envector `(,cconv--env-var))) ; Leave unchanged. + (setq fvrs-new fv)) ; Update substitution list. + + (setq emvrs (cconv--set-diff emvrs vars)) + (setq lmenvs (cconv--map-diff-set lmenvs vars)) + + ;; The difference between envs and fvrs is explained + ;; in comment in the beginning of the function. + (dolist (elm cconv-captured+mutated) ; Find mutated arguments + (setq mv (car elm)) ; used in inner closures. + (when (and (memq mv vars) (eq form (caddr elm))) + (progn (push mv emvrs) + (push `(,mv (list ,mv)) letbind)))) + (dolist (elm body-forms) ; convert function body + (push (cconv-closure-convert-rec + elm emvrs fvrs-new envs lmenvs) + body-forms-new)) + + (setq body-forms-new + (if letbind `((let ,letbind . ,(reverse body-forms-new))) + (reverse body-forms-new))) + + (cond + ;if no freevars - do nothing + ((null envector) + `(function (lambda ,vars . ,body-forms-new))) + ; 1 free variable - do not build vector + ((null (cdr envector)) + `(curry + (function (lambda (,cconv--env-var . ,vars) . ,body-forms-new)) + ,(car envector))) + ; >=2 free variables - build vector + (t + `(curry + (function (lambda (,cconv--env-var . ,vars) . ,body-forms-new)) + (vector . ,envector)))))) + + (`(function . ,_) form) ; Same as quote. + + ;defconst, defvar + (`(,(and sym (or `defconst `defvar)) ,definedsymbol . ,body-forms) + + (let ((body-forms-new '())) + (dolist (elm body-forms) + (push (cconv-closure-convert-rec + elm emvrs fvrs envs lmenvs) + body-forms-new)) + (setq body-forms-new (reverse body-forms-new)) + `(,sym ,definedsymbol . ,body-forms-new))) + + ;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. + (letbind '())) + ; 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 (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. + (push (car body-forms) body-new) + (setq body-forms (cdr body-forms))) + (when (eq (car-safe (car body-forms)) 'interactive) + (push (cconv-closure-convert-rec + (car body-forms) + emvrs fvrs envs lmenvs) + body-new) + (setq body-forms (cdr body-forms))) + + (dolist (elm body-forms) + (push (cconv-closure-convert-rec + elm emvrs fvrs envs lmenvs) + body-forms-new)) + (setq body-forms-new (reverse body-forms-new)) + + (if letbind + ; Letbind mutable arguments. + (let ((binders-new '())) + (dolist (elm letbind) (push `(,elm (list ,elm)) + binders-new)) + (push `(let ,(reverse binders-new) . + ,body-forms-new) body-new) + (setq body-new (reverse body-new))) + (setq body-new (append (reverse body-new) body-forms-new))) + + `(,sym ,func ,vars . ,body-new))) + + ;condition-case + (`(condition-case ,var ,protected-form . ,handlers) + (let ((handlers-new '()) + (newform (cconv-closure-convert-rec + `(function (lambda () ,protected-form)) + emvrs fvrs envs lmenvs))) + (setq fvrs (remq var fvrs)) + (dolist (handler handlers) + (push (list (car handler) + (cconv-closure-convert-rec + `(function (lambda (,(or var cconv--dummy-var)) + ,@(cdr handler))) + emvrs fvrs envs lmenvs)) + handlers-new)) + `(condition-case :fun-body ,newform + ,@(nreverse handlers-new)))) + + (`(,(and head (or `catch `unwind-protect)) ,form . ,body) + `(,head ,(cconv-closure-convert-rec form emvrs fvrs envs lmenvs) + :fun-body + ,(cconv-closure-convert-rec `(function (lambda () ,@body)) + emvrs fvrs envs lmenvs))) + + (`(track-mouse . ,body) + `(track-mouse + :fun-body + ,(cconv-closure-convert-rec `(function (lambda () ,@body)) + emvrs fvrs envs lmenvs))) + + (`(setq . ,forms) ; setq special form + (let (prognlist sym sym-new value) + (while forms + (setq sym (car forms)) + (setq sym-new (cconv-closure-convert-rec + sym + (remq sym emvrs) fvrs envs lmenvs)) + (setq value + (cconv-closure-convert-rec + (cadr forms) emvrs fvrs envs lmenvs)) + (if (memq sym emvrs) + (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) + `(progn . ,(reverse prognlist)) + (car prognlist)))) + + (`(,(and (or `funcall `apply) callsym) ,fun . ,args) + ; funcall is not a special form + ; but we treat it separately + ; for the needs of lambda lifting + (let ((fv (cdr (assq fun lmenvs)))) + (if fv + (let ((args-new '()) + (processed-fv '())) + ;; All args (free variables and actual arguments) + ;; should be processed, because they can be fvrs + ;; (free variables of another closure) + (dolist (fvr fv) + (push (cconv-closure-convert-rec + fvr (remq fvr emvrs) + fvrs envs lmenvs) + processed-fv)) + (setq processed-fv (reverse processed-fv)) + (dolist (elm args) + (push (cconv-closure-convert-rec + elm emvrs fvrs envs lmenvs) + args-new)) + (setq args-new (append processed-fv (reverse args-new))) + (setq fun (cconv-closure-convert-rec + fun emvrs fvrs envs lmenvs)) + `(,callsym ,fun . ,args-new)) + (let ((cdr-new '())) + (dolist (elm (cdr form)) + (push (cconv-closure-convert-rec + elm emvrs fvrs envs lmenvs) + cdr-new)) + `(,callsym . ,(reverse cdr-new)))))) + + (`(,func . ,body-forms) ; first element is function or whatever + ; function-like forms are: + ; or, and, if, progn, prog1, prog2, + ; while, until + (let ((body-forms-new '())) + (dolist (elm body-forms) + (push (cconv-closure-convert-rec + elm emvrs fvrs envs lmenvs) + body-forms-new)) + (setq body-forms-new (reverse body-forms-new)) + `(,func . ,body-forms-new))) + + (_ + (let ((free (memq form fvrs))) + (if free ;form is a free variable + (let* ((numero (- (length fvrs) (length free))) + (var (if (null (cdr envs)) + cconv--env-var + ;; Replace form => (aref env #) + `(aref ,cconv--env-var ,numero)))) + (if (memq form emvrs) ; form => (car (aref env #)) if mutable + `(car ,var) + var)) + (if (memq form emvrs) ; if form is a mutable variable + `(car ,form) ; replace form => (car form) + form)))))) + +(defun cconv-analyse-function (args body env parentform inclosure) + (dolist (arg args) + (cond + ((byte-compile-not-lexical-var-p arg) + (byte-compile-report-error + (format "Argument %S is not a lexical variable" arg))) + ((eq ?& (aref (symbol-name arg) 0)) nil) ;Ignore &rest, &optional, ... + (t (push (list arg inclosure parentform) env)))) ;Push vrs to vars. + (dolist (form body) ;Analyse body forms. + (cconv-analyse-form form env inclosure))) + +(defun cconv-analyse-form (form env inclosure) + "Find mutated variables and variables captured by closure. Analyse +lambdas if they are suitable for lambda lifting. +-- FORM is a piece of Elisp code after macroexpansion. +-- ENV is a list of variables visible in current lexical environment. + Each entry has the form (VAR INCLOSURE BINDER PARENTFORM) + for let-bound vars and (VAR INCLOSURE PARENTFORM) for function arguments. +-- INCLOSURE is the nesting level within lambdas." + (pcase form + ; let special form + (`(,(and (or `let* `let) letsym) ,binders . ,body-forms) + + (let ((orig-env env) + (var nil) + (value nil)) + (dolist (binder binders) + (if (not (consp binder)) + (progn + (setq var binder) ; treat the form (let (x) ...) well + (setq value nil)) + (setq var (car binder)) + (setq value (cadr binder)) + + (cconv-analyse-form value (if (eq letsym 'let*) env orig-env) + inclosure)) + + (unless (byte-compile-not-lexical-var-p var) + (let ((varstruct (list var inclosure binder form))) + (push varstruct env) ; Push a new one. + + (pcase value + (`(function (lambda . ,_)) + ;; If var is a function push it to lambda list. + (push varstruct cconv-lambda-candidates))))))) + + (dolist (form body-forms) ; Analyse body forms. + (cconv-analyse-form form env inclosure))) + + ; defun special form + (`(,(or `defun `defmacro) ,func ,vrs . ,body-forms) + (when env + (byte-compile-log-warning + (format "Function %S will ignore its context %S" + func (mapcar #'car env)) + t :warning)) + (cconv-analyse-function vrs body-forms nil form 0)) + + (`(function (lambda ,vrs . ,body-forms)) + (cconv-analyse-function vrs body-forms env form (1+ inclosure))) + + (`(setq . ,forms) + ;; If a local variable (member of env) is modified by setq then + ;; it is a mutated variable. + (while forms + (let ((v (assq (car forms) env))) ; v = non nil if visible + (when v + (push v cconv-mutated) + ;; Delete from candidate list for lambda lifting. + (setq cconv-lambda-candidates (delq v cconv-lambda-candidates)) + (unless (eq inclosure (cadr v)) ;Bound in a different closure level. + (push v cconv-captured)))) + (cconv-analyse-form (cadr forms) env inclosure) + (setq forms (cddr forms)))) + + (`((lambda . ,_) . ,_) ; first element is lambda expression + (dolist (exp `((function ,(car form)) . ,(cdr form))) + (cconv-analyse-form exp env inclosure))) + + (`(cond . ,cond-forms) ; cond special form + (dolist (forms cond-forms) + (dolist (form forms) + (cconv-analyse-form form env inclosure)))) + + (`(quote . ,_) nil) ; quote form + (`(function . ,_) nil) ; same as quote + + (`(condition-case ,var ,protected-form . ,handlers) + ;; FIXME: The bytecode for condition-case forces us to wrap the + ;; form and handlers in closures (for handlers, it's probably + ;; unavoidable, but not for the protected form). + (setq inclosure (1+ inclosure)) + (cconv-analyse-form protected-form env inclosure) + (push (list var inclosure form) env) + (dolist (handler handlers) + (dolist (form (cdr handler)) + (cconv-analyse-form form env inclosure)))) + + ;; FIXME: The bytecode for catch forces us to wrap the body. + (`(,(or `catch `unwind-protect) ,form . ,body) + (cconv-analyse-form form env inclosure) + (setq inclosure (1+ inclosure)) + (dolist (form body) + (cconv-analyse-form form env inclosure))) + + ;; FIXME: The bytecode for save-window-excursion and the lack of + ;; bytecode for track-mouse forces us to wrap the body. + (`(track-mouse . ,body) + (setq inclosure (1+ inclosure)) + (dolist (form body) + (cconv-analyse-form form env inclosure))) + + (`(,(or `defconst `defvar) ,var ,value . ,_) + (push var byte-compile-bound-variables) + (cconv-analyse-form value env inclosure)) + + (`(,(or `funcall `apply) ,fun . ,args) + ;; Here we ignore fun because funcall and apply are the only two + ;; functions where we can pass a candidate for lambda lifting as + ;; argument. So, if we see fun elsewhere, we'll delete it from + ;; lambda candidate list. + (if (symbolp fun) + (let ((lv (assq fun cconv-lambda-candidates))) + (when lv + (unless (eq (cadr lv) inclosure) + (push lv cconv-captured) + ;; If this funcall and the definition of fun are in + ;; different closures - we delete fun from candidate + ;; list, because it is too complicated to manage free + ;; variables in this case. + (setq cconv-lambda-candidates + (delq lv cconv-lambda-candidates))))) + (cconv-analyse-form fun env inclosure)) + (dolist (form args) + (cconv-analyse-form form env inclosure))) + + (`(,_ . ,body-forms) ; First element is a function or whatever. + (dolist (form body-forms) + (cconv-analyse-form form env inclosure))) + + ((pred symbolp) + (let ((dv (assq form env))) ; dv = declared and visible + (when dv + (unless (eq inclosure (cadr dv)) ; capturing condition + (push dv cconv-captured)) + ;; Delete lambda if it is found here, since it escapes. + (setq cconv-lambda-candidates + (delq dv cconv-lambda-candidates))))))) + +(provide 'cconv) +;;; cconv.el ends here diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el index 885424ec726..12dafe274b9 100644 --- a/lisp/emacs-lisp/cl-extra.el +++ b/lisp/emacs-lisp/cl-extra.el @@ -771,10 +771,11 @@ This also does some trivial optimizations to make the form prettier." (sublis sub (nreverse decls)) (list (list* 'list '(quote apply) - (list 'function - (list* 'lambda - (append new (cadadr form)) - (sublis sub body))) + (list 'quote + (list 'function + (list* 'lambda + (append new (cadadr form)) + (sublis sub body)))) (nconc (mapcar (function (lambda (x) (list 'list '(quote quote) x))) diff --git a/lisp/emacs-lisp/cl-loaddefs.el b/lisp/emacs-lisp/cl-loaddefs.el index 8e192a18459..bd50c75bcc3 100644 --- a/lisp/emacs-lisp/cl-loaddefs.el +++ b/lisp/emacs-lisp/cl-loaddefs.el @@ -10,7 +10,7 @@ ;;;;;; ceiling* floor* isqrt lcm gcd cl-progv-before cl-set-frame-visible-p ;;;;;; cl-map-overlays cl-map-intervals cl-map-keymap-recursively ;;;;;; notevery notany every some mapcon mapcan mapl maplist map -;;;;;; cl-mapcar-many equalp coerce) "cl-extra" "cl-extra.el" "60f6b85256416c5f2a0a3954a11523b6") +;;;;;; cl-mapcar-many equalp coerce) "cl-extra" "cl-extra.el" "2bfbae6523c842d511b8c8d88658825a") ;;; Generated autoloads from cl-extra.el (autoload 'coerce "cl-extra" "\ @@ -282,7 +282,7 @@ Not documented ;;;;;; do-all-symbols do-symbols dotimes dolist do* do loop return-from ;;;;;; return block etypecase typecase ecase case load-time-value ;;;;;; eval-when destructuring-bind function* defmacro* defun* gentemp -;;;;;; gensym) "cl-macs" "cl-macs.el" "0904b956872432ae7cc5fa9abcefce63") +;;;;;; gensym) "cl-macs" "cl-macs.el" "7602128fa01003de9a8df4c752865300") ;;; Generated autoloads from cl-macs.el (autoload 'gensym "cl-macs" "\ diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 80e95724f1f..093e4fbf258 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -602,7 +602,13 @@ called from BODY." (put 'cl-block-wrapper 'byte-compile 'cl-byte-compile-block) (defun cl-byte-compile-block (cl-form) - (if (fboundp 'byte-compile-form-do-effect) ; Check for optimizing compiler + ;; Here we try to determine if a catch tag is used or not, so as to get rid + ;; of the catch when it's not used. + (if (and (fboundp 'byte-compile-form-do-effect) ; Optimizing compiler? + ;; FIXME: byte-compile-top-level can only be used for code that is + ;; closed (as the name implies), so for lexical scoping we should + ;; implement this optimization differently. + (not lexical-binding)) (progn (let* ((cl-entry (cons (nth 1 (nth 1 (nth 1 cl-form))) nil)) (cl-active-block-names (cons cl-entry cl-active-block-names)) diff --git a/lisp/emacs-lisp/disass.el b/lisp/emacs-lisp/disass.el index 9f4cca91676..9ee02a98e5e 100644 --- a/lisp/emacs-lisp/disass.el +++ b/lisp/emacs-lisp/disass.el @@ -72,19 +72,22 @@ redefine OBJECT if it is a symbol." (let ((macro 'nil) (name 'nil) (doc 'nil) + (lexical-binding nil) args) (while (symbolp obj) (setq name obj obj (symbol-function obj))) (if (subrp obj) (error "Can't disassemble #<subr %s>" name)) - (if (and (listp obj) (eq (car obj) 'autoload)) - (progn - (load (nth 1 obj)) - (setq obj (symbol-function name)))) + (when (and (listp obj) (eq (car obj) 'autoload)) + (load (nth 1 obj)) + (setq obj (symbol-function name))) (if (eq (car-safe obj) 'macro) ;handle macros (setq macro t obj (cdr obj))) + (when (and (listp obj) (eq (car obj) 'closure)) + (setq lexical-binding t) + (setq obj (cddr obj))) (if (and (listp obj) (eq (car obj) 'byte-code)) (setq obj (list 'lambda nil obj))) (if (and (listp obj) (not (eq (car obj) 'lambda))) @@ -215,7 +218,9 @@ OBJ should be a call to BYTE-CODE generated by the byte compiler." (cond ((memq op byte-goto-ops) (insert (int-to-string (nth 1 arg)))) ((memq op '(byte-call byte-unbind - byte-listN byte-concatN byte-insertN)) + byte-listN byte-concatN byte-insertN + byte-stack-ref byte-stack-set byte-stack-set2 + byte-discardN byte-discardN-preserve-tos)) (insert (int-to-string arg))) ((memq op '(byte-varref byte-varset byte-varbind)) (prin1 (car arg) (current-buffer))) diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index 70a7983dbea..d711ba59a42 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -519,7 +519,7 @@ the minibuffer." ((and (eq (car form) 'defcustom) (default-boundp (nth 1 form))) ;; Force variable to be bound. - (set-default (nth 1 form) (eval (nth 2 form)))) + (set-default (nth 1 form) (eval (nth 2 form) lexical-binding))) ((eq (car form) 'defface) ;; Reset the face. (setq face-new-frame-defaults @@ -532,7 +532,7 @@ the minibuffer." (put ',(nth 1 form) 'customized-face ,(nth 2 form))) (put (nth 1 form) 'saved-face nil))))) - (setq edebug-result (eval form)) + (setq edebug-result (eval form lexical-binding)) (if (not edebugging) (princ edebug-result) edebug-result))) @@ -2462,6 +2462,7 @@ MSG is printed after `::::} '." (if edebug-global-break-condition (condition-case nil (setq edebug-global-break-result + ;; FIXME: lexbind. (eval edebug-global-break-condition)) (error nil)))) (edebug-break)) @@ -2473,6 +2474,7 @@ MSG is printed after `::::} '." (and edebug-break-data (or (not edebug-break-condition) (setq edebug-break-result + ;; FIXME: lexbind. (eval edebug-break-condition)))))) (if (and edebug-break (nth 2 edebug-break-data)) ; is it temporary? @@ -3633,9 +3635,10 @@ Return the result of the last expression." (defun edebug-eval (edebug-expr) ;; Are there cl lexical variables active? - (if (bound-and-true-p cl-debug-env) - (eval (cl-macroexpand-all edebug-expr cl-debug-env)) - (eval edebug-expr))) + (eval (if (bound-and-true-p cl-debug-env) + (cl-macroexpand-all edebug-expr cl-debug-env) + edebug-expr) + lexical-binding)) ;; FIXME: lexbind. (defun edebug-safe-eval (edebug-expr) ;; Evaluate EXPR safely. @@ -4237,8 +4240,8 @@ It is removed when you hit any char." ;;; Menus (defun edebug-toggle (variable) - (set variable (not (eval variable))) - (message "%s: %s" variable (eval variable))) + (set variable (not (symbol-value variable))) + (message "%s: %s" variable (symbol-value variable))) ;; We have to require easymenu (even for Emacs 18) just so ;; the easy-menu-define macro call is compiled correctly. 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 2fe33dfce2e..bd768dbdb9f 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/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index 15690023700..85717408121 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el @@ -699,7 +699,8 @@ If CHAR is not a character, return nil." "Evaluate sexp before point; print value in minibuffer. With argument, print output into current buffer." (let ((standard-output (if eval-last-sexp-arg-internal (current-buffer) t))) - (eval-last-sexp-print-value (eval (preceding-sexp))))) + ;; Setup the lexical environment if lexical-binding is enabled. + (eval-last-sexp-print-value (eval (preceding-sexp) lexical-binding)))) (defun eval-last-sexp-print-value (value) @@ -763,16 +764,18 @@ Reinitialize the face according to the `defface' specification." ;; `defcustom' is now macroexpanded to ;; `custom-declare-variable' with a quoted value arg. ((and (eq (car form) 'custom-declare-variable) - (default-boundp (eval (nth 1 form)))) + (default-boundp (eval (nth 1 form) lexical-binding))) ;; Force variable to be bound. - (set-default (eval (nth 1 form)) (eval (nth 1 (nth 2 form)))) + (set-default (eval (nth 1 form) lexical-binding) + (eval (nth 1 (nth 2 form)) lexical-binding)) form) ;; `defface' is macroexpanded to `custom-declare-face'. ((eq (car form) 'custom-declare-face) ;; Reset the face. (setq face-new-frame-defaults - (assq-delete-all (eval (nth 1 form)) face-new-frame-defaults)) - (put (eval (nth 1 form)) 'face-defface-spec nil) + (assq-delete-all (eval (nth 1 form) lexical-binding) + face-new-frame-defaults)) + (put (eval (nth 1 form) lexical-binding) 'face-defface-spec nil) ;; Setting `customized-face' to the new spec after calling ;; the form, but preserving the old saved spec in `saved-face', ;; imitates the situation when the new face spec is set @@ -783,10 +786,11 @@ Reinitialize the face according to the `defface' specification." ;; `defface' change the spec, regardless of a saved spec. (prog1 `(prog1 ,form (put ,(nth 1 form) 'saved-face - ',(get (eval (nth 1 form)) 'saved-face)) + ',(get (eval (nth 1 form) lexical-binding) + 'saved-face)) (put ,(nth 1 form) 'customized-face ,(nth 2 form))) - (put (eval (nth 1 form)) 'saved-face nil))) + (put (eval (nth 1 form) lexical-binding) 'saved-face nil))) ((eq (car form) 'progn) (cons 'progn (mapcar 'eval-defun-1 (cdr form)))) (t form))) @@ -1205,7 +1209,6 @@ This function also returns nil meaning don't specify the indentation." (put 'prog1 'lisp-indent-function 1) (put 'prog2 'lisp-indent-function 2) (put 'save-excursion 'lisp-indent-function 0) -(put 'save-window-excursion 'lisp-indent-function 0) (put 'save-restriction 'lisp-indent-function 0) (put 'save-match-data 'lisp-indent-function 0) (put 'save-current-buffer 'lisp-indent-function 0) diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index af8047256e2..bccc60a24e0 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -29,6 +29,8 @@ ;;; Code: +(eval-when-compile (require 'cl)) + ;; Bound by the top-level `macroexpand-all', and modified to include any ;; macros defined by `defmacro'. (defvar macroexpand-all-environment nil) @@ -164,6 +166,17 @@ Assumes the caller has bound `macroexpand-all-environment'." (cons (macroexpand-all-1 (list 'function f)) (macroexpand-all-forms args))))) + ;; Macro expand compiler macros. + ;; FIXME: Don't depend on CL. + (`(,(and (pred symbolp) fun + (guard (and (eq (get fun 'byte-compile) + 'cl-byte-compile-compiler-macro) + (functionp 'compiler-macroexpand)))) + . ,_) + (let ((newform (compiler-macroexpand form))) + (if (eq form newform) + (macroexpand-all-forms form 1) + (macroexpand-all-1 newform)))) (`(,_ . ,_) ;; For every other list, we just expand each argument (for ;; setq/setq-default this works alright because the variable names diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index 3179672a3ec..d795dbd390c 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -1,4 +1,4 @@ -;;; pcase.el --- ML-style pattern-matching macro for Elisp +;;; pcase.el --- ML-style pattern-matching macro for Elisp -*- lexical-binding: t -*- ;; Copyright (C) 2010-2011 Free Software Foundation, Inc. @@ -37,8 +37,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) - ;; Macro-expansion of pcase is reasonably fast, so it's not a problem ;; when byte-compiling a file, but when interpreting the code, if the pcase ;; is in a loop, the repeated macro-expansion becomes terribly costly, so we @@ -157,7 +155,9 @@ of the form (UPAT EXP)." ;; to a separate function if that number is too high. ;; ;; We've already used this branch. So it is shared. - (destructuring-bind (code prevvars res) prev + (let* ((code (car prev)) (cdrprev (cdr prev)) + (prevvars (car cdrprev)) (cddrprev (cdr cdrprev)) + (res (car cddrprev))) (unless (symbolp res) ;; This is the first repeat, so we have to move ;; the branch to a separate function. @@ -258,15 +258,18 @@ MATCH is the pattern that needs to be matched, of the form: (and MATCH ...) (or MATCH ...)" (when (setq branches (delq nil branches)) - (destructuring-bind (match code &rest vars) (car branches) + (let* ((carbranch (car branches)) + (match (car carbranch)) (cdarbranch (cdr carbranch)) + (code (car cdarbranch)) + (vars (cdr cdarbranch))) (pcase--u1 (list match) code vars (cdr branches))))) (defun pcase--and (match matches) (if matches `(and ,match ,@matches) match)) (defun pcase--split-match (sym splitter match) - (case (car match) - ((match) + (cond + ((eq (car match) 'match) (if (not (eq sym (cadr match))) (cons match match) (let ((pat (cddr match))) @@ -280,7 +283,7 @@ MATCH is the pattern that needs to be matched, of the form: (cdr pat))))) (t (let ((res (funcall splitter (cddr match)))) (cons (or (car res) match) (or (cdr res) match)))))))) - ((or and) + ((memq (car match) '(or and)) (let ((then-alts '()) (else-alts '()) (neutral-elem (if (eq 'or (car match)) @@ -410,32 +413,37 @@ and otherwise defers to REST which is a list of branches of the form (pcase--u1 (cons `(match ,var or . ,(nreverse simples)) (cdr matches)) code vars (if (null others) rest - (cons (list* + (cons (cons (pcase--and (if (cdr others) (cons 'or (nreverse others)) (car others)) (cdr matches)) - code vars) + (cons code vars)) rest)))) (t (pcase--u1 (cons (pop alts) (cdr matches)) code vars (if (null alts) (progn (error "Please avoid it") rest) - (cons (list* + (cons (cons (pcase--and (if (cdr alts) (cons 'or alts) (car alts)) (cdr matches)) - code vars) + (cons code vars)) rest))))))) ((eq 'match (caar matches)) - (destructuring-bind (op sym &rest upat) (pop matches) + (let* ((popmatches (pop matches)) + (op (car popmatches)) (cdrpopmatches (cdr popmatches)) + (sym (car cdrpopmatches)) + (upat (cdr cdrpopmatches))) (cond ((memq upat '(t _)) (pcase--u1 matches code vars rest)) ((eq upat 'dontcare) :pcase--dontcare) ((functionp upat) (error "Feature removed, use (pred %s)" upat)) ((memq (car-safe upat) '(guard pred)) - (destructuring-bind (then-rest &rest else-rest) - (pcase--split-rest - sym (apply-partially #'pcase--split-pred upat) rest) + (let* ((splitrest + (pcase--split-rest + sym (apply-partially #'pcase--split-pred upat) rest)) + (then-rest (car splitrest)) + (else-rest (cdr splitrest))) (pcase--if (if (and (eq (car upat) 'pred) (symbolp (cadr upat))) `(,(cadr upat) ,sym) (let* ((exp (cadr upat)) @@ -479,13 +487,15 @@ and otherwise defers to REST which is a list of branches of the form (setq all nil)))) (if all ;; Use memq for (or `a `b `c `d) rather than a big tree. - (let ((elems (mapcar 'cadr (cdr upat)))) - (destructuring-bind (then-rest &rest else-rest) - (pcase--split-rest - sym (apply-partially #'pcase--split-member elems) rest) - (pcase--if `(,(if memq-fine #'memq #'member) ,sym ',elems) - (pcase--u1 matches code vars then-rest) - (pcase--u else-rest)))) + (let* ((elems (mapcar 'cadr (cdr upat))) + (splitrest + (pcase--split-rest + sym (apply-partially #'pcase--split-member elems) rest)) + (then-rest (car splitrest)) + (else-rest (cdr splitrest))) + (pcase--if `(,(if memq-fine #'memq #'member) ,sym ',elems) + (pcase--u1 matches code vars then-rest) + (pcase--u else-rest))) (pcase--u1 (cons `(match ,sym ,@(cadr upat)) matches) code vars (append (mapcar (lambda (upat) `((and (match ,sym . ,upat) ,@matches) @@ -508,15 +518,14 @@ and otherwise defers to REST which is a list of branches of the form ;; `(PAT3 . PAT4)) which the programmer can easily rewrite ;; to the more efficient `(,(and PAT1 PAT3) . ,(and PAT2 PAT4))). (pcase--u1 `((match ,sym . ,(cadr upat))) - (lexical-let ((rest rest)) - ;; FIXME: This codegen is not careful to share its - ;; code if used several times: code blow up is likely. - (lambda (vars) - ;; `vars' will likely contain bindings which are - ;; not always available in other paths to - ;; `rest', so there' no point trying to pass - ;; them down. - (pcase--u rest))) + ;; FIXME: This codegen is not careful to share its + ;; code if used several times: code blow up is likely. + (lambda (vars) + ;; `vars' will likely contain bindings which are + ;; not always available in other paths to + ;; `rest', so there' no point trying to pass + ;; them down. + (pcase--u rest)) vars (list `((and . ,matches) ,code . ,vars)))) (t (error "Unknown upattern `%s'" upat))))) @@ -535,10 +544,12 @@ and if not, defers to REST which is a list of branches of the form ((consp qpat) (let ((syma (make-symbol "xcar")) (symd (make-symbol "xcdr"))) - (destructuring-bind (then-rest &rest else-rest) - (pcase--split-rest sym - (apply-partially #'pcase--split-consp syma symd) - rest) + (let* ((splitrest (pcase--split-rest + sym + (apply-partially #'pcase--split-consp syma symd) + rest)) + (then-rest (car splitrest)) + (else-rest (cdr splitrest))) (pcase--if `(consp ,sym) `(let ((,syma (car ,sym)) (,symd (cdr ,sym))) @@ -548,8 +559,10 @@ and if not, defers to REST which is a list of branches of the form code vars then-rest)) (pcase--u else-rest))))) ((or (integerp qpat) (symbolp qpat) (stringp qpat)) - (destructuring-bind (then-rest &rest else-rest) - (pcase--split-rest sym (apply-partially 'pcase--split-equal qpat) rest) + (let* ((splitrest (pcase--split-rest + sym (apply-partially 'pcase--split-equal qpat) rest)) + (then-rest (car splitrest)) + (else-rest (cdr splitrest))) (pcase--if `(,(if (stringp qpat) #'equal #'eq) ,sym ',qpat) (pcase--u1 matches code vars then-rest) (pcase--u else-rest)))) |