More work. Highlights:

[sod] / class-layout.lisp

;;; -*-lisp-*-
;;;
;;; Layout for instances and vtables
;;;
;;; (c) 2009 Straylight/Edgeware
;;;

;;;----- Licensing notice ---------------------------------------------------
;;;
;;; This file is part of the Simple Object Definition system.
;;;
;;; SOD is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2 of the License, or
;;; (at your option) any later version.
;;;
;;; SOD is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with SOD; if not, write to the Free Software Foundation,
;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.

(cl:in-package #:sod)

;;;--------------------------------------------------------------------------
;;; Effective slot objects.

(defclass effective-slot ()
  ((class :initarg :class :type sod-slot :reader effective-slot-class)
   (slot :initarg :slot :type sod-slot :reader effective-slot-direct-slot)
   (initializer :initarg :initializer :type (or sod-initializer null)
		:reader effective-slot-initializer))
  (:documentation
   "Describes a slot and how it's meant to be initialized.

   Effective slot objects are usually attached to layouts."))

(defgeneric find-slot-initializer (class slot)
  (:documentation
   "Return the most specific initializer for SLOT, starting from CLASS."))

(defgeneric compute-effective-slot (class slot)
  (:documentation
   "Construct an effective slot from the supplied direct slot.

   SLOT is a direct slot defined on CLASS or one of its superclasses.
   (Metaclass initializers are handled using a different mechanism.)"))

(defmethod print-object ((slot effective-slot) stream)
  (maybe-print-unreadable-object (slot stream :type t)
    (format stream "~A~@[ = ~@_~A~]"
	    (effective-slot-direct-slot slot)
	    (effective-slot-initializer slot))))

(defmethod find-slot-initializer ((class sod-class) (slot sod-slot))
  (some (lambda (super)
	  (find slot
		(sod-class-instance-initializers super)
		:key #'sod-initializer-slot))
	(sod-class-precedence-list class)))

(defmethod compute-effective-slot ((class sod-class) (slot sod-slot))
  (make-instance 'effective-slot
		 :slot slot
		 :class class
		 :initializer (find-slot-initializer class slot)))

;;;--------------------------------------------------------------------------
;;; Instance layout objects.

;;; islots

(defclass islots ()
  ((class :initarg :class :type sod-class :reader islots-class)
   (subclass :initarg :subclass :type sod-class :reader islots-subclass)
   (slots :initarg :slots :type list :reader islots-slots))
  (:documentation
   "The collection of effective SLOTS defined by an instance of CLASS."))

(defmethod print-object ((islots islots) stream)
  (print-unreadable-object (islots stream :type t)
    (format stream "~A <= ~A ~_~:<~@{~S~^ ~_~}~:>"
	    (islots-subclass islots)
	    (islots-class islots)
	    (islots-slots islots))))

(defgeneric compute-islots (class subclass)
  (:documentation
   "Return ISLOTS containing EFFECTIVE-SLOTs for a particular CLASS.

   Initializers for the slots should be taken from the most specific
   superclass of SUBCLASS."))

;;; vtable-pointer

(defclass vtable-pointer ()
  ((class :initarg :class :type sod-class :reader vtable-pointer-class)
   (chain-head :initarg :chain-head :type sod-class
	       :reader vtable-pointer-chain-head))
  (:documentation
   "A pointer to the vtable for CLASS corresponding to a particular CHAIN."))

(defmethod print-object ((vtp vtable-pointer) stream)
  (print-unreadable-object (vtp stream :type t)
    (format stream "~A:~A"
	    (vtable-pointer-class vtp)
	    (sod-class-nickname (vtable-pointer-chain-head vtp)))))

;;; ichain

(defclass ichain ()
  ((class :initarg :class :type sod-class :reader ichain-class)
   (chain-head :initarg :chain-head :type sod-class :reader ichain-head)
   (body :initarg :body :type list :reader ichain-body))
  (:documentation
   "All of the instance layout for CLASS corresponding to a particular CHAIN.

   The BODY is a list of things to include in the finished structure.  By
   default, it contains a VTABLE-POINTER and ISLOTS for each class in the
   chain."))

(defmethod print-object ((ichain ichain) stream)
  (print-unreadable-object (ichain stream :type t)
    (format stream "~A:~A ~_~:<~@{~S~^ ~_~}~:>"
	    (ichain-class ichain)
	    (sod-class-nickname (ichain-head ichain))
	    (ichain-body ichain))))

(defgeneric compute-ichain (class chain)
  (:documentation
   "Return an ICHAIN for a particular CHAIN of CLASS's superclasses.

   The CHAIN is a list of classes, with the least specific first -- so the
   chain head is the first element."))

;;; ilayout

(defclass ilayout ()
  ((class :initarg :class :type sod-class :reader ilayout-class)
   (ichains :initarg :ichains :type list :reader ilayout-ichains))
  (:documentation
   "All of the instance layout for a CLASS.

   Consists of an ICHAIN for each distinct chain."))

(defmethod print-object ((ilayout ilayout) stream)
  (print-unreadable-object (ilayout stream :type t)
    (format stream "~A ~_~:<~@{~S~^ ~_~}~:>"
	    (ilayout-class ilayout)
	    (ilayout-ichains ilayout))))

(defgeneric compute-ilayout (class)
  (:documentation
   "Compute and return an instance layout for CLASS."))

;;; Standard implementation.

(defmethod compute-islots ((class sod-class) (subclass sod-class))
  (make-instance 'islots
		 :class class
		 :subclass subclass
		 :slots (mapcar (lambda (slot)
				  (compute-effective-slot subclass slot))
				(sod-class-slots class))))

(defmethod compute-ichain ((class sod-class) chain)
  (let* ((head (car chain))
	 (vtable-pointer (make-instance 'vtable-pointer
					:class class
					:chain-head head))
	 (islots (remove-if-not #'islots-slots
				(mapcar (lambda (super)
					  (compute-islots super class))
					chain))))
    (make-instance 'ichain
		   :class class
		   :chain-head head
		   :body (cons vtable-pointer islots))))

(defmethod compute-ilayout ((class sod-class))
  (make-instance 'ilayout
		 :class class
		 :ichains (mapcar (lambda (chain)
				    (compute-ichain class
						    (reverse chain)))
				  (sod-class-chains class))))

;;;--------------------------------------------------------------------------
;;; Effective methods.

(defclass effective-method ()
  ((message :initarg :message :type sod-message
	    :reader effective-method-message)
   (class :initarg :class :type sod-class :reader effective-method-class))
  (:documentation
   "The effective method invoked by sending MESSAGE to an instance of CLASS.

   This is not a useful class by itself.  Message classes are expected to
   define their own effective-method classes.

   An effective method class must accept a :DIRECT-METHODS initarg, which
   will be a list of applicable methods sorted in most-to-least specific
   order."))

(defmethod print-object ((method effective-method) stream)
  (maybe-print-unreadable-object (method stream :type t)
    (format stream "~A ~A"
	    (effective-method-message method)
	    (effective-method-class method))))

(defgeneric message-effective-method-class (message)
  (:documentation
   "Return the effective method class for the given MESSAGE."))

(defgeneric compute-sod-effective-method (message class)
  (:documentation
   "Return the effective method when a CLASS instance receives MESSAGE.

   The default method constructs an instance of the message's chosen
   MESSAGE-EFFECTIVE-METHOD-CLASS, passing the MESSAGE, the CLASS and the
   list of applicable methods as initargs to MAKE-INSTANCE."))

(defmethod compute-sod-effective-method
    ((message sod-message) (class sod-class))
  (let ((direct-methods (mapcan (lambda (super)
				  (let ((method
					 (find message
					       (sod-class-methods super)
					       :key #'sod-method-message)))
				    (and method (list method))))
				(sod-class-precedence-list class))))
    (make-instance (message-effective-method-class message)
		   :message message
		   :class class
		   :direct-methods direct-methods)))

;;;--------------------------------------------------------------------------
;;; Vtable layout.

;;; method-entry

(defclass method-entry ()
  ((method :initarg :method :type effective-method
	   :reader method-entry-effective-method)
   (chain-head :initarg :chain-head
	       :type sod-class
	       :reader method-entry-chain-head))
  (:documentation
   "An entry point into an effective method.

   Calls to an effective method via different vtable chains will have their
   `me' pointers pointing to different ichains within the instance layout.
   Rather than (necessarily) duplicating the entire effective method for each
   chain, we insert an entry veneer (the method entry) to fix up the pointer.
   Exactly how it does this is up to the effective method -- and duplication
   under some circumstances is probably a reasonable approach -- e.g., if the
   effective method is just going to call a direct method immediately."))

(defmethod print-object ((entry method-entry) stream)
  (maybe-print-unreadable-object (entry stream :type t)
    (format stream "~A:~A"
	    (method-entry-effective-method entry)
	    (sod-class-nickname (method-entry-chain-head entry)))))

(defgeneric make-method-entry (effective-method chain-head)
  (:documentation
   "Return a METHOD-ENTRY 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
   what a sensible default action would be.)"))

;;; vtmsgs

(defclass vtmsgs ()
  ((class :initarg :class :type sod-class :reader vtmsgs-class)
   (subclass :initarg :subclass :type sod-class :reader vtmsgs-subclass)
   (chain-head :initarg :chain-head :type sod-class
	       :reader vtmsgs-chain-head)
   (entries :initarg :entries :type list :reader vtmsgs-entries))
  (:documentation
   "The message dispatch table for a particular CLASS.

   The BODY contains a list of effective method objects for the messages
   defined on CLASS, customized for calling from the chain headed by
   CHAIN-HEAD."))

(defmethod print-object ((vtmsgs vtmsgs) stream)
  (print-unreadable-object (vtmsgs stream :type t)
    (format stream "~A <= ~A ~_~:<~@{~S~^ ~_~}~:>"
	    (vtmsgs-subclass vtmsgs)
	    (vtmsgs-class vtmsgs)
	    (vtmsgs-entries vtmsgs))))

(defgeneric compute-vtmsgs (class subclass chain-head)
  (:documentation
   "Return a VTMSGS object containing method entries for CLASS.

   The CHAIN-HEAD describes which chain the method entries should be
   constructed for.

   The default method simply calls MAKE-METHOD-ENTRY for each of the methods
   and wraps a VTMSGS object around them.  This ought to be enough for almost
   all purposes."))

;;; class-pointer

(defclass class-pointer ()
  ((class :initarg :class :type sod-class :reader class-pointer-class)
   (chain-head :initarg :chain-head :type sod-class
	       :reader class-pointer-chain-head)
   (metaclass :initarg :metaclass :type sod-class
	      :reader class-pointer-metaclass)
   (meta-chain-head :initarg :meta-chain-head :type sod-class
		    :reader class-pointer-meta-chain-head))
  (:documentation
   "Represents a pointer to a class object for the instance's class.

   A class instance can have multiple chains.  It may be useful to find any
   of those chains from an instance of the class.  Therefore the vtable
   stores a pointer to each separate chain of the class instance."))

(defmethod print-object ((cptr class-pointer) stream)
  (print-unreadable-object (cptr stream :type t)
    (format stream "~A:~A"
	    (class-pointer-metaclass cptr)
	    (sod-class-nickname (class-pointer-meta-chain-head cptr)))))

(defgeneric make-class-pointer (class chain-head metaclass meta-chain-head)
  (:documentation
   "Return a class pointer to a metaclass chain."))

;;; base-offset

(defclass base-offset ()
  ((class :initarg :class :type sod-class :reader base-offset-class)
   (chain-head :initarg :chain-head :type sod-class
	       :reader base-offset-chain-head))
  (:documentation
   "The offset of this chain to the ilayout base.

   There's only one of these per vtable."))

(defmethod print-object ((boff base-offset) stream)
  (print-unreadable-object (boff stream :type t)
    (format stream "~A:~A"
	    (base-offset-class boff)
	    (sod-class-nickname (base-offset-chain-head boff)))))

(defgeneric make-base-offset (class chain-head)
  (:documentation
   "Return the base offset object for CHAIN-HEAD ichain."))

;;; chain-offset

(defclass chain-offset ()
  ((class :initarg :class :type sod-class :reader chain-offset-class)
   (chain-head :initarg :chain-head :type sod-class
	       :reader chain-offset-chain-head)
   (target-head :initarg :target-head :type sod-class
		:reader chain-offset-target-head))
  (:documentation
   "The offset from the CHAIN-HEAD ichain to the TARGET-HEAD ichain."))

(defmethod print-object ((choff chain-offset) stream)
  (print-unreadable-object (choff stream :type t)
    (format stream "~A:~A->~A"
	    (chain-offset-class choff)
	    (sod-class-nickname (chain-offset-chain-head choff))
	    (sod-class-nickname (chain-offset-target-head choff)))))

(defgeneric make-chain-offset (class chain-head target-head)
  (:documentation
   "Return the offset from CHAIN-HEAD to TARGET-HEAD."))

;;; vtable

(defclass vtable ()
  ((class :initarg :class :type sod-class :reader vtable-class)
   (chain-head :initarg :chain-head :type sod-class
	       :reader vtable-chain-head)
   (body :initarg :body :type list :reader vtable-body))
  (:documentation
   "VTABLEs hold all of the per-chain static information for a class.

   There is one vtable for each chain of each class.  The vtables for a class
   are prefixes of the corresponding chains of its subclasses.

   Vtables contain method entry pointers, pointers to class objects, and
   the offset information used for cross-chain slot access."))

(defmethod print-object ((vtable vtable) stream)
  (print-unreadable-object (vtable stream :type t)
    (format stream "~A:~A ~_~:<~@{~S~^ ~_~}~:>"
	    (vtable-class vtable)
	    (sod-class-nickname (vtable-chain-head vtable))
	    (vtable-body vtable))))

(defgeneric compute-vtable (class chain)
  (:documentation
   "Compute the vtable layout for a chain of CLASS.

   The CHAIN is a list of classes, with the least specific first."))

(defgeneric compute-vtables (class)
  (:documentation
   "Compute the vtable layouts for CLASS.

   Returns a list of VTABLE objects in the order of CLASS's chains."))

;;; Implementation.

(defmethod compute-vtmsgs
    ((class sod-class)
     (subclass sod-class)
     (chain-head sod-class))
  (flet ((make-entry (message)
	   (let ((method (find message
			       (sod-class-effective-methods subclass)
			       :key #'effective-method-message)))
	     (make-method-entry method chain-head))))
    (make-instance 'vtmsgs
		   :class class
		   :subclass subclass
		   :chain-head chain-head
		   :entries (mapcar #'make-entry
				    (sod-class-messages class)))))

(defmethod make-class-pointer
    ((class sod-class) (chain-head sod-class)
     (metaclass sod-class) (meta-chain-head sod-class))

  ;; Slightly tricky.  We don't necessarily want a pointer to the metaclass,
  ;; but to its most specific subclass on the given chain.  Fortunately, CL
  ;; is good at this game.
  (let* ((meta-chains (sod-class-chains metaclass))
	 (meta-chain-tails (mapcar #'car meta-chains))
	 (meta-chain-tail (find meta-chain-head meta-chain-tails
				:key #'sod-class-chain-head)))
    (make-instance 'class-pointer
		   :class class
		   :chain-head chain-head
		   :metaclass meta-chain-tail
		   :meta-chain-head meta-chain-head)))

(defmethod make-base-offset ((class sod-class) (chain-head sod-class))
  (make-instance 'base-offset
		 :class class
		 :chain-head chain-head))

(defmethod make-chain-offset
    ((class sod-class) (chain-head sod-class) (target-head sod-class))
  (make-instance 'chain-offset
		 :class class
		 :chain-head chain-head
		 :target-head target-head))

;; Special variables used by COMPUTE-VTABLE.
(defvar *done-metaclass-chains*)
(defvar *done-instance-chains*)

(defgeneric compute-vtable-items (class super chain-head emit)
  (:documentation
   "Emit vtable items for a superclass of CLASS.

   This function is called for each superclass SUPER of CLASS reached on the
   chain headed by CHAIN-HEAD.  The function should call EMIT for each
   vtable item it wants to write.

   The right way to check to see whether items have already been emitted
   (e.g., has an offset to some other chain been emitted?) is as follows:

     * In a method on COMPUTE-VTABLE, bind a special variable to an empty
       list or hash table.

     * In a method on this function, check the variable or hash table.

   This function is the real business end of COMPUTE-VTABLE."))

(defmethod compute-vtable-items
    ((class sod-class) (super sod-class) (chain-head sod-class)
     (emit function))

  ;; If this class introduces new metaclass chains, then emit pointers to
  ;; them.
  (let* ((metasuper (sod-class-metaclass super))
	 (metasuper-chains (sod-class-chains metasuper))
	 (metasuper-chain-heads (mapcar (lambda (chain)
					  (sod-class-chain-head (car chain)))
					metasuper-chains)))
    (dolist (metasuper-chain-head metasuper-chain-heads)
      (unless (member metasuper-chain-head *done-metaclass-chains*)
	(funcall emit (make-class-pointer class
					  chain-head
					  metasuper
					  metasuper-chain-head))
	(push metasuper-chain-head *done-metaclass-chains*))))

  ;; If there are new instance chains, then emit offsets to them.
  (let* ((chains (sod-class-chains super))
	 (chain-heads (mapcar (lambda (chain)
				(sod-class-chain-head (car chain)))
			      chains)))
    (dolist (head chain-heads)
      (unless (member head *done-instance-chains*)
	(funcall emit (make-chain-offset class chain-head head))
	(push head *done-instance-chains*))))

  ;; Finally, if there are interesting methods, emit those too.
  (when (sod-class-messages super)
    (funcall emit (compute-vtmsgs super class chain-head))))

(defmethod compute-vtable ((class sod-class) (chain list))
  (let* ((chain-head (car chain))
	 (*done-metaclass-chains* nil)
	 (*done-instance-chains* (list chain-head))
	 (done-superclasses nil)
	 (items nil))
    (flet ((emit (item)
	     (push item items)))

      ;; Find the root chain in the metaclass and write a pointer.
      (let* ((metaclass (sod-class-metaclass class))
	     (metaclass-chains (sod-class-chains metaclass))
	     (metaclass-chain-heads (mapcar (lambda (chain)
					      (sod-class-chain-head
					       (car chain)))
					    metaclass-chains))
	     (metaclass-root-chain (find-if-not
				    #'sod-class-direct-superclasses
				    metaclass-chain-heads)))
	(emit (make-class-pointer class chain-head
				  metaclass metaclass-root-chain))
	(push metaclass-root-chain *done-metaclass-chains*))

      ;; Write an offset to the instance base.
      (emit (make-base-offset class chain-head))

      ;; Now walk the chain.  As we ascend the chain, scan the class
      ;; precedence list of each class in reverse to ensure that we have
      ;; everything interesting.
      (dolist (super chain)
	(dolist (sub (reverse (sod-class-precedence-list super)))
	  (unless (member sub done-superclasses)
	    (compute-vtable-items class
				  sub
				  chain-head
				  #'emit)
	    (push sub done-superclasses))))

      ;; We're through.
      (make-instance 'vtable
		     :class class
		     :chain-head chain-head
		     :body (nreverse items)))))

(defgeneric compute-effective-methods (class)
  (:documentation
   "Return a list of all of the effective methods needed for CLASS.

   The list needn't be in any particular order."))

(defmethod compute-effective-methods ((class sod-class))
  (mapcan (lambda (super)
	    (mapcar (lambda (message)
		      (compute-sod-effective-method message class))
		    (sod-class-messages super)))
	  (sod-class-precedence-list class)))

(defmethod compute-vtables ((class sod-class))
  (mapcar (lambda (chain)
	    (compute-vtable class (reverse chain)))
	  (sod-class-chains class)))

;;;--------------------------------------------------------------------------
;;; Names of things.

(defun islots-struct-tag (class)
  (format nil "~A__islots" class))

(defun ichain-struct-tag (class chain-head)
  (format nil "~A__ichain_~A" class(sod-class-nickname chain-head)))

(defun ilayout-struct-tag (class)
  (format nil "~A__ilayout" class))

(defun vtmsgs-struct-tag (class super)
  (format nil "~A__vtmsgs_~A" class (sod-class-nickname super)))

(defun vtable-struct-tag (class chain-head)
  (format nil "~A__vt_~A" class (sod-class-nickname chain-head)))

(defun vtable-name (class chain-head)
  (format nil "~A__vtable_~A" class (sod-class-nickname chain-head)))

;;;--------------------------------------------------------------------------
;;; Hacks for now.

(defclass hacky-effective-method (effective-method)
  ((direct-methods :initarg :direct-methods)))

(defmethod print-object ((method hacky-effective-method) stream)
  (if *print-escape*
      (print-unreadable-object (method stream :type t)
	(format stream "~A ~_~A ~_~:<~@{~S~^ ~_~}~:>"
		(effective-method-message method)
		(effective-method-class method)
		(slot-value method 'direct-methods)))
      (call-next-method)))

(defmethod message-effective-method-class ((message sod-message))
  'hacky-effective-method)

(defmethod make-method-entry
    ((method hacky-effective-method) (chain-head sod-class))
  (make-instance 'method-entry
		 :method method
		 :chain-head chain-head))

;;;----- That's all, folks --------------------------------------------------