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.

5 files changed, 89 insertions, 44 deletions

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)))))