From: Stefan Monnier Date: Mon, 27 Dec 2021 05:52:05 +0000 (-0500) Subject: oclosure.el: Add support for mutable slots X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=55a8e924132c425d1f27493748567071d5cba308;p=emacs.git oclosure.el: Add support for mutable slots * lisp/emacs-lisp/oclosure.el (oclosure--defstruct-make-copiers): Adjust for the case of mutable slots. Optimize the mandatory arg case. Don't mark the copiers as inlinable. (oclosure-define): Allow `:type` and `:mutable` properties on slots. (oclosure--lambda): Add `mutables` arg. (oclosure-lambda): Pass it. (oclosure--copy): Add `mutlist` arg. (oclosure--get): Add `mutable` arg. (oclosure--set): New function. (oclosure--mut-getter-prototype, oclosure--mut-setter-prototype): New prototype functions. * test/lisp/emacs-lisp/oclosure-tests.el (oclosure-test, oclosure-tests): Add test for copier with mandatory arg. (oclosure-test-mut, oclosure-test--mutate): New test. * lisp/emacs-lisp/nadvice.el (advice): Use separate copiers for the two use-cases, to avoid relying on CL keywords, since they're not optimized away via inlining any more. (advice--make, advice--tweak): Adjust accordingly. --- diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el index d49ac5ae25d..90861a0ee71 100644 --- a/lisp/emacs-lisp/nadvice.el +++ b/lisp/emacs-lisp/nadvice.el @@ -43,7 +43,8 @@ (push (purecopy '(nadvice 1 0)) package--builtin-versions) (oclosure-define (advice - (:copier advice--copy)) + (:copier advice--cons (cdr)) + (:copier advice--copy (car cdr where props))) car cdr where props) ;;;; Lightweight advice/hook @@ -207,11 +208,11 @@ WHERE is a symbol to select an entry in `advice--where-alist'." (if (and md (> fd md)) ;; `function' should go deeper. (let ((rest (advice--make where function (advice--cdr main) props))) - (advice--copy main :cdr rest)) + (advice--cons main rest)) (let ((proto (assq where advice--where-alist))) (unless proto (error "Unknown add-function location `%S'" where)) (advice--copy (cadr proto) - :car function :cdr main :where where :props props))))) + function main where props))))) (defun advice--member-p (function use-name definition) (let ((found nil)) @@ -237,7 +238,7 @@ WHERE is a symbol to select an entry in `advice--where-alist'." (if val (car val) (let ((nrest (advice--tweak rest tweaker))) (if (eq rest nrest) flist - (advice--copy flist :cdr nrest)))))))) + (advice--cons flist nrest)))))))) ;;;###autoload (defun advice--remove-function (flist function) diff --git a/lisp/emacs-lisp/oclosure.el b/lisp/emacs-lisp/oclosure.el index d957236fa49..7a8290c33ff 100644 --- a/lisp/emacs-lisp/oclosure.el +++ b/lisp/emacs-lisp/oclosure.el @@ -44,6 +44,35 @@ ;; - auto-generate docstrings for cl-defstruct slot accessors instead of ;; storing them in the accessor itself? +;; Related constructs: +;; - `funcallable-standard-object' (FSO) in Common-Lisp. These are different +;; from OClosures in that they involve an additional indirection to get +;; to the actual code, and that they offer the possibility of +;; changing (via mutation) the code associated with +;; an FSO. Also the FSO's function can't directly access the FSO's +;; other fields, contrary to the case with OClosures where those are directly +;; available as local variables. +;; - Function objects in Javascript. +;; - Function objects in Python. +;; - Callable/Applicable classes in OO languages, i.e. classes with +;; a single method called `apply' or `call'. The most obvious +;; difference with OClosures (beside the fact that Callable can be +;; extended with additional methods) is that all instances of +;; a given Callable class have to use the same method, whereas every +;; OClosure object comes with its own code, so two OClosure objects of the +;; same type can have different code. Of course, you can get the +;; same result by turning every `oclosure-lambda' into its own class +;; declaration creating an ad-hoc subclass of the specified type. +;; In this sense, OClosures are just a generalization of `lambda' which brings +;; some of the extra feature of Callable objects. +;; - Apply hooks and "entities" in MIT Scheme +;; https://www.gnu.org/software/mit-scheme/documentation/stable/mit-scheme-ref/Application-Hooks.html +;; Apply hooks are basically the same as Common-Lisp's FSOs, and "entities" +;; are a variant of it where the inner function gets the FSO itself as +;; additional argument (a kind of "self" arg), thus making it easier +;; for the code to get data from the object's extra info, tho still +;; not as easy as with OClosures. + ;;; Code: ;; Slots are currently immutable, tho they can be updated functionally @@ -54,7 +83,7 @@ ;; to perform store-conversion on the variable, so we'd either have ;; to prevent cconv from doing it (which might require a new bytecode op ;; to update the in-closure variable), or we'd have to keep track of which -;; slots have been store-converted so `oclosure-get' can access their value +;; slots have been store-converted so `oclosure--get' can access their value ;; correctly. ;; - If the mutated variable/slot is captured by another (nested) closure ;; store-conversion is indispensable, so if we want to avoid store-conversion @@ -86,34 +115,58 @@ (memq 'oclosure-object (oclosure--class-allparents (cl--find-class type)))))) (cl-deftype oclosure-object () '(satisfies oclosure--object-p)) -(defun oclosure--defstruct-make-copiers (copiers slots name) - (require 'cl-macs) ;`cl--arglist-args' is not autoloaded. - (mapcar - (lambda (copier) - (pcase-let* - ((cname (pop copier)) - (args (or (pop copier) `(&key ,@slots))) - (doc (or (pop copier) - (format "Copier for objects of type `%s'." name))) - (obj (make-symbol "obj")) - (absent (make-symbol "absent")) - (anames (cl--arglist-args args)) - (index -1) - (argvals - (mapcar - (lambda (slot) - (setq index (1+ index)) - (when (memq slot anames) - ;; FIXME: Skip the `unless' test for mandatory args. - `(if (eq ',absent ,slot) - (oclosure-get ,obj ,index) - ,slot))) - slots))) - `(cl-defsubst ,cname (&cl-defs (',absent) ,obj ,@args) - ,doc - (declare (side-effect-free t)) - (oclosure--copy ,obj ,@argvals)))) - copiers)) +(defun oclosure--defstruct-make-copiers (copiers slotdescs name) + (require 'cl-macs) ;`cl--arglist-args' is not autoloaded. + (let* ((mutables '()) + (slots (mapcar + (lambda (desc) + (let ((name (cl--slot-descriptor-name desc))) + (unless (alist-get :read-only + (cl--slot-descriptor-props desc)) + (push name mutables)) + name)) + slotdescs))) + (mapcar + (lambda (copier) + (pcase-let* + ((cname (pop copier)) + (args (or (pop copier) `(&key ,@slots))) + (doc (or (pop copier) + (format "Copier for objects of type `%s'." name))) + (obj (make-symbol "obj")) + (absent (make-symbol "absent")) + (anames (cl--arglist-args args)) + (mnames + (let ((res '()) + (tmp args)) + (while (and tmp + (not (memq (car tmp) + cl--lambda-list-keywords))) + (push (pop tmp) res)) + res)) + (index -1) + (mutlist '()) + (argvals + (mapcar + (lambda (slot) + (setq index (1+ index)) + (let* ((mutable (memq slot mutables)) + (get `(oclosure--get ,obj ,index ,(not (not mutable))))) + (push mutable mutlist) + (cond + ((not (memq slot anames)) get) + ((memq slot mnames) slot) + (t + `(if (eq ',absent ,slot) + ,get + ,slot))))) + slots))) + `(cl-defun ,cname (&cl-defs (',absent) ,obj ,@args) + ,doc + (declare (side-effect-free t)) + (oclosure--copy ,obj ',(if (remq nil mutlist) (nreverse mutlist)) + ,@argvals)))) + copiers))) (defmacro oclosure-define (name &optional docstring &rest slots) (declare (doc-string 2) (indent 1)) @@ -165,12 +218,28 @@ (cons sa (merge (cdr slots-a) (cdr slots-b)))))))) class)) parent-names)) - (slotdescs (append - parent-slots - (mapcar (lambda (field) - (cl--make-slot-descriptor field nil nil - '((:read-only . t)))) - slots))) + (slotdescs + (append + parent-slots + (mapcar (lambda (field) + (if (not (consp field)) + (cl--make-slot-descriptor field nil nil + '((:read-only . t))) + (let ((name (pop field)) + (type nil) + (read-only t) + (props '())) + (while field + (pcase (pop field) + (:mutable (setq read-only (not (car field)))) + (:type (setq type (car field))) + (p (message "Unknown property: %S" p) + (push (cons p (car field)) props))) + (setq field (cdr field))) + (cl--make-slot-descriptor name nil type + `((:read-only . ,read-only) + ,@props))))) + slots))) (allparents (apply #'append (mapcar #'cl--class-allparents parents))) (class (oclosure--class-make name docstring slotdescs parents @@ -191,21 +260,36 @@ (cl--find-class type)))))))) ,@(let ((i -1)) (mapcar (lambda (desc) - (let ((slot (cl--slot-descriptor-name desc))) + (let* ((slot (cl--slot-descriptor-name desc)) + (mutable + (not (alist-get :read-only + (cl--slot-descriptor-props desc)))) + ;; Always use a double hyphen: if users wants to + ;; make it public, they can do so with an alias. + (name (intern (format "%S--%S" name slot)))) (cl-incf i) (when (gethash slot it) (error "Duplicate slot name: %S" slot)) (setf (gethash slot it) i) - ;; Always use a double hyphen: if users wants to - ;; make it public, they can do so with an alias. - `(defalias ',(intern (format "%S--%S" name slot)) - ;; We use `oclosure--copy' instead of `oclosure--accessor-copy' - ;; here to circumvent bootstrapping problems. - (oclosure--copy oclosure--accessor-prototype - ',name ',slot ,i)))) + (if (not mutable) + `(defalias ',name + ;; We use `oclosure--copy' instead of + ;; `oclosure--accessor-copy' here to circumvent + ;; bootstrapping problems. + (oclosure--copy oclosure--accessor-prototype nil + ',name ',slot ,i)) + `(progn + (defalias ',name + (oclosure--accessor-copy + oclosure--mut-getter-prototype + ',name ',slot ,i)) + (defalias ',(gv-setter name) + (oclosure--accessor-copy + oclosure--mut-setter-prototype + ',name ',slot ,i)))))) slotdescs)) ,@(oclosure--defstruct-make-copiers - copiers (mapcar #'cl--slot-descriptor-name slotdescs) name)))) + copiers slotdescs name)))) (defun oclosure--define (class pred) (let* ((name (cl--class-name class)) @@ -214,10 +298,12 @@ (defalias predname pred) (put name 'cl-deftype-satisfies predname))) -(defmacro oclosure--lambda (type bindings args &rest body) +(defmacro oclosure--lambda (type bindings mutables args &rest body) "Low level construction of an OClosure object. TYPE is expected to be a symbol that is (or will be) defined as an OClosure type. BINDINGS should list all the slots expected by this type, in the proper order. +MUTABLE is a list of symbols indicating which of the BINDINGS +should be mutable. No checking is performed," (declare (indent 3) (debug (sexp (&rest (sexp form)) sexp def-body))) ;; FIXME: Fundamentally `oclosure-lambda' should be a special form. @@ -230,7 +316,10 @@ No checking is performed," ;; FIXME: Since we use the docstring internally to store the ;; type we can't handle actual docstrings. We could fix this by adding ;; a docstring slot to OClosures. - ((`(,prebody . ,body) (macroexp-parse-body body))) + ((`(,prebody . ,body) (macroexp-parse-body body)) + (rovars (mapcar #'car bindings))) + (dolist (mutable mutables) + (setq rovars (delq mutable rovars))) `(let ,(mapcar (lambda (bind) (if (cdr bind) bind ;; Bind to something that doesn't look @@ -245,13 +334,13 @@ No checking is performed," ;; This `oclosure--fix-type' + `ignore' call is used by the compiler (in ;; `cconv.el') to detect and signal an error in case of ;; store-conversion (i.e. if a variable/slot is mutated). - (ignore ,@(mapcar #'car bindings)) + (ignore ,@rovars) (lambda ,args (:documentation ',type) ,@prebody ;; Add dummy code which accesses the field's vars to make sure ;; they're captured in the closure. - (if t nil ,@(mapcar #'car bindings)) + (if t nil ,@rovars ,@(mapcar (lambda (m) `(setq ,m ,m)) mutables)) ,@body))))) (defmacro oclosure-lambda (type-and-slots args &rest body) @@ -268,8 +357,13 @@ ARGS and BODY are the same as for `lambda'." ((`(,type . ,fields) type-and-slots) (class (cl--find-class type)) (slots (oclosure--class-slots class)) + (mutables '()) (slotbinds (mapcar (lambda (slot) - (list (cl--slot-descriptor-name slot))) + (let ((name (cl--slot-descriptor-name slot)) + (props (cl--slot-descriptor-props slot))) + (unless (alist-get :read-only props) + (push name mutables)) + (list name))) slots)) (tempbinds (mapcar (lambda (field) @@ -287,7 +381,7 @@ ARGS and BODY are the same as for `lambda'." fields))) ;; FIXME: Optimize temps away when they're provided in the right order? `(let ,tempbinds - (oclosure--lambda ,type ,slotbinds ,args ,@body)))) + (oclosure--lambda ,type ,slotbinds ,mutables ,args ,@body)))) (defun oclosure--fix-type (_ignore oclosure) (if (byte-code-function-p oclosure) @@ -307,9 +401,12 @@ ARGS and BODY are the same as for `lambda'." (cadr oclosure)) oclosure))) -(defun oclosure--copy (oclosure &rest args) +(defun oclosure--copy (oclosure mutlist &rest args) (if (byte-code-function-p oclosure) - (apply #'make-closure oclosure args) + (apply #'make-closure oclosure + (if (null mutlist) + args + (mapcar (lambda (arg) (if (pop mutlist) (list arg) arg)) args))) (cl-assert (eq 'closure (car-safe oclosure))) (cl-assert (eq :type (caar (cadr oclosure)))) (let ((env (cadr oclosure))) @@ -322,14 +419,24 @@ ARGS and BODY are the same as for `lambda'." ,@(nthcdr (1+ (length args)) env)) ,@(nthcdr 2 oclosure))))) -(defun oclosure-get (oclosure index) +(defun oclosure--get (oclosure index mutable) (if (byte-code-function-p oclosure) - (let ((csts (aref oclosure 2))) - (aref csts index)) + (let* ((csts (aref oclosure 2)) + (v (aref csts index))) + (if mutable (car v) v)) (cl-assert (eq 'closure (car-safe oclosure))) (cl-assert (eq :type (caar (cadr oclosure)))) (cdr (nth (1+ index) (cadr oclosure))))) +(defun oclosure--set (v oclosure index) + (if (byte-code-function-p oclosure) + (let* ((csts (aref oclosure 2)) + (cell (aref csts index))) + (setcar cell v)) + (cl-assert (eq 'closure (car-safe oclosure))) + (cl-assert (eq :type (caar (cadr oclosure)))) + (setcdr (nth (1+ index) (cadr oclosure)) v))) + (defun oclosure-type (oclosure) "Return the type of OCLOSURE, or nil if the arg is not a OClosure." (if (byte-code-function-p oclosure) @@ -345,7 +452,8 @@ ARGS and BODY are the same as for `lambda'." ;; Use `oclosure--lambda' to circumvent a bootstrapping problem: ;; `oclosure-accessor' is not yet defined at this point but ;; `oclosure--accessor-prototype' is needed when defining `oclosure-accessor'. - (oclosure--lambda oclosure-accessor ((type) (slot) (index)) (oclosure) (oclosure-get oclosure index))) + (oclosure--lambda oclosure-accessor ((type) (slot) (index)) nil + (oclosure) (oclosure--get oclosure index nil))) (oclosure-define accessor "OClosure function to access a specific slot of an object." @@ -370,5 +478,13 @@ ARGS and BODY are the same as for `lambda'." "OClosure function to access a specific slot of an OClosure function." index) +(defconst oclosure--mut-getter-prototype + (oclosure-lambda (oclosure-accessor (type) (slot) (index)) (oclosure) + (oclosure--get oclosure index t))) +(defconst oclosure--mut-setter-prototype + ;; FIXME: The generated docstring is wrong. + (oclosure-lambda (oclosure-accessor (type) (slot) (index)) (val oclosure) + (oclosure--set val oclosure index))) + (provide 'oclosure) ;;; oclosure.el ends here diff --git a/test/lisp/emacs-lisp/oclosure-tests.el b/test/lisp/emacs-lisp/oclosure-tests.el index 50d05738d39..0a256a5baa4 100644 --- a/test/lisp/emacs-lisp/oclosure-tests.el +++ b/test/lisp/emacs-lisp/oclosure-tests.el @@ -24,8 +24,8 @@ (require 'cl-lib) (oclosure-define (oclosure-test - ;; FIXME: Test `:parent'! - (:copier oclosure-test-copy)) + (:copier oclosure-test-copy) + (:copier oclosure-test-copy1 (fst))) "Simple OClosure." fst snd name) @@ -41,11 +41,11 @@ (ert-deftest oclosure-tests () (let* ((i 42) - (ocl1 (oclosure-lambda oclosure-test ((fst 1) (snd 2) (name "hi")) - () + (ocl1 (oclosure-lambda (oclosure-test (fst 1) (snd 2) (name "hi")) + () (list fst snd i))) - (ocl2 (oclosure-lambda oclosure-test ((name (cl-incf i)) (fst (cl-incf i))) - () + (ocl2 (oclosure-lambda (oclosure-test (name (cl-incf i)) (fst (cl-incf i))) + () (list fst snd 152 i)))) (should (equal (list (oclosure-test--fst ocl1) (oclosure-test--snd ocl1) @@ -58,6 +58,7 @@ (should (equal (funcall ocl1) '(1 2 44))) (should (equal (funcall ocl2) '(44 nil 152 44))) (should (equal (funcall (oclosure-test-copy ocl1 :fst 7)) '(7 2 44))) + (should (equal (funcall (oclosure-test-copy1 ocl1 9)) '(9 2 44))) (should (cl-typep ocl1 'oclosure-test)) (should (cl-typep ocl1 'oclosure-object)) (should (member (oclosure-test-gen ocl1) @@ -72,7 +73,7 @@ (byte-compile-debug t)) (byte-compile '(lambda () (let ((inc-where nil)) - (oclosure-lambda advice ((where 'foo)) () + (oclosure-lambda (advice (where 'foo)) () (setq inc-where (lambda () (setq where (1+ where)))) where)))) nil) @@ -95,10 +96,29 @@ (string-match "Duplicate slot name: where$" (cadr err)))))) (should (condition-case err - (progn (macroexpand '(oclosure-lambda advice ((where 1) (where 2)) () where)) + (progn (macroexpand '(oclosure-lambda (advice (where 1) (where 2)) () where)) nil) (error (and (eq 'error (car err)) (string-match "Duplicate slot: where$" (cadr err))))))) +(oclosure-define (oclosure-test-mut + (:parent oclosure-test) + (:copier oclosure-test-mut-copy)) + "Simple OClosure with a mutable field." + (mut :mutable t)) + +(ert-deftest oclosure-test--mutate () + (let* ((f (oclosure-lambda (oclosure-test-mut (fst 0) (mut 3)) + (x) + (+ x fst mut))) + (f2 (oclosure-test-mut-copy f :fst 50))) + (should (equal (oclosure-test-mut--mut f) 3)) + (should (equal (funcall f 5) 8)) + (should (equal (funcall f2 5) 58)) + (cl-incf (oclosure-test-mut--mut f) 7) + (should (equal (oclosure-test-mut--mut f) 10)) + (should (equal (funcall f 5) 15)) + (should (equal (funcall f2 15) 68)))) + ;;; oclosure-tests.el ends here.