Fix pcase memoizing; change lexbound byte-code marker.
* 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
parent
d032d5e7df
commit
e2abe5a13d
10 changed files with 188 additions and 78 deletions
|
|
@ -1,3 +1,20 @@
|
|||
2011-03-06 Stefan Monnier <monnier@iro.umontreal.ca>
|
||||
|
||||
* 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.
|
||||
* 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.
|
||||
* 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.
|
||||
* emacs-lisp/macroexp.el (macroexpand-all-1): Slight change to the
|
||||
pcase pattern to generate slightly better code.
|
||||
|
||||
2011-03-01 Stefan Monnier <monnier@iro.umontreal.ca>
|
||||
|
||||
* emacs-lisp/cconv.el (cconv-liftwhen): Increase threshold.
|
||||
|
|
|
|||
|
|
@ -2009,8 +2009,7 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
|
|||
(setq lap0 (car rest)
|
||||
lap1 (nth 1 rest))
|
||||
(if (memq (car lap0) byte-constref-ops)
|
||||
(if (or (eq (car lap0) 'byte-constant)
|
||||
(eq (car lap0) 'byte-constant2))
|
||||
(if (memq (car lap0) '(byte-constant byte-constant2))
|
||||
(unless (memq (cdr lap0) byte-compile-constants)
|
||||
(setq byte-compile-constants (cons (cdr lap0)
|
||||
byte-compile-constants)))
|
||||
|
|
|
|||
|
|
@ -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,6 +1183,12 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'."
|
|||
(t fn)))))))
|
||||
|
||||
(defun byte-compile-arglist-signature (arglist)
|
||||
(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)
|
||||
|
|
@ -1195,7 +1204,7 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'."
|
|||
(setq opts (1+ opts))
|
||||
(setq args (1+ args)))))
|
||||
(setq arglist (cdr arglist)))
|
||||
(cons args (if restp nil (if opts (+ args opts) args)))))
|
||||
(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)
|
||||
(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.
|
||||
(if (or bytecomp-doc bytecomp-int
|
||||
lexical-binding)
|
||||
(list bytecomp-doc))
|
||||
(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 (or bytecomp-int lexical-binding)
|
||||
(list (nth 1 bytecomp-int)))
|
||||
(if lexical-binding
|
||||
'(t))))
|
||||
(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))
|
||||
|
|
|
|||
|
|
@ -66,22 +66,21 @@
|
|||
;;; Code:
|
||||
|
||||
;; TODO:
|
||||
;; - byte-optimize-form should be applied before cconv.
|
||||
;; - maybe unify byte-optimize and compiler-macros.
|
||||
;; - canonize code in macro-expand so we don't have to handle (let (var) body)
|
||||
;; and other oddities.
|
||||
;; - 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.
|
||||
;; - 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.
|
||||
;; - a reference to a var that is known statically to always hold a constant
|
||||
;; should be turned into a byte-constant rather than a byte-stack-ref.
|
||||
;; Hmm... right, that's called constant propagation and could be done here
|
||||
;; But when that constant is a function, we have to be careful to make sure
|
||||
;; Hmm... right, that's called constant propagation and could be done here,
|
||||
;; but when that constant is a function, we have to be careful to make sure
|
||||
;; the bytecomp only compiles it once.
|
||||
;; - Since we know here when a variable is not mutated, we could pass that
|
||||
;; info to the byte-compiler, e.g. by using a new `immutable-let'.
|
||||
;; - add tail-calls to bytecode.c and the bytecompiler.
|
||||
;; - add tail-calls to bytecode.c and the byte compiler.
|
||||
|
||||
;; (defmacro dlet (binders &rest body)
|
||||
;; ;; Works in both lexical and non-lexical mode.
|
||||
|
|
|
|||
|
|
@ -176,8 +176,9 @@ Assumes the caller has bound `macroexpand-all-environment'."
|
|||
(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)
|
||||
(`(,(pred (lambda (fun)
|
||||
(and (symbolp fun)
|
||||
(eq (get fun 'byte-compile)
|
||||
'cl-byte-compile-compiler-macro)
|
||||
(functionp 'compiler-macroexpand))))
|
||||
. ,_)
|
||||
|
|
|
|||
|
|
@ -42,7 +42,7 @@
|
|||
;; is in a loop, the repeated macro-expansion becomes terribly costly, so we
|
||||
;; memoize previous macro expansions to try and avoid recomputing them
|
||||
;; over and over again.
|
||||
(defconst pcase-memoize (make-hash-table :weakness t :test 'equal))
|
||||
(defconst pcase--memoize (make-hash-table :weakness 'key :test 'eq))
|
||||
|
||||
(defconst pcase--dontcare-upats '(t _ dontcare))
|
||||
|
||||
|
|
@ -78,10 +78,21 @@ E.g. you can match pairs where the cdr is larger than the car with a pattern
|
|||
like `(,a . ,(pred (< a))) or, with more checks:
|
||||
`(,(and a (pred numberp)) . ,(and (pred numberp) (pred (< a))))"
|
||||
(declare (indent 1) (debug case)) ;FIXME: edebug `guard' and vars.
|
||||
(or (gethash (cons exp cases) pcase-memoize)
|
||||
(puthash (cons exp cases)
|
||||
(pcase--expand exp cases)
|
||||
pcase-memoize)))
|
||||
;; We want to use a weak hash table as a cache, but the key will unavoidably
|
||||
;; be based on `exp' and `cases', yet `cases' is a fresh new list each time
|
||||
;; we're called so it'll be immediately GC'd. So we use (car cases) as key
|
||||
;; which does come straight from the source code and should hence not be GC'd
|
||||
;; so easily.
|
||||
(let ((data (gethash (car cases) pcase--memoize)))
|
||||
;; data = (EXP CASES . EXPANSION)
|
||||
(if (and (equal exp (car data)) (equal cases (cadr data)))
|
||||
;; We have the right expansion.
|
||||
(cddr data)
|
||||
(when data
|
||||
(message "pcase-memoize: equal first branch, yet different"))
|
||||
(let ((expansion (pcase--expand exp cases)))
|
||||
(puthash (car cases) (cons exp (cons cases expansion)) pcase--memoize)
|
||||
expansion))))
|
||||
|
||||
;;;###autoload
|
||||
(defmacro pcase-let* (bindings &rest body)
|
||||
|
|
@ -135,6 +146,8 @@ of the form (UPAT EXP)."
|
|||
(and (symbolp upat) (not (memq upat pcase--dontcare-upats))))
|
||||
|
||||
(defun pcase--expand (exp cases)
|
||||
;; (message "pid=%S (pcase--expand %S ...hash=%S)"
|
||||
;; (emacs-pid) exp (sxhash cases))
|
||||
(let* ((defs (if (symbolp exp) '()
|
||||
(let ((sym (make-symbol "x")))
|
||||
(prog1 `((,sym ,exp)) (setq exp sym)))))
|
||||
|
|
|
|||
|
|
@ -76,15 +76,18 @@ DEF is the function whose usage we're looking for in DOCSTRING."
|
|||
;; Replace `fn' with the actual function name.
|
||||
(if (consp def) "anonymous" def)
|
||||
(match-string 1 docstring))
|
||||
(substring docstring 0 (match-beginning 0)))))
|
||||
(unless (zerop (match-beginning 0))
|
||||
(substring docstring 0 (match-beginning 0))))))
|
||||
|
||||
;; FIXME: Move to subr.el?
|
||||
(defun help-add-fundoc-usage (docstring arglist)
|
||||
"Add the usage info to DOCSTRING.
|
||||
If DOCSTRING already has a usage info, then just return it unchanged.
|
||||
The usage info is built from ARGLIST. DOCSTRING can be nil.
|
||||
ARGLIST can also be t or a string of the form \"(FUN ARG1 ARG2 ...)\"."
|
||||
(unless (stringp docstring) (setq docstring "Not documented"))
|
||||
(if (or (string-match "\n\n(fn\\(\\( .*\\)?)\\)\\'" docstring) (eq arglist t))
|
||||
(unless (stringp docstring) (setq docstring ""))
|
||||
(if (or (string-match "\n\n(fn\\(\\( .*\\)?)\\)\\'" docstring)
|
||||
(eq arglist t))
|
||||
docstring
|
||||
(concat docstring
|
||||
(if (string-match "\n?\n\\'" docstring)
|
||||
|
|
@ -95,6 +98,7 @@ ARGLIST can also be t or a string of the form \"(FUN ARG1 ARG2 ...)\"."
|
|||
(concat "(fn" (match-string 1 arglist) ")")
|
||||
(format "%S" (help-make-usage 'fn arglist))))))
|
||||
|
||||
;; FIXME: Move to subr.el?
|
||||
(defun help-function-arglist (def)
|
||||
;; Handle symbols aliased to other symbols.
|
||||
(if (and (symbolp def) (fboundp def)) (setq def (indirect-function def)))
|
||||
|
|
@ -103,12 +107,28 @@ ARGLIST can also be t or a string of the form \"(FUN ARG1 ARG2 ...)\"."
|
|||
;; and do the same for interpreted closures
|
||||
(if (eq (car-safe def) 'closure) (setq def (cddr def)))
|
||||
(cond
|
||||
((and (byte-code-function-p def) (integerp (aref def 0)))
|
||||
(let* ((args-desc (aref def 0))
|
||||
(max (lsh args-desc -8))
|
||||
(min (logand args-desc 127))
|
||||
(rest (logand args-desc 128))
|
||||
(arglist ()))
|
||||
(dotimes (i min)
|
||||
(push (intern (concat "arg" (number-to-string (1+ i)))) arglist))
|
||||
(when (> max min)
|
||||
(push '&optional arglist)
|
||||
(dotimes (i (- max min))
|
||||
(push (intern (concat "arg" (number-to-string (+ 1 i min))))
|
||||
arglist)))
|
||||
(unless (zerop rest) (push '&rest arglist) (push 'rest arglist))
|
||||
(nreverse arglist)))
|
||||
((byte-code-function-p def) (aref def 0))
|
||||
((eq (car-safe def) 'lambda) (nth 1 def))
|
||||
((and (eq (car-safe def) 'autoload) (not (eq (nth 4 def) 'keymap)))
|
||||
"[Arg list not available until function definition is loaded.]")
|
||||
(t t)))
|
||||
|
||||
;; FIXME: Move to subr.el?
|
||||
(defun help-make-usage (function arglist)
|
||||
(cons (if (symbolp function) function 'anonymous)
|
||||
(mapcar (lambda (arg)
|
||||
|
|
|
|||
|
|
@ -1,3 +1,9 @@
|
|||
2011-03-06 Stefan Monnier <monnier@iro.umontreal.ca>
|
||||
|
||||
* 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.
|
||||
|
||||
2011-03-01 Stefan Monnier <monnier@iro.umontreal.ca>
|
||||
|
||||
* callint.c (quotify_arg): Simplify the logic.
|
||||
|
|
|
|||
13
src/alloc.c
13
src/alloc.c
|
|
@ -2945,10 +2945,19 @@ usage: (vector &rest OBJECTS) */)
|
|||
|
||||
DEFUN ("make-byte-code", Fmake_byte_code, Smake_byte_code, 4, MANY, 0,
|
||||
doc: /* Create a byte-code object with specified arguments as elements.
|
||||
The arguments should be the arglist, bytecode-string, constant vector,
|
||||
stack size, (optional) doc string, and (optional) interactive spec.
|
||||
The arguments should be the ARGLIST, bytecode-string BYTE-CODE, constant
|
||||
vector CONSTANTS, maximum stack size DEPTH, (optional) DOCSTRING,
|
||||
and (optional) INTERACTIVE-SPEC.
|
||||
The first four arguments are required; at most six have any
|
||||
significance.
|
||||
The ARGLIST can be either like the one of `lambda', in which case the arguments
|
||||
will be dynamically bound before executing the byte code, or it can be an
|
||||
integer of the form NNNNNNNRMMMMMMM where the 7bit MMMMMMM specifies the
|
||||
minimum number of arguments, the 7-bit NNNNNNN specifies the maximum number
|
||||
of arguments (ignoring &rest) and the R bit specifies whether there is a &rest
|
||||
argument to catch the left-over arguments. If such an integer is used, the
|
||||
arguments will not be dynamically bound but will be instead pushed on the
|
||||
stack before executing the byte-code.
|
||||
usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INTERACTIVE-SPEC &rest ELEMENTS) */)
|
||||
(register int nargs, Lisp_Object *args)
|
||||
{
|
||||
|
|
|
|||
|
|
@ -502,37 +502,50 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth,
|
|||
stacke = stack.bottom - 1 + XFASTINT (maxdepth);
|
||||
#endif
|
||||
|
||||
if (! NILP (args_template))
|
||||
if (INTEGERP (args_template))
|
||||
{
|
||||
int at = XINT (args_template);
|
||||
int rest = at & 128;
|
||||
int mandatory = at & 127;
|
||||
int nonrest = at >> 8;
|
||||
eassert (mandatory <= nonrest);
|
||||
if (nargs <= nonrest)
|
||||
{
|
||||
int i;
|
||||
for (i = 0 ; i < nargs; i++, args++)
|
||||
PUSH (*args);
|
||||
if (nargs < mandatory)
|
||||
/* Too few arguments. */
|
||||
Fsignal (Qwrong_number_of_arguments,
|
||||
Fcons (Fcons (make_number (mandatory),
|
||||
rest ? Qand_rest : make_number (nonrest)),
|
||||
Fcons (make_number (nargs), Qnil)));
|
||||
else
|
||||
{
|
||||
for (; i < nonrest; i++)
|
||||
PUSH (Qnil);
|
||||
if (rest)
|
||||
PUSH (Qnil);
|
||||
}
|
||||
}
|
||||
else if (rest)
|
||||
{
|
||||
int i;
|
||||
for (i = 0 ; i < nonrest; i++, args++)
|
||||
PUSH (*args);
|
||||
PUSH (Flist (nargs - nonrest, args));
|
||||
}
|
||||
else
|
||||
/* Too many arguments. */
|
||||
Fsignal (Qwrong_number_of_arguments,
|
||||
Fcons (Fcons (make_number (mandatory),
|
||||
make_number (nonrest)),
|
||||
Fcons (make_number (nargs), Qnil)));
|
||||
}
|
||||
else if (! NILP (args_template))
|
||||
/* We should push some arguments on the stack. */
|
||||
{
|
||||
Lisp_Object at;
|
||||
int pushed = 0, optional = 0;
|
||||
|
||||
for (at = args_template; CONSP (at); at = XCDR (at))
|
||||
if (EQ (XCAR (at), Qand_optional))
|
||||
optional = 1;
|
||||
else if (EQ (XCAR (at), Qand_rest))
|
||||
{
|
||||
PUSH (pushed < nargs
|
||||
? Flist (nargs - pushed, args)
|
||||
: Qnil);
|
||||
pushed = nargs;
|
||||
at = Qnil;
|
||||
break;
|
||||
}
|
||||
else if (pushed < nargs)
|
||||
{
|
||||
PUSH (*args++);
|
||||
pushed++;
|
||||
}
|
||||
else if (optional)
|
||||
PUSH (Qnil);
|
||||
else
|
||||
break;
|
||||
|
||||
if (pushed != nargs || !NILP (at))
|
||||
Fsignal (Qwrong_number_of_arguments,
|
||||
Fcons (args_template, Fcons (make_number (nargs), Qnil)));
|
||||
error ("Unknown args template!");
|
||||
}
|
||||
|
||||
while (1)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue