[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
master 6f973faa91 2/2: cl-generic: Use OClosures for `cl--generic-isnot-
|
From: |
Stefan Monnier |
|
Subject: |
master 6f973faa91 2/2: cl-generic: Use OClosures for `cl--generic-isnot-nnm-p` |
|
Date: |
Wed, 30 Mar 2022 17:08:34 -0400 (EDT) |
branch: master
commit 6f973faa912a5ac1ba643c6f5deb0c02baa0ba6d
Author: Stefan Monnier <monnier@iro.umontreal.ca>
Commit: Stefan Monnier <monnier@iro.umontreal.ca>
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.
---
lisp/emacs-lisp/cl-generic.el | 162 ++++++++++++++++++++++++------------------
lisp/emacs-lisp/oclosure.el | 2 -
lisp/loadup.el | 1 +
3 files changed, 95 insertions(+), 70 deletions(-)
diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el
index 295512d51e..279f73f36a 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 f5a21151f1..db108bd7be 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))))
diff --git a/lisp/loadup.el b/lisp/loadup.el
index faeb9188e4..6ca699f901 100644
--- a/lisp/loadup.el
+++ b/lisp/loadup.el
@@ -197,6 +197,7 @@
(load "button") ;After loaddefs, because of define-minor-mode!
(load "emacs-lisp/cl-preloaded")
+(load "emacs-lisp/oclosure") ;Used by cl-generic
(load "obarray") ;abbrev.el is implemented in terms of obarrays.
(load "abbrev") ;lisp-mode.el and simple.el use define-abbrev-table.