cl-generic: Use OClosures for `cl--generic-isnot-nnm-p`

Rewrite the handling of `cl-no-next-method` to get rid of the hideous
hack used in `cl--generic-isnot-nnm-p` and also to try and move
some of the cost to the construction of the effective method rather
than its invocation.  This speeds up method calls measurably when
there's a `cl-call-next-method` in the body.

* lisp/loadup.el ("emacs-lisp/oclosure"): Load.

* lisp/emacs-lisp/oclosure.el (oclosure-define): Remove workaround now
that we're preloaded.

* lisp/emacs-lisp/cl-generic.el (cl--generic-method): Rename `uses-cnm`
to `call-con` to reflect it's not a boolean any more.
(cl-defmethod): Adjust to the new name and new values.
(cl-generic-define-method): Adjust to the new name.
(cl--generic-lambda): Use the new `curried` calling convention.
(cl--generic-no-next-method-function): Delete function.
(cl--generic-nnm): New type.
(cl-generic-call-method): Rewrite to support the various
calling conventions.
(cl--generic-nnm-sample, cl--generic-cnm-sample): Delete consts.
(cl--generic-isnot-nnm-p): Rewrite using `oclosure-type`.
(cl--generic-method-info): Add support for new calling convention.

2 files changed, 94 insertions, 70 deletions

diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el
index 295512d51ef..279f73f36a2 100644
--- a/lisp/emacs-lisp/cl-generic.el
+++ b/lisp/emacs-lisp/cl-generic.el
@@ -144,13 +144,20 @@ SPECIALIZERS-FUNCTION takes as first argument a tag value TAG
 (cl-defstruct (cl--generic-method
                (:constructor nil)
                (:constructor cl--generic-make-method
-                (specializers qualifiers uses-cnm function))
+                (specializers qualifiers call-con function))
                (:predicate nil))
   (specializers nil :read-only t :type list)
   (qualifiers   nil :read-only t :type (list-of atom))
