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