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.

10 files changed, 188 insertions, 78 deletions

diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index 10f57c2b96a..70604238117 100644
--- a/lisp/ChangeLog
+++ b/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.
diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el
index d86cb729081..6d6eb68535e 100644
--- a/lisp/emacs-lisp/byte-opt.el
+++ b/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)
-                  (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)))
diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el
index 3575b10e1f1..297655a235a 100644
--- a/lisp/emacs-lisp/bytecomp.el
+++ b/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)
-        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))
diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el
index 7855193fa3f..5501c13ee4f 100644
--- a/lisp/emacs-lisp/cconv.el
+++ b/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
-;;   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.
diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el
index 4377797cba8..168a430577d 100644
--- a/lisp/emacs-lisp/macroexp.el
+++ b/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
-               (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)
diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el
index 89bbff980c4..2300ebf721a 100644
--- a/lisp/emacs-lisp/pcase.el
+++ b/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)
-      (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)))))
diff --git a/lisp/help-fns.el b/lisp/help-fns.el
index 87fb6a02bd3..58df45bc33c 100644
--- a/lisp/help-fns.el
+++ b/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"))
-  (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)
diff --git a/src/ChangeLog b/src/ChangeLog
index c638e1fa4b5..e8b3c57fbd0 100644
--- a/src/ChangeLog
+++ b/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.
diff --git a/src/alloc.c b/src/alloc.c
index 0b7db7ec627..c7fd8747f74 100644
--- a/src/alloc.c
+++ b/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)
 {
diff --git a/src/bytecode.c b/src/bytecode.c
index 9693a5a9196..dbab02886e2 100644
--- a/src/bytecode.c
+++ b/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))
-    /* 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)