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