mirror of
https://git.savannah.gnu.org/git/emacs.git
synced 2025-02-01 20:06:00 +00:00
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.
This commit is contained in:
Stefan Monnier
parent
b12ad270eb
commit
6f973faa91
@ -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)))
|
||||
|
||||
@ -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))))
|
||||
|
||||
@ -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.
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user