-  ;; USES-CNM is a boolean indicating if FUNCTION expects an extra argument
-  ;; holding the next-method.
-  (uses-cnm     nil :read-only t :type boolean)
+  ;; CALL-CON indicates the calling convention expected by FUNCTION:
+  ;; - nil: FUNCTION is just a normal function with no extra arguments for
+  ;;   `call-next-method' or `next-method-p' (which it hence can't use).
+  ;; - `curried': FUNCTION is a curried function that first takes the
+  ;;   "next combined method" and return the resulting combined method.
+  ;;   It can distinguish `next-method-p' by checking if that next method
+  ;;   is `cl--generic-isnot-nnm-p'.
+  ;; - t: FUNCTION takes the `call-next-method' function as its first (extra)
+  ;;      argument.
+  (call-con     nil :read-only t :type symbol)
   (function     nil :read-only t :type function))
 
 (cl-defstruct (cl--generic
@@ -400,6 +407,8 @@ the specializer used will be the one returned by BODY."
       (pcase (macroexpand fun macroenv)
         (`#'(lambda ,args . ,body)
          (let* ((parsed-body (macroexp-parse-body body))
+                (nm (make-symbol "cl--nm"))
+                (arglist (make-symbol "cl--args"))
                 (cnm (make-symbol "cl--cnm"))
                 (nmp (make-symbol "cl--nmp"))
                 (nbody (macroexpand-all
@@ -412,15 +421,49 @@ the specializer used will be the one returned by BODY."
                 ;; is used.
                 ;; FIXME: Also, optimize the case where call-next-method is
                 ;; only called with explicit arguments.
-                (uses-cnm (macroexp--fgrep `((,cnm) (,nmp)) nbody)))
-           (cons (not (not uses-cnm))
-                 `#'(lambda (,@(if uses-cnm (list cnm)) ,@args)
-                      ,@(car parsed-body)
-                      ,(if (not (assq nmp uses-cnm))
-                           nbody
-                         `(let ((,nmp (lambda ()
-                                        (cl--generic-isnot-nnm-p ,cnm))))
-                            ,nbody))))))
+                (uses-cnm (macroexp--fgrep `((,cnm) (,nmp)) nbody))
+                (λ-lift (mapcar #'car uses-cnm)))
+           (if (not uses-cnm)
+               (cons nil
+                     `#'(lambda (,@args)
+                          ,@(car parsed-body)
+                          ,nbody))
+             (cons 'curried
+                   `#'(lambda (,nm) ;Called when constructing the effective method.
+                        (let ((,nmp (if (cl--generic-isnot-nnm-p ,nm)
+                                        #'always #'ignore)))
+                          ;; This `(λ (&rest x) .. (apply (λ (args) ..) x))'
+                          ;; dance is needed because we need to get the original
+                          ;; args as a list when `cl-call-next-method' is
+                          ;; called with no arguments.  It's important to
+                          ;; capture it as a list since it needs to distinguish
+                          ;; the nil case from the absent case in optional
+                          ;; arguments and it needs to properly remember the
+                          ;; original value if `nbody' mutates some of its
+                          ;; formal args.
+                          ;; FIXME: This `(λ (&rest ,arglist)' could be skipped
+                          ;; when we know `cnm' is always called with args, and
+                          ;; it could be implemented more efficiently if `cnm'
+                          ;; is always called directly and there are no
+                          ;; `&optional' args.
+                          (lambda (&rest ,arglist)
+                            ,@(let* ((prebody (car parsed-body))
+                                     (ds (if (stringp (car prebody))
+                                             prebody
+                                           (setq prebody (cons nil prebody))))
+                                     (usage (help-split-fundoc (car ds) nil)))
+                                (unless usage
+                                  (setcar ds (help-add-fundoc-usage (car ds)
+                                                                    args)))
+                                prebody)
+                            (let ((,cnm (lambda (&rest args)
+                                          (apply ,nm (or args ,arglist)))))
+                              ;; This `apply+lambda' basically parses
+                              ;; `arglist' according to `args'.
+                              ;; A destructuring-bind would do the trick
+                              ;; as well when/if it's more efficient.
+                              (apply (lambda (,@λ-lift ,@args) ,nbody)
+                                     ,@λ-lift ,arglist)))))))))
         (f (error "Unexpected macroexpansion result: %S" f))))))
 
 (put 'cl-defmethod 'function-documentation
@@ -518,11 +561,9 @@ The set of acceptable TYPEs (also called \"specializers\") is defined
       (require 'gv)
       (declare-function gv-setter "gv" (name))
       (setq name (gv-setter (cadr name))))
-    (pcase-let* ((`(,uses-cnm . ,fun) (cl--generic-lambda args body)))
+    (pcase-let* ((`(,call-con . ,fun) (cl--generic-lambda args body)))
       `(progn
          ,(and (get name 'byte-obsolete-info)
-               (or (not (fboundp 'byte-compile-warning-enabled-p))
-                   (byte-compile-warning-enabled-p 'obsolete name))
                (let* ((obsolete (get name 'byte-obsolete-info)))
                  (macroexp-warn-and-return
                   (macroexp--obsolete-warning name obsolete "generic function")
@@ -534,7 +575,7 @@ The set of acceptable TYPEs (also called \"specializers\") is defined
          ;; The ",'" is a no-op that pacifies check-declare.
          (,'declare-function ,name "")
          (cl-generic-define-method ',name ',(nreverse qualifiers) ',args
-                                   ,uses-cnm ,fun)))))
+                                   ',call-con ,fun)))))
 
 (defun cl--generic-member-method (specializers qualifiers methods)
   (while
@@ -552,7 +593,7 @@ The set of acceptable TYPEs (also called \"specializers\") is defined
   `(,name ,qualifiers . ,specializers))
 
 ;;;###autoload
-(defun cl-generic-define-method (name qualifiers args uses-cnm function)
+(defun cl-generic-define-method (name qualifiers args call-con function)
   (pcase-let*
       ((generic (cl-generic-ensure-function name))
        (`(,spec-args . ,_) (cl--generic-split-args args))
@@ -561,7 +602,7 @@ The set of acceptable TYPEs (also called \"specializers\") is defined
                                    spec-arg (cdr spec-arg)))
                              spec-args))
        (method (cl--generic-make-method
-                specializers qualifiers uses-cnm function))
+                specializers qualifiers call-con function))
        (mt (cl--generic-method-table generic))
        (me (cl--generic-member-method specializers qualifiers mt))
        (dispatches (cl--generic-dispatches generic))
@@ -738,29 +779,38 @@ for all those different tags in the method-cache.")
                   (list (cl--generic-name generic)))
         f))))
 
-(defun cl--generic-no-next-method-function (generic method)
-  (lambda (&rest args)
-    (apply #'cl-no-next-method generic method args)))
+(oclosure-define (cl--generic-nnm)
+  "Special type for `call-next-method's that just call `no-next-method'.")
 
 (defun cl-generic-call-method (generic method &optional fun)
   "Return a function that calls METHOD.
 FUN is the function that should be called when METHOD calls
 `call-next-method'."
-  (if (not (cl--generic-method-uses-cnm method))
-      (cl--generic-method-function method)
-    (let ((met-fun (cl--generic-method-function method))
-          (next (or fun (cl--generic-no-next-method-function
-                         generic method))))
-      (lambda (&rest args)
-        (apply met-fun
-               ;; FIXME: This sucks: passing just `next' would
-               ;; be a lot more efficient than the lambda+apply
-               ;; quasi-η, but we need this to implement the
-               ;; "if call-next-method is called with no
-               ;; arguments, then use the previous arguments".
-               (lambda (&rest cnm-args)
-                 (apply next (or cnm-args args)))
-               args)))))
+  (let ((met-fun (cl--generic-method-function method)))
+    (pcase (cl--generic-method-call-con method)
+      ('nil met-fun)
+      ('curried
+       (funcall met-fun (or fun
+                            (oclosure-lambda (cl--generic-nnm) (&rest args)
+                              (apply #'cl-no-next-method generic method
+                                     args)))))
+      ;; FIXME: backward compatibility with old convention for `.elc' files
+      ;; compiled before the `curried' convention.
+      (_
+       (lambda (&rest args)
+         (apply met-fun
+                (if fun
+                    ;; FIXME: This sucks: passing just `next' would
+                    ;; be a lot more efficient than the lambda+apply
+                    ;; quasi-η, but we need this to implement the
+                    ;; "if call-next-method is called with no
+                    ;; arguments, then use the previous arguments".
+                    (lambda (&rest cnm-args)
+                      (apply fun (or cnm-args args)))
+                  (oclosure-lambda (cl--generic-nnm) (&rest cnm-args)
+                    (apply #'cl-no-next-method generic method
+                           (or cnm-args args))))
+                args))))))
 
 ;; Standard CLOS name.
 (defalias 'cl-method-qualifiers #'cl--generic-method-qualifiers)
@@ -926,36 +976,9 @@ those methods.")
   "Standard support for :after, :before, :around, and `:extra NAME' qualifiers."
   (cl--generic-standard-method-combination generic methods))
 
-(defconst cl--generic-nnm-sample (cl--generic-no-next-method-function t t))
-(defconst cl--generic-cnm-sample
-  (funcall (cl--generic-build-combined-method
-            nil (list (cl--generic-make-method () () t #'identity)))))
-
 (defun cl--generic-isnot-nnm-p (cnm)
   "Return non-nil if CNM is the function that calls `cl-no-next-method'."
-  ;; ¡Big Gross Ugly Hack!
-  ;; `next-method-p' just sucks, we should let it die.  But EIEIO did support
-  ;; it, and some packages use it, so we need to support it.
-  (catch 'found
-    (cl-assert (function-equal cnm cl--generic-cnm-sample))
-    (if (byte-code-function-p cnm)
-        (let ((cnm-constants (aref cnm 2))
-              (sample-constants (aref cl--generic-cnm-sample 2)))
-          (dotimes (i (length sample-constants))
-            (when (function-equal (aref sample-constants i)
-                                  cl--generic-nnm-sample)
-              (throw 'found
-                     (not (function-equal (aref cnm-constants i)
-                                          cl--generic-nnm-sample))))))
-      (cl-assert (eq 'closure (car-safe cl--generic-cnm-sample)))
-      (let ((cnm-env (cadr cnm)))
-        (dolist (vb (cadr cl--generic-cnm-sample))
-          (when (function-equal (cdr vb) cl--generic-nnm-sample)
-            (throw 'found
-                   (not (function-equal (cdar cnm-env)
-                                        cl--generic-nnm-sample))))
-          (setq cnm-env (cdr cnm-env)))))
-    (error "Haven't found no-next-method-sample in cnm-sample")))
+  (not (eq (oclosure-type cnm) 'cl--generic-nnm)))
 
 ;;; Define some pre-defined generic functions, used internally.
 
@@ -1031,9 +1054,12 @@ MET-NAME is as returned by `cl--generic-load-hist-format'."
 (defun cl--generic-method-info (method)
   (let* ((specializers (cl--generic-method-specializers method))
          (qualifiers   (cl--generic-method-qualifiers method))
-         (uses-cnm     (cl--generic-method-uses-cnm method))
+         (call-con     (cl--generic-method-call-con method))
          (function     (cl--generic-method-function method))
-         (args (help-function-arglist function 'names))
+         (args (help-function-arglist (if (not (eq call-con 'curried))
+                                          function
+                                        (funcall function #'ignore))
+                                      'names))
          (docstring (documentation function))
          (qual-string
           (if (null qualifiers) ""
@@ -1044,7 +1070,7 @@ MET-NAME is as returned by `cl--generic-load-hist-format'."
                       (let ((split (help-split-fundoc docstring nil)))
                         (if split (cdr split) docstring))))
          (combined-args ()))
-    (if uses-cnm (setq args (cdr args)))
+    (if (eq t call-con) (setq args (cdr args)))
     (dolist (specializer specializers)
       (let ((arg (if (eq '&rest (car args))
                      (intern (format "arg%d" (length combined-args)))
diff --git a/lisp/emacs-lisp/oclosure.el b/lisp/emacs-lisp/oclosure.el
index f5a21151f13..db108bd7bee 100644
--- a/lisp/emacs-lisp/oclosure.el
+++ b/lisp/emacs-lisp/oclosure.el
@@ -248,8 +248,6 @@ list of slot properties.  The currently known properties are the following:
        ,(when options (macroexp-warn-and-return name
                        (format "Ignored options: %S" options)
                        nil))
-       (eval-when-compile (unless (fboundp 'oclosure--define)
-                            (load "oclosure.el")))
        (eval-and-compile
          (oclosure--define ',name ,docstring ',parent-names ',slots
                            ,@(when predicate `(:predicate ',predicate))))