mdw@git.distorted.org.uk Git - sod/blob - src/method-impl.lisp

   1 ;;; -*-lisp-*-
   2 ;;;
   3 ;;; Method combination implementation
   4 ;;;
   5 ;;; (c) 2009 Straylight/Edgeware
   6 ;;;
   7
   8 ;;;----- Licensing notice ---------------------------------------------------
   9 ;;;
  10 ;;; This file is part of the Sensible Object Design, an object system for C.
  11 ;;;
  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.
  16 ;;;
  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.
  21 ;;;
  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.
  25
  26 (cl:in-package #:sod)
  27
  28 ;;;--------------------------------------------------------------------------
  29 ;;; Message classes.
  30
  31 (export 'basic-message)
  32 (defclass basic-message (sod-message)
  33   ((argument-tail :type list :reader sod-message-argument-tail)
  34    (no-varargs-tail :type list :reader sod-message-no-varargs-tail))
  35   (:documentation
  36    "Base class for built-in message classes.
  37
  38    Provides the basic functionality for the built-in method combinations.
  39    This is a separate class so that `special effect' messages can avoid
  40    inheriting its default behaviour.
  41
  42    The function type protocol is implemented on `basic-message' using slot
  43    reader methods.  The actual values are computed on demand."))
  44
  45 (define-on-demand-slot basic-message argument-tail (message)
  46   (let ((seq 0))
  47     (mapcar (lambda (arg)
  48               (if (or (eq arg :ellipsis) (argument-name arg)) arg
  49                   (make-argument (make-instance 'temporary-argument
  50                                                 :tag (prog1 seq
  51                                                        (incf seq)))
  52                                  (argument-type arg))))
  53             (c-function-arguments (sod-message-type message)))))
  54
  55 (define-on-demand-slot basic-message no-varargs-tail (message)
  56   (mapcar (lambda (arg)
  57             (if (eq arg :ellipsis)
  58                 (make-argument *sod-ap* c-type-va-list)
  59                 arg))
  60           (sod-message-argument-tail message)))
  61
  62 (defmethod sod-message-method-class
  63     ((message basic-message) (class sod-class) pset)
  64   (let ((role (get-property pset :role :keyword nil)))
  65     (case role
  66       ((:before :after) 'daemon-direct-method)
  67       (:around 'delegating-direct-method)
  68       ((nil) (error "How odd: a primary method slipped through the net"))
  69       (t (error "Unknown method role ~A" role)))))
  70
  71 (export 'simple-message)
  72 (defclass simple-message (basic-message)
  73   ()
  74   (:documentation
  75    "Base class for messages with `simple' method combinations.
  76
  77    A simple method combination is one which has only one method role other
  78    than the `before', `after' and `around' methods provided by
  79    `basic-message'.  We call these `primary' methods, and the programmer
  80    designates them by not specifying an explicit role.
  81
  82    If the programmer doesn't define any primary methods then the effective
  83    method is null -- i.e., the method entry pointer shows up as a null
  84    pointer."))
  85
  86 (defmethod sod-message-method-class
  87     ((message simple-message) (class sod-class) pset)
  88   (if (get-property pset :role :keyword nil)
  89       (call-next-method)
  90       (primary-method-class message)))
  91
  92 (defmethod primary-method-class ((message simple-message))
  93   'basic-direct-method)
  94
  95 ;;;--------------------------------------------------------------------------
  96 ;;; Direct method classes.
  97
  98 (export '(basic-direct-method sod-method-role))
  99 (defclass basic-direct-method (sod-method)
 100   ((role :initarg :role :type symbol :reader sod-method-role)
 101    (function-type :type c-function-type :reader sod-method-function-type))
 102   (:documentation
 103    "Base class for built-in direct method classes.
 104
 105    Provides the basic functionality for the built-in direct-method classes.
 106    This is a separate class so that `special effect' methods can avoid
 107    inheriting its default behaviour and slots.
 108
 109    A basic method can be assigned a `role', which may be set either as an
 110    initarg or using the `:role' property.  Roles are used for method
 111    categorization.
 112
 113    The function type protocol is implemented on `basic-direct-method' using
 114    slot reader methods."))
 115
 116 (defmethod shared-initialize :after
 117     ((method basic-direct-method) slot-names &key pset)
 118   (declare (ignore slot-names))
 119   (default-slot (method 'role) (get-property pset :role :keyword nil)))
 120
 121 (define-on-demand-slot basic-direct-method function-type (method)
 122   (let ((type (sod-method-type method)))
 123     (c-type (fun (lisp (c-type-subtype type))
 124                  ("me" (* (class (sod-method-class method))))
 125                  . (c-function-arguments type)))))
 126
 127 (defmethod sod-method-function-name ((method basic-direct-method))
 128   (with-slots ((class %class) role message) method
 129     (format nil "~A__~@[~(~A~)_~]method_~A__~A" class role
 130             (sod-class-nickname (sod-message-class message))
 131             (sod-message-name message))))
 132
 133 (export 'daemon-direct-method)
 134 (defclass daemon-direct-method (basic-direct-method)
 135   ()
 136   (:documentation
 137    "A daemon direct method is invoked for side effects and cannot override.
 138
 139    This is the direct method class for `before' and `after' methods, which
 140    cannot choose to override the remaining methods and are not involved in
 141    the computation of the final result.
 142
 143    In C terms, a daemon method must return `void', and is not passed a
 144    `next_method' pointer."))
 145
 146 (defmethod check-method-type ((method daemon-direct-method)
 147                               (message sod-message)
 148                               (type c-function-type))
 149   (with-slots ((msgtype %type)) message
 150     (unless (c-type-equal-p (c-type-subtype type) c-type-void)
 151       (error "Method return type ~A must be `void'" (c-type-subtype type)))
 152     (unless (argument-lists-compatible-p (c-function-arguments msgtype)
 153                                          (c-function-arguments type))
 154       (error "Method arguments ~A don't match message ~A" type msgtype))))
 155
 156 (export 'delegating-direct-method)
 157 (defclass delegating-direct-method (basic-direct-method)
 158   ((next-method-type :type c-function-type
 159                      :reader sod-method-next-method-type))
 160   (:documentation
 161    "A delegating direct method can choose to override other methods.
 162
 163    This is the direct method class for `around' and standard-method-
 164    combination primary methods, which are given the choice of computing the
 165    entire method's result or delegating to (usually) less-specific methods.
 166
 167    In C terms, a delegating method is passed a `next_method' pointer so that
 168    it can delegate part of its behaviour.  (A delegating direct method for a
 169    varargs message is also given an additional `va_list' argument,
 170    conventionally named `sod__ap_master', which it is expected to pass on to
 171    its `next_method' function if necessary.)
 172
 173    The function type protocol is implemented on `delegating-direct-method'
 174    using slot reader methods.."))
 175
 176 (define-on-demand-slot delegating-direct-method next-method-type (method)
 177   (let* ((message (sod-method-message method))
 178          (return-type (c-type-subtype (sod-message-type message)))
 179          (msgargs (sod-message-argument-tail message))
 180          (arguments (if (varargs-message-p message)
 181                         (cons (make-argument *sod-master-ap* c-type-va-list)
 182                               (butlast msgargs))
 183                         msgargs)))
 184     (c-type (fun (lisp return-type)
 185                  ("me" (* (class (sod-method-class method))))
 186                  . arguments))))
 187
 188 (define-on-demand-slot delegating-direct-method function-type (method)
 189   (let* ((message (sod-method-message method))
 190          (type (sod-method-type method))
 191          (method-args (c-function-arguments type)))
 192     (c-type (fun (lisp (c-type-subtype type))
 193                  ("me" (* (class (sod-method-class method))))
 194                  ("next_method" (* (lisp (commentify-function-type
 195                                           (sod-method-next-method-type
 196                                            method)))))
 197                  .
 198                  (if (varargs-message-p message)
 199                      (cons (make-argument *sod-master-ap* c-type-va-list)
 200                            method-args)
 201                      method-args)))))
 202
 203 ;;;--------------------------------------------------------------------------
 204 ;;; Effective method classes.
 205
 206 (export '(basic-effective-method
 207           effective-method-around-methods effective-method-before-methods
 208           effective-method-after-methods))
 209 (defclass basic-effective-method (effective-method)
 210   ((around-methods :initarg :around-methods :initform nil
 211                    :type list :reader effective-method-around-methods)
 212    (before-methods :initarg :before-methods :initform nil
 213                    :type list :reader effective-method-before-methods)
 214    (after-methods :initarg :after-methods :initform nil
 215                   :type list :reader effective-method-after-methods)
 216    (basic-argument-names :type list
 217                          :reader effective-method-basic-argument-names)
 218    (functions :type list :reader effective-method-functions))
 219   (:documentation
 220    "Base class for built-in effective method classes.
 221
 222    This class maintains lists of the applicable `before', `after' and
 223    `around' methods and provides behaviour for invoking these methods
 224    correctly.
 225
 226    The argument names protocol is implemented on `basic-effective-method'
 227    using a slot reader method."))
 228
 229 (define-on-demand-slot basic-effective-method basic-argument-names (method)
 230   (let ((message (effective-method-message method)))
 231     (mapcar #'argument-name
 232             (sod-message-no-varargs-tail message))))
 233
 234 (defmethod effective-method-function-name ((method effective-method))
 235   (let* ((class (effective-method-class method))
 236          (message (effective-method-message method))
 237          (message-class (sod-message-class message)))
 238     (format nil "~A__emethod_~A__~A"
 239             class
 240             (sod-class-nickname message-class)
 241             (sod-message-name message))))
 242
 243 (define-on-demand-slot basic-effective-method functions (method)
 244   (compute-method-entry-functions method))
 245
 246 (export 'simple-effective-method)
 247 (defclass simple-effective-method (basic-effective-method)
 248   ((primary-methods :initarg :primary-methods :initform nil
 249                     :type list :reader effective-method-primary-methods))
 250   (:documentation
 251    "Effective method counterpart to `simple-message'."))
 252
 253 (defmethod shared-initialize :after
 254     ((method simple-effective-method) slot-names &key direct-methods)
 255   (declare (ignore slot-names))
 256   (categorize (method direct-methods :bind ((role (sod-method-role method))))
 257       ((primary (null role))
 258        (before (eq role :before))
 259        (after (eq role :after))
 260        (around (eq role :around)))
 261     (with-slots (primary-methods before-methods after-methods around-methods)
 262         method
 263       (setf primary-methods primary
 264             before-methods before
 265             after-methods (reverse after)
 266             around-methods around))))
 267
 268 ;;;--------------------------------------------------------------------------
 269 ;;; Code generation.
 270
 271 (defmethod shared-initialize :after
 272     ((codegen method-codegen) slot-names &key)
 273   (declare (ignore slot-names))
 274   (with-slots (message target) codegen
 275     (setf target
 276           (if (eq (c-type-subtype (sod-message-type message)) c-type-void)
 277               :void
 278               :return))))
 279
 280 ;;;--------------------------------------------------------------------------
 281 ;;; Invoking direct methods.
 282
 283 (export 'basic-effective-method-body)
 284 (defun basic-effective-method-body (codegen target method body)
 285   "Build the common method-invocation structure.
 286
 287    Writes to CODEGEN some basic method-invocation instructions.  It invokes
 288    the `around' methods, from most- to least-specific.  If they all delegate,
 289    then the `before' methods are run, most-specific first; next, the
 290    instructions generated by BODY (invoked with a target argument); then, the
 291    `after' methods are run, least-specific first; and, finally, the value
 292    delivered by the BODY is returned to the `around' methods.  The result
 293    returned by the outermost `around' method -- or, if there are none,
 294    delivered by the BODY -- is finally delivered to the TARGET."
 295
 296   (with-slots (message (class %class)
 297                before-methods after-methods around-methods)
 298       method
 299     (let* ((message-type (sod-message-type message))
 300            (return-type (c-type-subtype message-type))
 301            (basic-tail (effective-method-basic-argument-names method)))
 302       (flet ((method-kernel (target)
 303                (dolist (before before-methods)
 304                  (invoke-method codegen :void basic-tail before))
 305                (if (null after-methods)
 306                    (funcall body target)
 307                    (convert-stmts codegen target return-type
 308                                   (lambda (target)
 309                                     (funcall body target)
 310                                     (dolist (after (reverse after-methods))
 311                                       (invoke-method codegen :void
 312                                                      basic-tail after)))))))
 313         (invoke-delegation-chain codegen target basic-tail
 314                                  around-methods #'method-kernel)))))
 315
 316 ;;;--------------------------------------------------------------------------
 317 ;;; Method entry points.
 318
 319 (defparameter *method-entry-inline-threshold* 200
 320   "Threshold below which effective method bodies are inlined into entries.
 321
 322    After the effective method body has been computed, we calculate its
 323    metric, multiply by the number of entries we need to generate, and compare
 324    it with this threshold.  If the metric is below the threshold then we
 325    fold the method body into the entry functions; otherwise we split the
 326    effective method out into its own function.")
 327
 328 (defmethod method-entry-function-name
 329     ((method effective-method) (chain-head sod-class) role)
 330   (let* ((class (effective-method-class method))
 331          (message (effective-method-message method))
 332          (message-class (sod-message-class message)))
 333     (if (or (not (slot-boundp method 'functions))
 334             (slot-value method 'functions))
 335         (format nil "~A__mentry~@[__~(~A~)~]_~A__~A__chain_~A"
 336                 class role
 337                 (sod-class-nickname message-class)
 338                 (sod-message-name message)
 339                 (sod-class-nickname chain-head))
 340         *null-pointer*)))
 341
 342 (defmethod method-entry-slot-name ((entry method-entry))
 343   (let* ((method (method-entry-effective-method entry))
 344          (message (effective-method-message method))
 345          (name (sod-message-name message))
 346          (role (method-entry-role entry)))
 347     (method-entry-slot-name-by-role entry role name)))
 348
 349 (defmethod method-entry-function-type ((entry method-entry))
 350   (let* ((method (method-entry-effective-method entry))
 351          (message (effective-method-message method))
 352          (type (sod-message-type message))
 353          (tail (ecase (method-entry-role entry)
 354                  ((nil) (sod-message-argument-tail message))
 355                  (:valist (sod-message-no-varargs-tail message)))))
 356     (c-type (fun (lisp (c-type-subtype type))
 357                  ("me" (* (class (method-entry-chain-tail entry))))
 358                  . tail))))
 359
 360 (defmethod make-method-entries ((method basic-effective-method)
 361                                 (chain-head sod-class)
 362                                 (chain-tail sod-class))
 363   (let ((entries nil)
 364         (message (effective-method-message method)))
 365     (flet ((make (role)
 366              (push (make-instance 'method-entry
 367                                   :method method :role role
 368                                   :chain-head chain-head
 369                                   :chain-tail chain-tail)
 370                    entries)))
 371       (when (varargs-message-p message) (make :valist))
 372       (make nil)
 373       entries)))
 374
 375 (defmethod compute-method-entry-functions ((method basic-effective-method))
 376
 377   ;; OK, there's quite a lot of this, so hold tight.
 378   ;;
 379   ;; The first thing we need to do is find all of the related objects.  This
 380   ;; is a bit verbose but fairly straightforward.
 381   ;;
 382   ;; Next, we generate the effective method body -- using `compute-effective-
 383   ;; method-body' of all things.  This gives us the declarations and body for
 384   ;; an effective method function, but we don't have an actual function yet.
 385   ;;
 386   ;; Now we look at the chains which are actually going to need a method
 387   ;; entry: only those chains whose tail (most specific) class is a
 388   ;; superclass of the class which defined the message need an entry.  We
 389   ;; build a list of these tail classes.
 390   ;;
 391   ;; Having done this, we decide whether it's better to generate a standalone
 392   ;; effective-method function and call it from each of the method entries,
 393   ;; or to inline the effective method body into each of the entries.
 394   ;;
 395   ;; Most of the complexity here comes from (a) dealing with the two
 396   ;; different strategies for constructing method entry functions and (b)
 397   ;; (unsurprisingly) the mess involved with dealing with varargs messages.
 398
 399   (let* ((message (effective-method-message method))
 400          (class (effective-method-class method))
 401          (message-class (sod-message-class message))
 402          (return-type (c-type-subtype (sod-message-type message)))
 403          (codegen (make-instance 'method-codegen
 404                                  :message message
 405                                  :class class
 406                                  :method method))
 407
 408          ;; Method entry details.
 409          (chain-tails (remove-if-not (lambda (super)
 410                                        (sod-subclass-p super message-class))
 411                                      (mapcar #'car
 412                                              (sod-class-chains class))))
 413          (n-entries (length chain-tails))
 414          (raw-entry-args (sod-message-argument-tail message))
 415          (entry-args (sod-message-no-varargs-tail message))
 416          (parm-n (let ((tail (last raw-entry-args 2)))
 417                    (and tail (eq (cadr tail) :ellipsis) (car tail))))
 418          (entry-target (codegen-target codegen))
 419
 420          ;; Effective method function details.
 421          (emf-name (effective-method-function-name method))
 422          (ilayout-type (c-type (* (struct (ilayout-struct-tag class)))))
 423          (emf-arg-tail (sod-message-no-varargs-tail message))
 424          (emf-type (c-type (fun (lisp return-type)
 425                                 ("sod__obj" (lisp ilayout-type))
 426                                 . emf-arg-tail))))
 427
 428     (flet ((setup-entry (tail)
 429              (let ((head (sod-class-chain-head tail)))
 430                (codegen-push codegen)
 431                (ensure-var codegen "sod__obj" ilayout-type
 432                            (make-convert-to-ilayout-inst class
 433                                                          head "me"))))
 434            (finish-entry (tail)
 435              (let* ((head (sod-class-chain-head tail))
 436                     (role (if parm-n :valist nil))
 437                     (name (method-entry-function-name method head role))
 438                     (type (c-type (fun (lisp return-type)
 439                                        ("me" (* (class tail)))
 440                                        . entry-args))))
 441                (codegen-pop-function codegen name type
 442                 "~@(~@[~A ~]entry~) function ~:_~
 443                  for method `~A.~A' ~:_~
 444                  via chain headed by `~A' ~:_~
 445                  defined on `~A'."
 446                 (if parm-n "Indirect argument-tail" nil)
 447                 (sod-class-nickname message-class)
 448                 (sod-message-name message)
 449                 head class)
 450
 451                ;; If this is a varargs method then we've made the
 452                ;; `:valist' role.  Also make the `nil' role.
 453                (when parm-n
 454                  (let ((call (apply #'make-call-inst name "me"
 455                                     (mapcar #'argument-name entry-args)))
 456                        (main (method-entry-function-name method head nil))
 457                        (main-type (c-type (fun (lisp return-type)
 458                                                ("me" (* (class tail)))
 459                                                . raw-entry-args))))
 460                    (codegen-push codegen)
 461                    (ensure-var codegen *sod-ap* c-type-va-list)
 462                    (convert-stmts codegen entry-target return-type
 463                                   (lambda (target)
 464                                     (deliver-call codegen :void "va_start"
 465                                                   *sod-ap* parm-n)
 466                                     (deliver-expr codegen target call)
 467                                     (deliver-call codegen :void "va_end"
 468                                                   *sod-ap*)))
 469                    (codegen-pop-function codegen main main-type
 470                     "Variable-length argument list ~:_~
 471                      entry function ~:_~
 472                      for method `~A.~A' ~:_~
 473                      via chain headed by `~A' ~:_~
 474                      defined on `~A'."
 475                 (sod-class-nickname message-class)
 476                 (sod-message-name message)
 477                 head class))))))
 478
 479       ;; Generate the method body.  We'll work out what to do with it later.
 480       (codegen-push codegen)
 481       (let* ((result (if (eq return-type c-type-void) nil
 482                          (temporary-var codegen return-type)))
 483              (emf-target (or result :void)))
 484         (compute-effective-method-body method codegen emf-target)
 485         (multiple-value-bind (vars insts) (codegen-pop codegen)
 486           (cond ((or (= n-entries 1)
 487                      (<= (* n-entries (reduce #'+ insts :key #'inst-metric))
 488                          *method-entry-inline-threshold*))
 489
 490                  ;; The effective method body is simple -- or there's only
 491                  ;; one of them.  We'll inline the method body into the entry
 492                  ;; functions.
 493                  (dolist (tail chain-tails)
 494                    (setup-entry tail)
 495                    (dolist (var vars)
 496                      (if (typep var 'var-inst)
 497                          (ensure-var codegen (inst-name var)
 498                                      (inst-type var) (inst-init var))
 499                          (emit-decl codegen var)))
 500                    (emit-insts codegen insts)
 501                    (deliver-expr codegen entry-target result)
 502                    (finish-entry tail)))
 503
 504                 (t
 505
 506                  ;; The effective method body is complicated and we'd need
 507                  ;; more than one copy.  We'll generate an effective method
 508                  ;; function and call it a lot.
 509                  (codegen-build-function codegen emf-name emf-type vars
 510                   (nconc insts (and result
 511                                     (list (make-return-inst result))))
 512                   "Effective method function ~:_for `~A.~A' ~:_~
 513                    defined on `~A'."
 514                   (sod-class-nickname message-class)
 515                   (sod-message-name message)
 516                   (effective-method-class method))
 517
 518                  (let ((call (apply #'make-call-inst emf-name "sod__obj"
 519                                     (mapcar #'argument-name emf-arg-tail))))
 520                    (dolist (tail chain-tails)
 521                      (setup-entry tail)
 522                      (deliver-expr codegen entry-target call)
 523                      (finish-entry tail)))))))
 524
 525       (codegen-functions codegen))))
 526
 527 (defmethod compute-method-entry-functions
 528     ((method simple-effective-method))
 529   (if (effective-method-primary-methods method)
 530       (call-next-method)
 531       nil))
 532
 533 (defmethod compute-effective-method-body
 534     ((method simple-effective-method) codegen target)
 535   (basic-effective-method-body codegen target method
 536                                (lambda (target)
 537                                  (simple-method-body method
 538                                                      codegen
 539                                                      target))))
 540
 541 ;;;--------------------------------------------------------------------------
 542 ;;; Standard method combination.
 543
 544 (export 'standard-message)
 545 (defclass standard-message (simple-message)
 546   ()
 547   (:documentation
 548    "Message class for standard method combinations.
 549
 550    Standard method combination is a simple method combination where the
 551    primary methods are invoked as a delegation chain, from most- to
 552    least-specific."))
 553
 554 (export 'standard-effective-method)
 555 (defclass standard-effective-method (simple-effective-method) ()
 556   (:documentation "Effective method counterpart to `standard-message'."))
 557
 558 (defmethod primary-method-class ((message standard-message))
 559   'delegating-direct-method)
 560
 561 (defmethod sod-message-effective-method-class ((message standard-message))
 562   'standard-effective-method)
 563
 564 (defmethod simple-method-body
 565     ((method standard-effective-method) codegen target)
 566   (invoke-delegation-chain codegen
 567                            target
 568                            (effective-method-basic-argument-names method)
 569                            (effective-method-primary-methods method)
 570                            nil))
 571
 572 ;;;----- That's all, folks --------------------------------------------------