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