procyberian/emacs
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Fix pcase memoizing; change lexbound byte-code marker.

Browse source 
* src/bytecode.c (exec_byte_code): Remove old lexical binding slot handling
and replace it with the a integer args-desc handling.
* eval.c (funcall_lambda): Adjust arglist test accordingly.
* lisp/emacs-lisp/bytecomp.el (byte-compile-arglist-signature):
Handle integer arglist descriptor.
(byte-compile-make-args-desc): Make integer arglist descriptor.
(byte-compile-lambda): Use integer arglist descriptor to mark lexical
byte-coded functions instead of an extra slot.
* lisp/help-fns.el (help-add-fundoc-usage): Don't add a dummy doc.
(help-split-fundoc): Return a nil doc if there was no actual doc.
(help-function-arglist): Generate an arglist from an integer arg-desc.
* lisp/emacs-lisp/pcase.el (pcase--memoize): Rename from pcase-memoize;
Make only the key weak.
(pcase): Change the key used in the memoization table, so it does not
always get GC'd away.
* lisp/emacs-lisp/macroexp.el (macroexpand-all-1): Slight change to the
pcase pattern to generate slightly better code.
This commit is contained in:
Stefan Monnier 2011-03-05 23:48:17 -05:00
parent d032d5e7df
commit e2abe5a13d
10 changed files with 188 additions and 78 deletions
Download patch file Download diff file Expand all files Collapse all files

87
lisp/emacs-lisp/bytecomp.el
View file

@ -33,6 +33,9 @@
;;; Code:
;; FIXME: Use lexical-binding and get rid of the atrocious "bytecomp-"
;; variable prefix.
;; ========================================================================
;; Entry points:
;; byte-recompile-directory, byte-compile-file,
@ -1180,22 +1183,28 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'."
(t fn)))))))
(defun byte-compile-arglist-signature (arglist)
(let ((args 0)
opts
restp)
(while arglist
(cond ((eq (car arglist) '&optional)
(or opts (setq opts 0)))
((eq (car arglist) '&rest)
(if (cdr arglist)
(setq restp t
arglist nil)))
(t
(if opts
(setq opts (1+ opts))
(if (integerp arglist)
;; New style byte-code arglist.
(cons (logand arglist 127) ;Mandatory.
(if (zerop (logand arglist 128)) ;No &rest.
(lsh arglist -8))) ;Nonrest.
;; Old style byte-code, or interpreted function.
(let ((args 0)
opts
restp)
(while arglist
(cond ((eq (car arglist) '&optional)
(or opts (setq opts 0)))
((eq (car arglist) '&rest)
(if (cdr arglist)
(setq restp t
arglist nil)))
(t
(if opts
(setq opts (1+ opts))
(setq args (1+ args)))))
(setq arglist (cdr arglist)))
(cons args (if restp nil (if opts (+ args opts) args)))))
(setq arglist (cdr arglist)))
(cons args (if restp nil (if opts (+ args opts) args))))))
(defun byte-compile-arglist-signatures-congruent-p (old new)
@ -2645,6 +2654,26 @@ If FORM is a lambda or a macro, byte-compile it as a function."
;; Return the new lexical environment
lexenv))))
(defun byte-compile-make-args-desc (arglist)
(let ((mandatory 0)
nonrest (rest 0))
(while (and arglist (not (memq (car arglist) '(&optional &rest))))
(setq mandatory (1+ mandatory))
(setq arglist (cdr arglist)))
(setq nonrest mandatory)
(when (eq (car arglist) '&optional)
(setq arglist (cdr arglist))
(while (and arglist (not (eq (car arglist) '&rest)))
(setq nonrest (1+ nonrest))
(setq arglist (cdr arglist))))
(when arglist
(setq rest 1))
(if (> mandatory 127)
(byte-compile-report-error "Too many (>127) mandatory arguments")
(logior mandatory
(lsh nonrest 8)
(lsh rest 7)))))
;; Byte-compile a lambda-expression and return a valid function.
;; The value is usually a compiled function but may be the original
;; lambda-expression.
@ -2716,18 +2745,22 @@ If FORM is a lambda or a macro, byte-compile it as a function."
;; 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
lexical-binding)
(list bytecomp-doc))
;; optionally, the interactive spec.
(if (or bytecomp-int lexical-binding)
(list (nth 1 bytecomp-int)))
(if lexical-binding
'(t))))
(if lexical-binding
(byte-compile-make-args-desc bytecomp-arglist)
bytecomp-arglist)
(append
;; byte-string, constants-vector, stack depth
(cdr compiled)
;; optionally, the doc string.
(cond (lexical-binding
(require 'help-fns)
(list (help-add-fundoc-usage
bytecomp-doc bytecomp-arglist)))
((or bytecomp-doc bytecomp-int)
(list bytecomp-doc)))
;; optionally, the interactive spec.
(if bytecomp-int
(list (nth 1 bytecomp-int)))))
(setq compiled
(nconc (if bytecomp-int (list bytecomp-int))
(cond ((eq (car-safe compiled) 'progn) (cdr compiled))