3 ;;; Layout for instances and vtables
5 ;;; (c) 2009 Straylight/Edgeware
8 ;;;----- Licensing notice ---------------------------------------------------
10 ;;; This file is part of the Simple Object Definition system.
12 ;;; SOD is free software; you can redistribute it and/or modify
13 ;;; it under the terms of the GNU General Public License as published by
14 ;;; the Free Software Foundation; either version 2 of the License, or
15 ;;; (at your option) any later version.
17 ;;; SOD is distributed in the hope that it will be useful,
18 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20 ;;; GNU General Public License for more details.
22 ;;; You should have received a copy of the GNU General Public License
23 ;;; along with SOD; if not, write to the Free Software Foundation,
24 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
28 ;;;--------------------------------------------------------------------------
29 ;;; Effective slot objects.
31 (defclass effective-slot ()
32 ((class :initarg :class :type sod-slot :reader effective-slot-class)
33 (slot :initarg :slot :type sod-slot :reader effective-slot-direct-slot)
34 (initializer :initarg :initializer :type (or sod-initializer null)
35 :reader effective-slot-initializer))
37 "Describes a slot and how it's meant to be initialized.
39 Effective slot objects are usually attached to layouts."))
41 (defgeneric find-slot-initializer (class slot)
43 "Return the most specific initializer for SLOT, starting from CLASS."))
45 (defgeneric compute-effective-slot (class slot)
47 "Construct an effective slot from the supplied direct slot.
49 SLOT is a direct slot defined on CLASS or one of its superclasses.
50 (Metaclass initializers are handled using a different mechanism.)"))
52 (defmethod print-object ((slot effective-slot) stream)
53 (maybe-print-unreadable-object (slot stream :type t)
54 (format stream "~A~@[ = ~@_~A~]"
55 (effective-slot-direct-slot slot)
56 (effective-slot-initializer slot))))
58 (defmethod find-slot-initializer ((class sod-class) (slot sod-slot))
61 (sod-class-instance-initializers super)
62 :key #'sod-initializer-slot))
63 (sod-class-precedence-list class)))
65 (defmethod compute-effective-slot ((class sod-class) (slot sod-slot))
66 (make-instance 'effective-slot
69 :initializer (find-slot-initializer class slot)))
71 ;;;--------------------------------------------------------------------------
72 ;;; Instance layout objects.
77 ((class :initarg :class :type sod-class :reader islots-class)
78 (subclass :initarg :subclass :type sod-class :reader islots-subclass)
79 (slots :initarg :slots :type list :reader islots-slots))
81 "The collection of effective SLOTS defined by an instance of CLASS."))
83 (defmethod print-object ((islots islots) stream)
84 (print-unreadable-object (islots stream :type t)
85 (format stream "~A <= ~A ~_~:<~@{~S~^ ~_~}~:>"
86 (islots-subclass islots)
88 (islots-slots islots))))
90 (defgeneric compute-islots (class subclass)
92 "Return ISLOTS containing EFFECTIVE-SLOTs for a particular CLASS.
94 Initializers for the slots should be taken from the most specific
95 superclass of SUBCLASS."))
99 (defclass vtable-pointer ()
100 ((class :initarg :class :type sod-class :reader vtable-pointer-class)
101 (chain-head :initarg :chain-head :type sod-class
102 :reader vtable-pointer-chain-head)
103 (chain-tail :initarg :chain-tail :type sod-class
104 :reader vtable-pointer-chain-tail))
106 "A pointer to the vtable for CLASS corresponding to a particular CHAIN."))
108 (defmethod print-object ((vtp vtable-pointer) stream)
109 (print-unreadable-object (vtp stream :type t)
110 (format stream "~A:~A"
111 (vtable-pointer-class vtp)
112 (sod-class-nickname (vtable-pointer-chain-head vtp)))))
117 ((class :initarg :class :type sod-class :reader ichain-class)
118 (chain-head :initarg :chain-head :type sod-class :reader ichain-head)
119 (chain-tail :initarg :chain-tail :type sod-class :reader ichain-tail)
120 (body :initarg :body :type list :reader ichain-body))
122 "All of the instance layout for CLASS corresponding to a particular CHAIN.
124 The BODY is a list of things to include in the finished structure. By
125 default, it contains a VTABLE-POINTER and ISLOTS for each class in the
128 (defmethod print-object ((ichain ichain) stream)
129 (print-unreadable-object (ichain stream :type t)
130 (format stream "~A:~A ~_~:<~@{~S~^ ~_~}~:>"
131 (ichain-class ichain)
132 (sod-class-nickname (ichain-head ichain))
133 (ichain-body ichain))))
135 (defgeneric compute-ichain (class chain)
137 "Return an ICHAIN for a particular CHAIN of CLASS's superclasses.
139 The CHAIN is a list of classes, with the least specific first -- so the
140 chain head is the first element."))
145 ((class :initarg :class :type sod-class :reader ilayout-class)
146 (ichains :initarg :ichains :type list :reader ilayout-ichains))
148 "All of the instance layout for a CLASS.
150 Consists of an ICHAIN for each distinct chain."))
152 (defmethod print-object ((ilayout ilayout) stream)
153 (print-unreadable-object (ilayout stream :type t)
154 (format stream "~A ~_~:<~@{~S~^ ~_~}~:>"
155 (ilayout-class ilayout)
156 (ilayout-ichains ilayout))))
158 (defgeneric compute-ilayout (class)
160 "Compute and return an instance layout for CLASS."))
162 ;;; Standard implementation.
164 (defmethod compute-islots ((class sod-class) (subclass sod-class))
165 (make-instance 'islots
168 :slots (mapcar (lambda (slot)
169 (compute-effective-slot subclass slot))
170 (sod-class-slots class))))
172 (defmethod compute-ichain ((class sod-class) chain)
173 (let* ((chain-head (car chain))
174 (chain-tail (find chain-head (mapcar #'car (sod-class-chains class))
175 :key #'sod-class-chain-head))
176 (vtable-pointer (make-instance 'vtable-pointer
178 :chain-head chain-head
179 :chain-tail chain-tail))
180 (islots (remove-if-not #'islots-slots
181 (mapcar (lambda (super)
182 (compute-islots super class))
184 (make-instance 'ichain
186 :chain-head chain-head
187 :chain-tail chain-tail
188 :body (cons vtable-pointer islots))))
190 (defmethod compute-ilayout ((class sod-class))
191 (make-instance 'ilayout
193 :ichains (mapcar (lambda (chain)
194 (compute-ichain class
196 (sod-class-chains class))))
198 ;;;--------------------------------------------------------------------------
199 ;;; Effective methods.
201 (defclass effective-method ()
202 ((message :initarg :message :type sod-message
203 :reader effective-method-message)
204 (class :initarg :class :type sod-class :reader effective-method-class))
206 "The effective method invoked by sending MESSAGE to an instance of CLASS.
208 This is not a useful class by itself. Message classes are expected to
209 define their own effective-method classes.
211 An effective method class must accept a :DIRECT-METHODS initarg, which
212 will be a list of applicable methods sorted in most-to-least specific
215 (defmethod print-object ((method effective-method) stream)
216 (maybe-print-unreadable-object (method stream :type t)
217 (format stream "~A ~A"
218 (effective-method-message method)
219 (effective-method-class method))))
221 (defgeneric message-effective-method-class (message)
223 "Return the effective method class for the given MESSAGE."))
225 (defgeneric compute-sod-effective-method (message class)
227 "Return the effective method when a CLASS instance receives MESSAGE.
229 The default method constructs an instance of the message's chosen
230 MESSAGE-EFFECTIVE-METHOD-CLASS, passing the MESSAGE, the CLASS and the
231 list of applicable methods as initargs to MAKE-INSTANCE."))
233 (defmethod compute-sod-effective-method
234 ((message sod-message) (class sod-class))
235 (let ((direct-methods (mappend (lambda (super)
237 (sod-class-methods super)
238 :key #'sod-method-message
240 (sod-class-precedence-list class))))
241 (make-instance (message-effective-method-class message)
244 :direct-methods direct-methods)))
246 ;;;--------------------------------------------------------------------------
251 (defclass method-entry ()
252 ((method :initarg :method :type effective-method
253 :reader method-entry-effective-method)
254 (chain-head :initarg :chain-head :type sod-class
255 :reader method-entry-chain-head)
256 (chain-tail :initarg :chain-tail :type sod-class
257 :reader method-entry-chain-tail))
259 "An entry point into an effective method.
261 Calls to an effective method via different vtable chains will have their
262 `me' pointers pointing to different ichains within the instance layout.
263 Rather than (necessarily) duplicating the entire effective method for each
264 chain, we insert an entry veneer (the method entry) to fix up the pointer.
265 Exactly how it does this is up to the effective method -- and duplication
266 under some circumstances is probably a reasonable approach -- e.g., if the
267 effective method is just going to call a direct method immediately."))
269 (defmethod print-object ((entry method-entry) stream)
270 (maybe-print-unreadable-object (entry stream :type t)
271 (format stream "~A:~A"
272 (method-entry-effective-method entry)
273 (sod-class-nickname (method-entry-chain-head entry)))))
275 (defgeneric make-method-entry (effective-method chain-head chain-tail)
277 "Return a METHOD-ENTRY for an EFFECTIVE-METHOD called via CHAIN-HEAD.
279 There is no default method for this function. (Maybe when the
280 effective-method/method-entry output protocol has settled down I'll know
281 what a sensible default action would be.)"))
286 ((class :initarg :class :type sod-class :reader vtmsgs-class)
287 (subclass :initarg :subclass :type sod-class :reader vtmsgs-subclass)
288 (chain-head :initarg :chain-head :type sod-class
289 :reader vtmsgs-chain-head)
290 (chain-tail :initarg :chain-tail :type sod-class
291 :reader vtmsgs-chain-tail)
292 (entries :initarg :entries :type list :reader vtmsgs-entries))
294 "The message dispatch table for a particular CLASS.
296 The BODY contains a list of effective method entry objects for the
297 messages defined on CLASS, customized for calling from the chain headed by
300 (defmethod print-object ((vtmsgs vtmsgs) stream)
301 (print-unreadable-object (vtmsgs stream :type t)
302 (format stream "~A <= ~A ~_~:<~@{~S~^ ~_~}~:>"
303 (vtmsgs-subclass vtmsgs)
304 (vtmsgs-class vtmsgs)
305 (vtmsgs-entries vtmsgs))))
307 (defgeneric compute-vtmsgs (class subclass chain-head chain-tail)
309 "Return a VTMSGS object containing method entries for CLASS.
311 The CHAIN-HEAD describes which chain the method entries should be
314 The default method simply calls MAKE-METHOD-ENTRY for each of the methods
315 and wraps a VTMSGS object around them. This ought to be enough for almost
320 (defclass class-pointer ()
321 ((class :initarg :class :type sod-class :reader class-pointer-class)
322 (chain-head :initarg :chain-head :type sod-class
323 :reader class-pointer-chain-head)
324 (metaclass :initarg :metaclass :type sod-class
325 :reader class-pointer-metaclass)
326 (meta-chain-head :initarg :meta-chain-head :type sod-class
327 :reader class-pointer-meta-chain-head))
329 "Represents a pointer to a class object for the instance's class.
331 A class instance can have multiple chains. It may be useful to find any
332 of those chains from an instance of the class. Therefore the vtable
333 stores a pointer to each separate chain of the class instance."))
335 (defmethod print-object ((cptr class-pointer) stream)
336 (print-unreadable-object (cptr stream :type t)
337 (format stream "~A:~A"
338 (class-pointer-metaclass cptr)
339 (sod-class-nickname (class-pointer-meta-chain-head cptr)))))
341 (defgeneric make-class-pointer (class chain-head metaclass meta-chain-head)
343 "Return a class pointer to a metaclass chain."))
347 (defclass base-offset ()
348 ((class :initarg :class :type sod-class :reader base-offset-class)
349 (chain-head :initarg :chain-head :type sod-class
350 :reader base-offset-chain-head))
352 "The offset of this chain to the ilayout base.
354 There's only one of these per vtable."))
356 (defmethod print-object ((boff base-offset) stream)
357 (print-unreadable-object (boff stream :type t)
358 (format stream "~A:~A"
359 (base-offset-class boff)
360 (sod-class-nickname (base-offset-chain-head boff)))))
362 (defgeneric make-base-offset (class chain-head)
364 "Return the base offset object for CHAIN-HEAD ichain."))
368 (defclass chain-offset ()
369 ((class :initarg :class :type sod-class :reader chain-offset-class)
370 (chain-head :initarg :chain-head :type sod-class
371 :reader chain-offset-chain-head)
372 (target-head :initarg :target-head :type sod-class
373 :reader chain-offset-target-head))
375 "The offset from the CHAIN-HEAD ichain to the TARGET-HEAD ichain."))
377 (defmethod print-object ((choff chain-offset) stream)
378 (print-unreadable-object (choff stream :type t)
379 (format stream "~A:~A->~A"
380 (chain-offset-class choff)
381 (sod-class-nickname (chain-offset-chain-head choff))
382 (sod-class-nickname (chain-offset-target-head choff)))))
384 (defgeneric make-chain-offset (class chain-head target-head)
386 "Return the offset from CHAIN-HEAD to TARGET-HEAD."))
391 ((class :initarg :class :type sod-class :reader vtable-class)
392 (chain-head :initarg :chain-head :type sod-class
393 :reader vtable-chain-head)
394 (chain-tail :initarg :chain-tail :type sod-class
395 :reader vtable-chain-tail)
396 (body :initarg :body :type list :reader vtable-body))
398 "VTABLEs hold all of the per-chain static information for a class.
400 There is one vtable for each chain of each class. The vtables for a class
401 are prefixes of the corresponding chains of its subclasses.
403 Vtables contain method entry pointers, pointers to class objects, and
404 the offset information used for cross-chain slot access."))
406 (defmethod print-object ((vtable vtable) stream)
407 (print-unreadable-object (vtable stream :type t)
408 (format stream "~A:~A ~_~:<~@{~S~^ ~_~}~:>"
409 (vtable-class vtable)
410 (sod-class-nickname (vtable-chain-head vtable))
411 (vtable-body vtable))))
413 (defgeneric compute-vtable (class chain)
415 "Compute the vtable layout for a chain of CLASS.
417 The CHAIN is a list of classes, with the least specific first."))
419 (defgeneric compute-vtables (class)
421 "Compute the vtable layouts for CLASS.
423 Returns a list of VTABLE objects in the order of CLASS's chains."))
427 (defmethod compute-vtmsgs
430 (chain-head sod-class)
431 (chain-tail sod-class))
432 (flet ((make-entry (message)
433 (let ((method (find message
434 (sod-class-effective-methods subclass)
435 :key #'effective-method-message)))
436 (make-method-entry method chain-head chain-tail))))
437 (make-instance 'vtmsgs
440 :chain-head chain-head
441 :chain-tail chain-tail
442 :entries (mapcar #'make-entry
443 (sod-class-messages class)))))
445 (defmethod make-class-pointer
446 ((class sod-class) (chain-head sod-class)
447 (metaclass sod-class) (meta-chain-head sod-class))
449 ;; Slightly tricky. We don't necessarily want a pointer to the metaclass,
450 ;; but to its most specific subclass on the given chain. Fortunately, CL
451 ;; is good at this game.
452 (let* ((meta-chains (sod-class-chains metaclass))
453 (meta-chain-tails (mapcar #'car meta-chains))
454 (meta-chain-tail (find meta-chain-head meta-chain-tails
455 :key #'sod-class-chain-head)))
456 (make-instance 'class-pointer
458 :chain-head chain-head
459 :metaclass meta-chain-tail
460 :meta-chain-head meta-chain-head)))
462 (defmethod make-base-offset ((class sod-class) (chain-head sod-class))
463 (make-instance 'base-offset
465 :chain-head chain-head))
467 (defmethod make-chain-offset
468 ((class sod-class) (chain-head sod-class) (target-head sod-class))
469 (make-instance 'chain-offset
471 :chain-head chain-head
472 :target-head target-head))
474 ;; Special variables used by COMPUTE-VTABLE.
475 (defvar *done-metaclass-chains*)
476 (defvar *done-instance-chains*)
478 (defgeneric compute-vtable-items (class super chain-head chain-tail emit)
480 "Emit vtable items for a superclass of CLASS.
482 This function is called for each superclass SUPER of CLASS reached on the
483 chain headed by CHAIN-HEAD. The function should call EMIT for each
484 vtable item it wants to write.
486 The right way to check to see whether items have already been emitted
487 (e.g., has an offset to some other chain been emitted?) is as follows:
489 * In a method on COMPUTE-VTABLE, bind a special variable to an empty
492 * In a method on this function, check the variable or hash table.
494 This function is the real business end of COMPUTE-VTABLE."))
496 (defmethod compute-vtable-items
497 ((class sod-class) (super sod-class) (chain-head sod-class)
498 (chain-tail sod-class) (emit function))
500 ;; If this class introduces new metaclass chains, then emit pointers to
502 (let* ((metasuper (sod-class-metaclass super))
503 (metasuper-chains (sod-class-chains metasuper))
504 (metasuper-chain-heads (mapcar (lambda (chain)
505 (sod-class-chain-head (car chain)))
507 (dolist (metasuper-chain-head metasuper-chain-heads)
508 (unless (member metasuper-chain-head *done-metaclass-chains*)
509 (funcall emit (make-class-pointer class
512 metasuper-chain-head))
513 (push metasuper-chain-head *done-metaclass-chains*))))
515 ;; If there are new instance chains, then emit offsets to them.
516 (let* ((chains (sod-class-chains super))
517 (chain-heads (mapcar (lambda (chain)
518 (sod-class-chain-head (car chain)))
520 (dolist (head chain-heads)
521 (unless (member head *done-instance-chains*)
522 (funcall emit (make-chain-offset class chain-head head))
523 (push head *done-instance-chains*))))
525 ;; Finally, if there are interesting methods, emit those too.
526 (when (sod-class-messages super)
527 (funcall emit (compute-vtmsgs super class chain-head chain-tail))))
529 (defun find-root-superclass (class)
530 "Returns the `root' superclass of CLASS.
532 The root superclass is the superclass which itself has no direct
533 superclasses. In universes not based on the provided builtin module, the
534 root class may not be our beloved SodObject; however, there must be one
535 (otherwise the class graph is cyclic, which should be forbidden), and we
536 instist that it be unique."
538 ;; The root superclass must be a chain head since the chains partition the
539 ;; superclasses; the root has no superclasses so it can't have a link and
540 ;; must therefore be a head. This narrows the field down quite a lot.
542 ;; Note! This function gets called from CHECK-SOD-CLASS before the class's
543 ;; chains have been computed. Therefore we iterate over the direct
544 ;; superclass's chains rather than the class's own. This misses a chain
545 ;; only in the case where the class is its own chain head. There are two
546 ;; subcases: if there are no direct superclasses at all, then the class is
547 ;; its own root; otherwise, it clearly can't be the root and the omission
549 (let* ((supers (sod-class-direct-superclasses class))
552 (remove-if #'sod-class-direct-superclasses
553 (mappend (lambda (super)
554 (mapcar (lambda (chain)
555 (sod-class-chain-head
557 (sod-class-chains super)))
560 (cond ((null roots) (error "Class ~A has no root class!" class))
561 ((cdr roots) (error "Class ~A has multiple root classes ~
562 ~{~A~#[~; and ~;, ~]~}"
566 (defun find-root-metaclass (class)
567 "Returns the `root' metaclass of CLASS.
569 The root metaclass is the metaclass of the root superclass -- see
570 FIND-ROOT-SUPERCLASS."
571 (sod-class-metaclass (find-root-superclass class)))
573 (defmethod compute-vtable ((class sod-class) (chain list))
574 (let* ((chain-head (car chain))
575 (chain-tail (find chain-head (mapcar #'car (sod-class-chains class))
576 :key #'sod-class-chain-head))
577 (*done-metaclass-chains* nil)
578 (*done-instance-chains* (list chain-head))
579 (done-superclasses nil)
584 ;; Find the root chain in the metaclass and write a pointer.
585 (let* ((metaclass (sod-class-metaclass class))
586 (metaclass-root (find-root-metaclass class))
587 (metaclass-root-head (sod-class-chain-head metaclass-root)))
588 (emit (make-class-pointer class chain-head metaclass
589 metaclass-root-head))
590 (push metaclass-root-head *done-metaclass-chains*))
592 ;; Write an offset to the instance base.
593 (emit (make-base-offset class chain-head))
595 ;; Now walk the chain. As we ascend the chain, scan the class
596 ;; precedence list of each class in reverse to ensure that we have
597 ;; everything interesting.
598 (dolist (super chain)
599 (dolist (sub (reverse (sod-class-precedence-list super)))
600 (unless (member sub done-superclasses)
601 (compute-vtable-items class
606 (push sub done-superclasses))))
609 (make-instance 'vtable
611 :chain-head chain-head
612 :chain-tail chain-tail
613 :body (nreverse items)))))
615 (defgeneric compute-effective-methods (class)
617 "Return a list of all of the effective methods needed for CLASS.
619 The list needn't be in any particular order."))
621 (defmethod compute-effective-methods ((class sod-class))
622 (mapcan (lambda (super)
623 (mapcar (lambda (message)
624 (compute-sod-effective-method message class))
625 (sod-class-messages super)))
626 (sod-class-precedence-list class)))
628 (defmethod compute-vtables ((class sod-class))
629 (mapcar (lambda (chain)
630 (compute-vtable class (reverse chain)))
631 (sod-class-chains class)))
633 ;;;--------------------------------------------------------------------------
636 (defun islots-struct-tag (class)
637 (format nil "~A__islots" class))
639 (defun ichain-struct-tag (class chain-head)
640 (format nil "~A__ichain_~A" class (sod-class-nickname chain-head)))
642 (defun ichain-union-tag (class chain-head)
643 (format nil "~A__ichainu_~A" class (sod-class-nickname chain-head)))
645 (defun ilayout-struct-tag (class)
646 (format nil "~A__ilayout" class))
648 (defun vtmsgs-struct-tag (class super)
649 (format nil "~A__vtmsgs_~A" class (sod-class-nickname super)))
651 (defun vtable-struct-tag (class chain-head)
652 (format nil "~A__vt_~A" class (sod-class-nickname chain-head)))
654 (defun vtable-name (class chain-head)
655 (format nil "~A__vtable_~A" class (sod-class-nickname chain-head)))
657 ;;;----- That's all, folks --------------------------------------------------