From b426ab51d0598242a4c2b57d563341db66d71f7b Mon Sep 17 00:00:00 2001 From: Mark Wooding Date: Sun, 30 Aug 2015 10:58:38 +0100 Subject: [PATCH] src/: Allow methods to have more than one entry each in a vtable. The entries are assigned distinct `roles' to distinguish them. Each role can have a different type. To accommodate this a number of changes are made to the API. Note that no roles other than the standard `nil' role are currently defined, so none of this change should have any externally observable effect. * The `make-method-entry' method is replaced by `make-method-entries', which returns a list of entry objects. The standard method on `compute-vtmsgs' collects these together into a big list. * Slots in the `vtmsgs' structure are now given names by the method entries directly, rather than being named after their messages. There is a new generic function `method-entry-slot-name' to make this work, and a little protocol `method-entry-slot-name-by-role' to make extending this machinery easy. * The `message-macro-name' function now takes a method-entry rather than a message, because each entry needs its own macro. * The `method-entry-function-name' function has grown an additional `role' argument. The standard method inserts a non-nil role name in an unimaginative manner. * The standard method on `method-entry-function-type' now inspects the entry role, but its behaviour is unchanged except to check that the role is nil. --- src/class-layout-impl.lisp | 11 ++++++----- src/class-output.lisp | 18 ++++++++---------- src/class-utilities.lisp | 4 ++-- src/method-impl.lisp | 42 +++++++++++++++++++++++++++++------------- src/method-proto.lisp | 46 +++++++++++++++++++++++++++++++++------------- 5 files changed, 78 insertions(+), 43 deletions(-) diff --git a/src/class-layout-impl.lisp b/src/class-layout-impl.lisp index 3a5b5cd..950db2b 100644 --- a/src/class-layout-impl.lisp +++ b/src/class-layout-impl.lisp @@ -104,9 +104,10 @@ (defmethod print-object ((entry method-entry) stream) (maybe-print-unreadable-object (entry stream :type t) - (format stream "~A:~A" + (format stream "~A:~A~@[ ~S~]" (method-entry-effective-method entry) - (sod-class-nickname (method-entry-chain-head entry))))) + (sod-class-nickname (method-entry-chain-head entry)) + (method-entry-role entry)))) (defmethod compute-sod-effective-method ((message sod-message) (class sod-class)) @@ -229,17 +230,17 @@ (subclass sod-class) (chain-head sod-class) (chain-tail sod-class)) - (flet ((make-entry (message) + (flet ((make-entries (message) (let ((method (find message (sod-class-effective-methods subclass) :key #'effective-method-message))) - (make-method-entry method chain-head chain-tail)))) + (make-method-entries method chain-head chain-tail)))) (make-instance 'vtmsgs :class class :subclass subclass :chain-head chain-head :chain-tail chain-tail - :entries (mapcar #'make-entry + :entries (mapcan #'make-entries (sod-class-messages class))))) ;;; class-pointer diff --git a/src/class-output.lisp b/src/class-output.lisp index d6ead49..2ab6363 100644 --- a/src/class-output.lisp +++ b/src/class-output.lisp @@ -125,16 +125,14 @@ (dolist (entry (vtmsgs-entries vtmsgs)) (let* ((type (method-entry-function-type entry)) (args (c-function-arguments type)) - (method (method-entry-effective-method entry)) - (message (effective-method-message method)) (in-names nil) (out-names nil) (varargsp nil) (me "me")) (do ((args args (cdr args))) ((endp args)) - (let* ((raw-name (argument-name (car args))) + (let* ((raw-name (princ-to-string (argument-name (car args)))) (name (if (find raw-name (list "_vt" (sod-class-nickname class) - (sod-message-name message)) + (method-entry-slot-name entry)) :test #'string=) (format nil "sod__a_~A" raw-name) raw-name))) @@ -151,11 +149,11 @@ (format stream "#if __STDC_VERSION__ >= 199901~%")) (format stream "#define ~A(~{~A~^, ~}) ~ ~A->_vt->~A.~A(~{~A~^, ~})~%" - (message-macro-name class message) + (message-macro-name class entry) (nreverse in-names) me (sod-class-nickname class) - (sod-message-name message) + (method-entry-slot-name entry) (nreverse out-names)) (when varargsp (format stream "#endif~%")))) @@ -348,7 +346,7 @@ (sequence-output (stream sequencer) ((class :vtmsgs (sod-message-class message) :slots) (pprint-logical-block (stream nil :prefix " " :suffix ";") - (pprint-c-type pointer-type stream (sod-message-name message))) + (pprint-c-type pointer-type stream (method-entry-slot-name entry))) (terpri stream))))) (defmethod hook-output progn ((cptr class-pointer) @@ -541,15 +539,15 @@ const struct ~A ~A__classobj = {~%" (defmethod hook-output progn ((entry method-entry) (reason (eql :c)) sequencer) - (with-slots (method chain-head chain-tail) entry + (with-slots (method chain-head chain-tail role) entry (let* ((message (effective-method-message method)) (class (effective-method-class method)) (super (sod-message-class message))) (sequence-output (stream sequencer) ((class :vtable chain-head :vtmsgs super :slots) (format stream " /* ~19@A = */ ~A,~%" - (sod-message-name message) - (method-entry-function-name method chain-head))))))) + (method-entry-slot-name entry) + (method-entry-function-name method chain-head role))))))) ;;;-------------------------------------------------------------------------- ;;; Filling in the class object. diff --git a/src/class-utilities.lisp b/src/class-utilities.lisp index 5a74bcb..f00bc64 100644 --- a/src/class-utilities.lisp +++ b/src/class-utilities.lisp @@ -198,7 +198,7 @@ (format nil "~A__vtable_~A" class (sod-class-nickname chain-head))) (export 'message-macro-name) -(defun message-macro-name (class message) - (format nil "~A_~A" class (sod-message-name message))) +(defun message-macro-name (class entry) + (format nil "~A_~A" class (method-entry-slot-name entry))) ;;;----- That's all, folks -------------------------------------------------- diff --git a/src/method-impl.lisp b/src/method-impl.lisp index 9dd75b4..46f268b 100644 --- a/src/method-impl.lisp +++ b/src/method-impl.lisp @@ -355,33 +355,49 @@ effective method out into its own function.") (defmethod method-entry-function-name - ((method effective-method) (chain-head sod-class)) + ((method effective-method) (chain-head sod-class) role) (let* ((class (effective-method-class method)) (message (effective-method-message method)) (message-class (sod-message-class message))) (if (or (not (slot-boundp method 'functions)) (slot-value method 'functions)) - (format nil "~A__mentry_~A__~A__chain_~A" - class + (format nil "~A__mentry~@[__~(~A~)~]_~A__~A__chain_~A" + class role (sod-class-nickname message-class) (sod-message-name message) (sod-class-nickname chain-head)) 0))) +(defmethod method-entry-slot-name ((entry method-entry)) + (let* ((method (method-entry-effective-method entry)) + (message (effective-method-message method)) + (name (sod-message-name message)) + (role (method-entry-role entry))) + (method-entry-slot-name-by-role entry role name))) + (defmethod method-entry-function-type ((entry method-entry)) (let* ((method (method-entry-effective-method entry)) (message (effective-method-message method)) - (type (sod-message-type message))) + (type (sod-message-type message)) + (tail (ecase (method-entry-role entry) + ((nil) (sod-message-argument-tail message))))) (c-type (fun (lisp (c-type-subtype type)) ("me" (* (class (method-entry-chain-tail entry)))) - . (sod-message-argument-tail message))))) - -(defmethod make-method-entry ((method basic-effective-method) - (chain-head sod-class) (chain-tail sod-class)) - (make-instance 'method-entry - :method method - :chain-head chain-head - :chain-tail chain-tail)) + . tail)))) + +(defmethod make-method-entries ((method basic-effective-method) + (chain-head sod-class) + (chain-tail sod-class)) + (let ((entries nil) + (message (effective-method-message method))) + (flet ((make (role) + (push (make-instance 'method-entry + :method method :role role + :chain-head chain-head + :chain-tail chain-tail) + entries))) + (make nil) + entries))) (defmethod compute-method-entry-functions ((method basic-effective-method)) @@ -450,7 +466,7 @@ (emit-inst codegen (make-va-end-inst *sod-ap*))) (finish-entry (tail) (let* ((head (sod-class-chain-head tail)) - (name (method-entry-function-name method head)) + (name (method-entry-function-name method head nil)) (type (c-type (fun (lisp return-type) ("me" (* (class tail))) . entry-args)))) diff --git a/src/method-proto.lisp b/src/method-proto.lisp index 8b3822a..78429ef 100644 --- a/src/method-proto.lisp +++ b/src/method-proto.lisp @@ -85,14 +85,16 @@ (chain-head :initarg :chain-head :type sod-class :reader method-entry-chain-head) (chain-tail :initarg :chain-tail :type sod-class - :reader method-entry-chain-tail)) + :reader method-entry-chain-tail) + (role :initarg :role :type (or :keyword null) :reader method-entry-role)) (:documentation "An entry point into an effective method. - Specifically, this is the entry point to the effective method METHOD - invoked via the vtable for the chain headed by CHAIN-HEAD. The CHAIN-TAIL - is the most specific class on this chain; this is useful because we can - reuse the types of method entries from superclasses on non-primary chains. + Specifically, this is the entry point to the effective METHOD invoked via + the vtable for the chain headed by CHAIN-HEAD, and serving the given ROLE. + The CHAIN-TAIL is the most specific class on this chain; this is useful + because we can reuse the types of method entries from superclasses on + non-primary chains. Each effective method may have several different method entries, because an effective method can be called via vtables attached to different @@ -101,16 +103,22 @@ job of the method entry to adjust the instance pointers correctly for the rest of the effective method. + A vtable can contain more than one entry for the same message. Such + entries are distinguished by their roles. A message always has an entry + with the `nil role. No other roles are currently defined, though they may + be introduced by extensions. + The boundaries between a method entry and the effective method is (intentionally) somewhat fuzzy. In extreme cases, the effective method may not exist at all as a distinct entity in the output because its content is duplicated in all of the method entry functions. This is left up to the effective method protocol.")) -(export 'make-method-entry) -(defgeneric make-method-entry (effective-method chain-head chain-tail) +(export 'make-method-entries) +(defgeneric make-method-entries (effective-method chain-head chain-tail) (:documentation - "Return a METHOD-ENTRY for an EFFECTIVE-METHOD called via CHAIN-HEAD. + "Return a list of `method-entry' objects for an EFFECTIVE-METHOD called + via CHAIN-HEAD. There is no default method for this function. (Maybe when the effective-method/method-entry output protocol has settled down I'll know @@ -180,6 +188,17 @@ (:documentation "Return the C function type for a method entry.")) +(export 'method-entry-slot-name) +(defgeneric method-entry-slot-name (entry) + (:documentation + "Return the `vtmsgs' slot name for a method entry. + + The default method indirects through `method-entry-slot-name-by-role'.")) + +(defgeneric method-entry-slot-name-by-role (entry role name) + (:documentation "Easier implementation for `method-entry-slot-name'.") + (:method ((entry method-entry) (role (eql nil)) name) name)) + (export 'effective-method-basic-argument-names) (defgeneric effective-method-basic-argument-names (method) (:documentation @@ -312,7 +331,8 @@ (return-type (c-type-subtype message-type)) (raw-args (sod-message-argument-tail message)) (arguments (if (varargs-message-p message) - (cons (make-argument *sod-ap* (c-type va-list)) + (cons (make-argument *sod-ap* + (c-type va-list)) (butlast raw-args)) raw-args))) (codegen-push codegen) @@ -332,13 +352,13 @@ "Returns the function name of an effective method.")) (export 'method-entry-function-name) -(defgeneric method-entry-function-name (method chain-head) +(defgeneric method-entry-function-name (method chain-head role) (:documentation "Returns the function name of a method entry. - The method entry is given as an effective method/chain-head pair, rather - than as a method entry object because we want the function name before - we've made the entry object.")) + The method entry is given as an effective method/chain-head/role triple, + rather than as a method entry object because we want the function name + before we've made the entry object.")) (export 'compute-method-entry-functions) (defgeneric compute-method-entry-functions (method) -- 2.11.0