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.

lisp/ChangeLog

@@ -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.

lisp/emacs-lisp/byte-opt.el

@@ -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)
+	  (if (memq (car lap0) '(byte-constant byte-constant2))
-		  (eq (car lap0) 'byte-constant2))
 	      (unless (memq (cdr lap0) byte-compile-constants)
 		(setq byte-compile-constants (cons (cdr lap0)
 						   byte-compile-constants)))

lisp/emacs-lisp/bytecomp.el

@@ -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)
+  (if (integerp arglist)
-	opts
+      ;; New style byte-code arglist.
-	restp)
+      (cons (logand arglist 127)             ;Mandatory.
-    (while arglist
+            (if (zerop (logand arglist 128)) ;No &rest.
-      (cond ((eq (car arglist) '&optional)
+                (lsh arglist -8)))           ;Nonrest.
-	     (or opts (setq opts 0)))
+    ;; Old style byte-code, or interpreted function.
-	    ((eq (car arglist) '&rest)
+    (let ((args 0)
-	     (if (cdr arglist)
+          opts
-		 (setq restp t
+          restp)
-		       arglist nil)))
+      (while arglist
-	    (t
+        (cond ((eq (car arglist) '&optional)
-	     (if opts
+               (or opts (setq opts 0)))
-		 (setq opts (1+ opts))
+              ((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)))
+        (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-string, constants-vector, stack depth
+                     (byte-compile-make-args-desc bytecomp-arglist)
-                         (cdr compiled)
+                   bytecomp-arglist)
-                         ;; optionally, the doc string.
+                 (append
-                         (if (or bytecomp-doc bytecomp-int
+                  ;; byte-string, constants-vector, stack depth
-                                 lexical-binding)
+                  (cdr compiled)
-                             (list bytecomp-doc))
+                  ;; optionally, the doc string.
-                         ;; optionally, the interactive spec.
+                  (cond (lexical-binding
-                         (if (or bytecomp-int lexical-binding)
+                         (require 'help-fns)
-                             (list (nth 1 bytecomp-int)))
+                         (list (help-add-fundoc-usage
-                         (if lexical-binding
+                                bytecomp-doc bytecomp-arglist)))
-                             '(t))))
+                        ((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))

lisp/emacs-lisp/cconv.el

@@ -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
+;;   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
+;;   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.

lisp/emacs-lisp/macroexp.el

@@ -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
+      (`(,(pred (lambda (fun)
-               (guard (and (eq (get fun 'byte-compile)
+                  (and (symbolp fun)
-                               'cl-byte-compile-compiler-macro)
+                       (eq (get fun 'byte-compile)
-                           (functionp 'compiler-macroexpand))))
+                           'cl-byte-compile-compiler-macro)
+                       (functionp 'compiler-macroexpand))))
          . ,_)
        (let ((newform (compiler-macroexpand form)))
          (if (eq form newform)

lisp/emacs-lisp/pcase.el

@@ -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)
+  ;; We want to use a weak hash table as a cache, but the key will unavoidably
-      (puthash (cons exp cases)
+  ;; be based on `exp' and `cases', yet `cases' is a fresh new list each time
-               (pcase--expand exp cases)
+  ;; we're called so it'll be immediately GC'd.  So we use (car cases) as key
-               pcase-memoize)))
+  ;; 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)))))

lisp/help-fns.el

@@ -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"))
+  (unless (stringp docstring) (setq docstring ""))
-  (if (or (string-match "\n\n(fn\\(\\( .*\\)?)\\)\\'" docstring) (eq arglist t))
+  (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)

src/ChangeLog

@@ -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.

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,
+The arguments should be the ARGLIST, bytecode-string BYTE-CODE, constant
-stack size, (optional) doc string, and (optional) interactive spec.
+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)
 {

src/bytecode.c

@@ -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;
+      error ("Unknown args template!");
-      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)));
     }
 
   while (1)