Commit e2abe5a1 authored by Stefan Monnier's avatar Stefan Monnier
Browse files

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.
parent d032d5e7
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,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))
......
......@@ -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,10 +176,11 @@ 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)
'cl-byte-compile-compiler-macro)
(functionp 'compiler-macroexpand))))
(`(,(pred (lambda (fun)
(and (symbolp fun)
(eq (get fun 'byte-compile)
'cl-byte-compile-compiler-macro)
(functionp 'compiler-macroexpand))))
. ,_)
(let ((newform (compiler-macroexpand form)))
(if (eq form newform)
......
......@@ -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)
......
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.
......
......@@ -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))
/* We should push some arguments on the stack. */
if (INTEGERP (args_template))
{
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))
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 (args_template, Fcons (make_number (nargs), Qnil)));
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. */
{
error ("Unknown args template!");
}
while (1)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment