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   (:documentation
  35    "Base class for built-in message classes.
  36
  37    Provides the basic functionality for the built-in method combinations.
  38    This is a separate class so that `special effect' messages can avoid
  39    inheriting its default behaviour.
  40
  41    The function type protocol is implemented on `basic-message' using slot
  42    reader methods.  The actual values are computed on demand."))
  43
  44 (define-on-demand-slot basic-message argument-tail (message)
  45   (let ((seq 0))
  46     (mapcar (lambda (arg)
  47               (if (or (eq arg :ellipsis) (argument-name arg)) arg
  48                   (make-argument (make-instance 'temporary-argument
  49                                                 :tag (prog1 seq
  50                                                        (incf seq)))
  51                                  (argument-type arg))))
  52             (c-function-arguments (sod-message-type message)))))
  53
  54 (defmethod sod-message-method-class
  55     ((message basic-message) (class sod-class) pset)
  56   (let ((role (get-property pset :role :keyword nil)))
  57     (case role
  58       ((:before :after) 'daemon-direct-method)
  59       (:around 'delegating-direct-method)
  60       ((nil) (error "How odd: a primary method slipped through the net"))
  61       (t (error "Unknown method role ~A" role)))))
  62
  63 (export 'simple-message)
  64 (defclass simple-message (basic-message)
  65   ()
  66   (:documentation
  67    "Base class for messages with `simple' method combinations.
  68
  69    A simple method combination is one which has only one method role other
  70    than the `before', `after' and `around' methods provided by
  71    `basic-message'.  We call these `primary' methods, and the programmer
  72    designates them by not specifying an explicit role.
  73
  74    If the programmer doesn't define any primary methods then the effective
  75    method is null -- i.e., the method entry pointer shows up as a null
  76    pointer."))
  77
  78 (defmethod sod-message-method-class
  79     ((message simple-message) (class sod-class) pset)
  80   (if (get-property pset :role :keyword nil)
  81       (call-next-method)
  82       (primary-method-class message)))
  83
  84 (defmethod primary-method-class ((message simple-message))
  85   'basic-direct-method)
  86
  87 ;;;--------------------------------------------------------------------------
  88 ;;; Direct method classes.
  89
  90 (export '(basic-direct-method sod-method-role))
  91 (defclass basic-direct-method (sod-method)
  92   ((role :initarg :role :type symbol :reader sod-method-role)
  93    (function-type :type c-function-type :reader sod-method-function-type))
  94   (:documentation
  95    "Base class for built-in direct method classes.
  96
  97    Provides the basic functionality for the built-in direct-method classes.
  98    This is a separate class so that `special effect' methods can avoid
  99    inheriting its default behaviour and slots.
 100
 101    A basic method can be assigned a `role', which may be set either as an
 102    initarg or using the `:role' property.  Roles are used for method
 103    categorization.
 104
 105    The function type protocol is implemented on `basic-direct-method' using
 106    slot reader methods."))
 107
 108 (defmethod shared-initialize :after
 109     ((method basic-direct-method) slot-names &key pset)
 110   (declare (ignore slot-names))
 111   (default-slot (method 'role) (get-property pset :role :keyword nil)))
 112
 113 (defun direct-method-suppliedp-struct-tag (direct-method)
 114   (with-slots ((class %class) role message) direct-method
 115     (format nil "~A__~@[~(~A~)_~]suppliedp_~A__~A"
 116             class role
 117             (sod-class-nickname (sod-message-class message))
 118             (sod-message-name message))))
 119
 120 (defun effective-method-keyword-struct-tag (effective-method)
 121   (with-slots ((class %class) message) effective-method
 122     (format nil "~A__keywords_~A__~A"
 123             class
 124             (sod-class-nickname (sod-message-class message))
 125             (sod-message-name message))))
 126
 127 (defun fix-up-keyword-method-args (method args)
 128   "Adjust the ARGS to include METHOD's `suppliedp' and keyword arguments.
 129
 130    Return the adjusted list.  The `suppliedp' argument, if any, is prepended
 131    to the list; the keyword arguments are added to the end.
 132
 133    (The input ARGS list is not actually modified.)"
 134   (let* ((type (sod-method-type method))
 135          (keys (c-function-keywords type))
 136          (tag (direct-method-suppliedp-struct-tag method)))
 137     (append (and keys
 138                  (list (make-argument "suppliedp" (c-type (struct tag)))))
 139             args
 140             (mapcar (lambda (key)
 141                       (make-argument (argument-name key)
 142                                      (argument-type key)))
 143                     keys))))
 144
 145 (define-on-demand-slot basic-direct-method function-type (method)
 146   (let* ((message (sod-method-message method))
 147          (type (sod-method-type method))
 148          (method-args (c-function-arguments type)))
 149     (when (keyword-message-p message)
 150       (setf method-args (fix-up-keyword-method-args method method-args)))
 151     (c-type (fun (lisp (c-type-subtype type))
 152                  ("me" (* (class (sod-method-class method))))
 153                  . method-args))))
 154
 155 (defmethod sod-method-function-name ((method basic-direct-method))
 156   (with-slots ((class %class) role message) method
 157     (format nil "~A__~@[~(~A~)_~]method_~A__~A" class role
 158             (sod-class-nickname (sod-message-class message))
 159             (sod-message-name message))))
 160
 161 (export 'daemon-direct-method)
 162 (defclass daemon-direct-method (basic-direct-method)
 163   ()
 164   (:documentation
 165    "A daemon direct method is invoked for side effects and cannot override.
 166
 167    This is the direct method class for `before' and `after' methods, which
 168    cannot choose to override the remaining methods and are not involved in
 169    the computation of the final result.
 170
 171    In C terms, a daemon method must return `void', and is not passed a
 172    `next_method' pointer."))
 173
 174 (defmethod check-method-type ((method daemon-direct-method)
 175                               (message sod-message)
 176                               (type c-function-type))
 177   (with-slots ((msgtype %type)) message
 178     (check-method-return-type type c-type-void)
 179     (check-method-argument-lists type msgtype)))
 180
 181 (export 'delegating-direct-method)
 182 (defclass delegating-direct-method (basic-direct-method)
 183   ((next-method-type :type c-function-type
 184                      :reader sod-method-next-method-type))
 185   (:documentation
 186    "A delegating direct method can choose to override other methods.
 187
 188    This is the direct method class for `around' and standard-method-
 189    combination primary methods, which are given the choice of computing the
 190    entire method's result or delegating to (usually) less-specific methods.
 191
 192    In C terms, a delegating method is passed a `next_method' pointer so that
 193    it can delegate part of its behaviour.  (A delegating direct method for a
 194    varargs message is also given an additional `va_list' argument,
 195    conventionally named `sod__ap_master', which it is expected to pass on to
 196    its `next_method' function if necessary.)
 197
 198    The function type protocol is implemented on `delegating-direct-method'
 199    using slot reader methods.."))
 200
 201 (define-on-demand-slot delegating-direct-method next-method-type (method)
 202   (let* ((message (sod-method-message method))
 203          (return-type (c-type-subtype (sod-message-type message)))
 204          (msgargs (sod-message-argument-tail message))
 205          (arguments (cond ((varargs-message-p message)
 206                            (cons (make-argument *sod-master-ap*
 207                                                 c-type-va-list)
 208                                  (butlast msgargs)))
 209                           ((keyword-message-p message)
 210                            (cons (make-argument *sod-keywords*
 211                                                 (c-type (* (void :const))))
 212                                  msgargs))
 213                           (t
 214                            msgargs))))
 215     (c-type (fun (lisp return-type)
 216                  ("me" (* (class (sod-method-class method))))
 217                  . arguments))))
 218
 219 (define-on-demand-slot delegating-direct-method function-type (method)
 220   (let* ((message (sod-method-message method))
 221          (type (sod-method-type method))
 222          (method-args (c-function-arguments type))
 223          (next-method-arg (make-argument
 224                            "next_method"
 225                            (make-pointer-type
 226                             (commentify-function-type
 227                              (sod-method-next-method-type method))))))
 228     (cond ((varargs-message-p message)
 229            (push (make-argument *sod-master-ap* c-type-va-list)
 230                  method-args)
 231            (push next-method-arg method-args))
 232           ((keyword-message-p message)
 233            (push (make-argument *sod-keywords* (c-type (* (void :const))))
 234                  method-args)
 235            (push next-method-arg method-args)
 236            (setf method-args
 237                  (fix-up-keyword-method-args method method-args)))
 238           (t
 239            (push next-method-arg method-args)))
 240     (c-type (fun (lisp (c-type-subtype type))
 241                  ("me" (* (class (sod-method-class method))))
 242                  . method-args))))
 243
 244 ;;;--------------------------------------------------------------------------
 245 ;;; Effective method classes.
 246
 247 (defmethod shared-initialize :after
 248     ((method effective-method) slot-names &key direct-methods)
 249   (declare (ignore slot-names))
 250
 251   ;; Set the keyword argument list.
 252   (with-slots (message keywords) method
 253     (setf keywords (and (keyword-message-p message)
 254                         (merge-keyword-lists
 255                          (mapcar (lambda (m)
 256                                    (let ((type (sod-method-type m)))
 257                                      (cons (c-function-keywords type)
 258                                            (format nil "method for ~A on ~A"
 259                                                    message
 260                                                    (sod-method-class m)))))
 261                                  direct-methods))))))
 262
 263 (export '(basic-effective-method
 264           effective-method-around-methods effective-method-before-methods
 265           effective-method-after-methods))
 266 (defclass basic-effective-method (effective-method)
 267   ((around-methods :initarg :around-methods :initform nil
 268                    :type list :reader effective-method-around-methods)
 269    (before-methods :initarg :before-methods :initform nil
 270                    :type list :reader effective-method-before-methods)
 271    (after-methods :initarg :after-methods :initform nil
 272                   :type list :reader effective-method-after-methods)
 273    (basic-argument-names :type list
 274                          :reader effective-method-basic-argument-names)
 275    (functions :type list :reader effective-method-functions))
 276   (:documentation
 277    "Base class for built-in effective method classes.
 278
 279    This class maintains lists of the applicable `before', `after' and
 280    `around' methods and provides behaviour for invoking these methods
 281    correctly.
 282
 283    The argument names protocol is implemented on `basic-effective-method'
 284    using a slot reader method."))
 285
 286 (define-on-demand-slot basic-effective-method basic-argument-names (method)
 287   (let* ((message (effective-method-message method))
 288          (raw-tail (sod-message-argument-tail message)))
 289     (mapcar #'argument-name (reify-variable-argument-tail raw-tail))))
 290
 291 (defmethod effective-method-function-name ((method effective-method))
 292   (let* ((class (effective-method-class method))
 293          (message (effective-method-message method))
 294          (message-class (sod-message-class message)))
 295     (format nil "~A__emethod_~A__~A"
 296             class
 297             (sod-class-nickname message-class)
 298             (sod-message-name message))))
 299
 300 (define-on-demand-slot basic-effective-method functions (method)
 301   (compute-method-entry-functions method))
 302
 303 (export 'simple-effective-method)
 304 (defclass simple-effective-method (basic-effective-method)
 305   ((primary-methods :initarg :primary-methods :initform nil
 306                     :type list :reader effective-method-primary-methods))
 307   (:documentation
 308    "Effective method counterpart to `simple-message'."))
 309
 310 (defmethod shared-initialize :after
 311     ((method simple-effective-method) slot-names &key direct-methods)
 312   (declare (ignore slot-names))
 313   (categorize (method direct-methods :bind ((role (sod-method-role method))))
 314       ((primary (null role))
 315        (before (eq role :before))
 316        (after (eq role :after))
 317        (around (eq role :around)))
 318     (with-slots (primary-methods before-methods after-methods around-methods)
 319         method
 320       (setf primary-methods primary
 321             before-methods before
 322             after-methods (reverse after)
 323             around-methods around))))
 324
 325 ;;;--------------------------------------------------------------------------
 326 ;;; Code generation.
 327
 328 (defmethod shared-initialize :after
 329     ((codegen method-codegen) slot-names &key)
 330   (declare (ignore slot-names))
 331   (with-slots (message target) codegen
 332     (setf target
 333           (if (eq (c-type-subtype (sod-message-type message)) c-type-void)
 334               :void
 335               :return))))
 336
 337 ;;;--------------------------------------------------------------------------
 338 ;;; Invoking direct methods.
 339
 340 (export 'basic-effective-method-body)
 341 (defun basic-effective-method-body (codegen target method body)
 342   "Build the common method-invocation structure.
 343
 344    Writes to CODEGEN some basic method-invocation instructions.  It invokes
 345    the `around' methods, from most- to least-specific.  If they all delegate,
 346    then the `before' methods are run, most-specific first; next, the
 347    instructions generated by BODY (invoked with a target argument); then, the
 348    `after' methods are run, least-specific first; and, finally, the value
 349    delivered by the BODY is returned to the `around' methods.  The result
 350    returned by the outermost `around' method -- or, if there are none,
 351    delivered by the BODY -- is finally delivered to the TARGET."
 352
 353   (with-slots (message (class %class)
 354                before-methods after-methods around-methods)
 355       method
 356     (let* ((message-type (sod-message-type message))
 357            (return-type (c-type-subtype message-type))
 358            (basic-tail (effective-method-basic-argument-names method)))
 359       (flet ((method-kernel (target)
 360                (dolist (before before-methods)
 361                  (invoke-method codegen :void basic-tail before))
 362                (if (null after-methods)
 363                    (funcall body target)
 364                    (convert-stmts codegen target return-type
 365                                   (lambda (target)
 366                                     (funcall body target)
 367                                     (dolist (after (reverse after-methods))
 368                                       (invoke-method codegen :void
 369                                                      basic-tail after)))))))
 370         (invoke-delegation-chain codegen target basic-tail
 371                                  around-methods #'method-kernel)))))
 372
 373 ;;;--------------------------------------------------------------------------
 374 ;;; Method entry points.
 375
 376 (defparameter *method-entry-inline-threshold* 200
 377   "Threshold below which effective method bodies are inlined into entries.
 378
 379    After the effective method body has been computed, we calculate its
 380    metric, multiply by the number of entries we need to generate, and compare
 381    it with this threshold.  If the metric is below the threshold then we
 382    fold the method body into the entry functions; otherwise we split the
 383    effective method out into its own function.")
 384
 385 (defmethod method-entry-function-name
 386     ((method effective-method) (chain-head sod-class) role)
 387   (let* ((class (effective-method-class method))
 388          (message (effective-method-message method))
 389          (message-class (sod-message-class message)))
 390     (if (or (not (slot-boundp method 'functions))
 391             (slot-value method 'functions))
 392         (format nil "~A__mentry~@[__~(~A~)~]_~A__~A__chain_~A"
 393                 class role
 394                 (sod-class-nickname message-class)
 395                 (sod-message-name message)
 396                 (sod-class-nickname chain-head))
 397         *null-pointer*)))
 398
 399 (defmethod method-entry-slot-name ((entry method-entry))
 400   (let* ((method (method-entry-effective-method entry))
 401          (message (effective-method-message method))
 402          (name (sod-message-name message))
 403          (role (method-entry-role entry)))
 404     (method-entry-slot-name-by-role entry role name)))
 405
 406 (defmethod method-entry-function-type ((entry method-entry))
 407   (let* ((method (method-entry-effective-method entry))
 408          (message (effective-method-message method))
 409          (type (sod-message-type message))
 410          (keywordsp (keyword-message-p message))
 411          (raw-tail (append (sod-message-argument-tail message)
 412                            (and keywordsp (list :ellipsis))))
 413          (tail (ecase (method-entry-role entry)
 414                  ((nil) raw-tail)
 415                  (:valist (reify-variable-argument-tail raw-tail)))))
 416     (c-type (fun (lisp (c-type-subtype type))
 417                  ("me" (* (class (method-entry-chain-tail entry))))
 418                  . tail))))
 419
 420 (defgeneric effective-method-keyword-parser-function-name (method)
 421   (:documentation
 422    "Return the name of the keyword-parsing function for an effective METHOD.
 423
 424    See `make-keyword-parser-function' for details of what this function
 425    actually does."))
 426
 427 (defmethod effective-method-keyword-parser-function-name
 428     ((method basic-effective-method))
 429   (with-slots ((class %class) message) method
 430     (format nil "~A__kwparse_~A__~A"
 431             class
 432             (sod-class-nickname (sod-message-class message))
 433             (sod-message-name message))))
 434
 435 (defun make-keyword-parser-function (codegen method tag set keywords)
 436   "Construct and return a keyword-argument parsing function.
 437
 438    The function is contributed to the CODEGEN, with the name constructed from
 439    the effective METHOD.  It will populate an argument structure with the
 440    given TAG.  In case of error, it will mention the name SET in its report.
 441    The KEYWORDS are a list of `argument' objects naming the keywords to be
 442    accepted.
 443
 444    The generated function has the signature
 445
 446         void NAME(struct TAG *kw, va_list *ap, struct kwval *v, size_t n)
 447
 448     It assumes that AP includes the first keyword name.  (This makes it
 449     different from the keyword-parsing functions generated by the
 450     `KWSET_PARSEFN' macro, but this interface is slightly more convenient and
 451     we don't need to cope with functions which accept no required
 452     arguments.)"
 453
 454   ;; Let's start, then.
 455   (codegen-push codegen)
 456
 457   ;; Set up the local variables we'll need.
 458   (macrolet ((var (name type)
 459                `(ensure-var codegen ,name (c-type ,type))))
 460     (var "k" const-string)
 461     (var "aap" (* va-list))
 462     (var "t" (* (struct "kwtab" :const)))
 463     (var "vv" (* (struct "kwval" :const)))
 464     (var "nn" size-t))
 465
 466   (flet ((call (target func &rest args)
 467            ;; Call FUNC with ARGS; return result in TARGET.
 468
 469            (apply #'deliver-call codegen target func args))
 470
 471          (convert (target type)
 472            ;; Fetch the object of TYPE pointed to by `v->val', and store it
 473            ;; in TARGET.
 474
 475            (deliver-expr codegen target
 476                          (format nil "*(~A)v->val"
 477                                  (make-pointer-type (qualify-c-type
 478                                                      type (list :const))))))
 479
 480          (namecheck (var name conseq alt)
 481            ;; Return an instruction: if VAR matches the string NAME then do
 482            ;; CONSEQ; otherwise do ALT.
 483
 484            (make-if-inst (make-call-inst "!strcmp"
 485                                          var (prin1-to-string name))
 486                          conseq alt)))
 487
 488     ;; Prepare the main parsing loops.  We're going to construct them both at
 489     ;; the same time.  They're not quite similar enough for it to be
 490     ;; worthwhile abstracting this further, but carving up the keywords is
 491     ;; too tedious to write out more than once.
 492     (let ((va-act (make-expr-inst (make-call-inst "kw_unknown" set "k")))
 493           (tab-act (make-expr-inst (make-call-inst "kw_unknown"
 494                                                    set "v->kw")))
 495           (name (effective-method-keyword-parser-function-name method)))
 496
 497       ;; Work through the keywords.  We're going to be building up the
 498       ;; conditional dispatch from the end, so reverse the (nicely sorted)
 499       ;; list before processing it.
 500       (dolist (key (reverse keywords))
 501         (let* ((key-name (argument-name key))
 502                (key-type (argument-type key)))
 503
 504           ;; Handle the varargs case.
 505           (codegen-push codegen)
 506           (deliver-expr codegen (format nil "kw->~A__suppliedp" key-name) 1)
 507           (call (format nil "kw->~A" key-name) "va_arg" "*ap" key-type)
 508           (setf va-act (namecheck "k" key-name
 509                                   (codegen-pop-block codegen) va-act))
 510
 511           ;; Handle the table case.
 512           (codegen-push codegen)
 513           (deliver-expr codegen (format nil "kw->~A__suppliedp" key-name) 1)
 514           (convert (format nil "kw->~A" key-name) key-type)
 515           (setf tab-act (namecheck "v->kw" key-name
 516                                    (codegen-pop-block codegen) tab-act))))
 517
 518       ;; Deal with the special `kw.' keywords read via varargs.
 519       (codegen-push codegen)
 520       (call "vv" "va_arg" "*ap" (c-type (* (struct "kwval" :const))))
 521       (call "nn" "va_arg" "*ap" c-type-size-t)
 522       (call :void name "kw" *null-pointer* "vv" "nn")
 523       (setf va-act (namecheck "k" "kw.tab"
 524                               (codegen-pop-block codegen) va-act))
 525
 526       (codegen-push codegen)
 527       (call "aap" "va_arg" "*ap" (c-type (* va-list)))
 528       (call :void name "kw" "aap" *null-pointer* 0)
 529       (setf va-act (namecheck "k" "kw.va_list"
 530                               (codegen-pop-block codegen) va-act))
 531
 532       ;; Finish up the varargs loop.
 533       (emit-banner codegen "Parse keywords from the variable-length tail.")
 534       (codegen-push codegen)
 535       (call "k" "va_arg" "*ap" c-type-const-string)
 536       (emit-inst codegen (make-if-inst "!k" (make-break-inst)))
 537       (emit-inst codegen va-act)
 538       (let ((loop (make-for-inst nil nil nil (codegen-pop-block codegen))))
 539         (emit-inst codegen
 540                    (make-if-inst "ap" (make-block-inst nil (list loop)))))
 541
 542       ;; Deal with the special `kw.' keywords read from a table.
 543       (codegen-push codegen)
 544       (deliver-expr codegen "t"
 545                     (format nil "(~A)v->val"
 546                             (c-type (* (struct "kwtab" :const)))))
 547       (call :void name "kw" *null-pointer* "t->v" "t->n")
 548       (setf tab-act (namecheck "v->kw" "kw.tab"
 549                                (codegen-pop-block codegen) tab-act))
 550
 551       (emit-banner codegen "Parse keywords from the argument table.")
 552       (codegen-push codegen)
 553       (convert "aap" (c-type (* va-list)))
 554       (call :void name "kw" "aap" *null-pointer* 0)
 555       (setf tab-act (namecheck "v->kw" "kw.va_list"
 556                                (codegen-pop-block codegen) tab-act))
 557
 558       ;; Finish off the table loop.
 559       (codegen-push codegen)
 560       (emit-inst codegen tab-act)
 561       (emit-inst codegen (make-expr-inst "v++"))
 562       (emit-inst codegen (make-expr-inst "n--"))
 563       (emit-inst codegen (make-while-inst "n" (codegen-pop-block codegen)))
 564
 565       ;; Wrap the whole lot up with a nice bow.
 566       (let ((message (effective-method-message method)))
 567         (codegen-pop-function codegen name
 568                               (c-type (fun void
 569                                            ("kw" (* (struct tag)))
 570                                            ("ap" (* va-list))
 571                                            ("v" (* (struct "kwval" :const)))
 572                                            ("n" size-t)))
 573                               "Keyword parsing for `~A.~A' on class `~A'."
 574                               (sod-class-nickname
 575                                (sod-message-class message))
 576                               (sod-message-name message)
 577                               (effective-method-class method))))))
 578
 579 (defmethod make-method-entries ((method basic-effective-method)
 580                                 (chain-head sod-class)
 581                                 (chain-tail sod-class))
 582   (let ((entries nil)
 583         (message (effective-method-message method)))
 584     (flet ((make (role)
 585              (push (make-instance 'method-entry
 586                                   :method method :role role
 587                                   :chain-head chain-head
 588                                   :chain-tail chain-tail)
 589                    entries)))
 590       (when (or (varargs-message-p message)
 591                 (keyword-message-p message))
 592         (make :valist))
 593       (make nil)
 594       entries)))
 595
 596 (defmethod compute-method-entry-functions ((method basic-effective-method))
 597
 598   ;; OK, there's quite a lot of this, so hold tight.
 599   ;;
 600   ;; The first thing we need to do is find all of the related objects.  This
 601   ;; is a bit verbose but fairly straightforward.
 602   ;;
 603   ;; Next, we generate the effective method body -- using `compute-effective-
 604   ;; method-body' of all things.  This gives us the declarations and body for
 605   ;; an effective method function, but we don't have an actual function yet.
 606   ;;
 607   ;; Now we look at the chains which are actually going to need a method
 608   ;; entry: only those chains whose tail (most specific) class is a
 609   ;; superclass of the class which defined the message need an entry.  We
 610   ;; build a list of these tail classes.
 611   ;;
 612   ;; Having done this, we decide whether it's better to generate a standalone
 613   ;; effective-method function and call it from each of the method entries,
 614   ;; or to inline the effective method body into each of the entries.
 615   ;;
 616   ;; Most of the complexity here comes from (a) dealing with the two
 617   ;; different strategies for constructing method entry functions and (b)
 618   ;; (unsurprisingly) the mess involved with dealing with varargs messages.
 619
 620   (let* ((message (effective-method-message method))
 621          (class (effective-method-class method))
 622          (message-class (sod-message-class message))
 623          (return-type (c-type-subtype (sod-message-type message)))
 624          (codegen (make-instance 'method-codegen
 625                                  :message message
 626                                  :class class
 627                                  :method method))
 628
 629          ;; Method entry details.
 630          (chain-tails (remove-if-not (lambda (super)
 631                                        (sod-subclass-p super message-class))
 632                                      (mapcar #'car
 633                                              (sod-class-chains class))))
 634          (n-entries (length chain-tails))
 635          (raw-entry-args (append (sod-message-argument-tail message)
 636                                  (and (keyword-message-p message)
 637                                       (list :ellipsis))))
 638          (entry-args (reify-variable-argument-tail raw-entry-args))
 639          (parm-n (let ((tail (last (cons (make-argument "me" c-type-void)
 640                                          raw-entry-args) 2)))
 641                    (and tail (eq (cadr tail) :ellipsis)
 642                         (argument-name (car tail)))))
 643          (entry-target (codegen-target codegen))
 644
 645          ;; Effective method function details.
 646          (emf-name (effective-method-function-name method))
 647          (ilayout-type (c-type (* (struct (ilayout-struct-tag class)))))
 648          (emf-type (c-type (fun (lisp return-type)
 649                                 ("sod__obj" (lisp ilayout-type))
 650                                 . entry-args))))
 651
 652     (flet ((setup-entry (tail)
 653              (let ((head (sod-class-chain-head tail)))
 654                (codegen-push codegen)
 655                (ensure-var codegen "sod__obj" ilayout-type
 656                            (make-convert-to-ilayout-inst class
 657                                                          head "me"))))
 658            (finish-entry (tail)
 659              (let* ((head (sod-class-chain-head tail))
 660                     (role (if parm-n :valist nil))
 661                     (name (method-entry-function-name method head role))
 662                     (type (c-type (fun (lisp return-type)
 663                                        ("me" (* (class tail)))
 664                                        . entry-args))))
 665                (codegen-pop-function codegen name type
 666                 "~@(~@[~A ~]entry~) function ~:_~
 667                  for method `~A.~A' ~:_~
 668                  via chain headed by `~A' ~:_~
 669                  defined on `~A'."
 670                 (if parm-n "Indirect argument-tail" nil)
 671                 (sod-class-nickname message-class)
 672                 (sod-message-name message)
 673                 head class)
 674
 675                ;; If this is a varargs or keyword method then we've made the
 676                ;; `:valist' role.  Also make the `nil' role.
 677                (when parm-n
 678                  (let ((call (apply #'make-call-inst name "me"
 679                                     (mapcar #'argument-name entry-args)))
 680                        (main (method-entry-function-name method head nil))
 681                        (main-type (c-type (fun (lisp return-type)
 682                                                ("me" (* (class tail)))
 683                                                . raw-entry-args))))
 684                    (codegen-push codegen)
 685                    (ensure-var codegen *sod-ap* c-type-va-list)
 686                    (convert-stmts codegen entry-target return-type
 687                                   (lambda (target)
 688                                     (deliver-call codegen :void "va_start"
 689                                                   *sod-ap* parm-n)
 690                                     (deliver-expr codegen target call)
 691                                     (deliver-call codegen :void "va_end"
 692                                                   *sod-ap*)))
 693                    (codegen-pop-function codegen main main-type
 694                     "Variable-length argument list ~:_~
 695                      entry function ~:_~
 696                      for method `~A.~A' ~:_~
 697                      via chain headed by `~A' ~:_~
 698                      defined on `~A'."
 699                 (sod-class-nickname message-class)
 700                 (sod-message-name message)
 701                 head class))))))
 702
 703       ;; Generate the method body.  We'll work out what to do with it later.
 704       (codegen-push codegen)
 705       (let* ((result (if (eq return-type c-type-void) nil
 706                          (temporary-var codegen return-type)))
 707              (emf-target (or result :void)))
 708         (compute-effective-method-body method codegen emf-target)
 709         (multiple-value-bind (vars insts) (codegen-pop codegen)
 710           (cond ((or (= n-entries 1)
 711                      (<= (* n-entries (reduce #'+ insts :key #'inst-metric))
 712                          *method-entry-inline-threshold*))
 713
 714                  ;; The effective method body is simple -- or there's only
 715                  ;; one of them.  We'll inline the method body into the entry
 716                  ;; functions.
 717                  (dolist (tail chain-tails)
 718                    (setup-entry tail)
 719                    (dolist (var vars)
 720                      (if (typep var 'var-inst)
 721                          (ensure-var codegen (inst-name var)
 722                                      (inst-type var) (inst-init var))
 723                          (emit-decl codegen var)))
 724                    (emit-insts codegen insts)
 725                    (deliver-expr codegen entry-target result)
 726                    (finish-entry tail)))
 727
 728                 (t
 729
 730                  ;; The effective method body is complicated and we'd need
 731                  ;; more than one copy.  We'll generate an effective method
 732                  ;; function and call it a lot.
 733                  (codegen-build-function codegen emf-name emf-type vars
 734                   (nconc insts (and result
 735                                     (list (make-return-inst result))))
 736                   "Effective method function ~:_for `~A.~A' ~:_~
 737                    defined on `~A'."
 738                   (sod-class-nickname message-class)
 739                   (sod-message-name message)
 740                   (effective-method-class method))
 741
 742                  (let ((call (apply #'make-call-inst emf-name "sod__obj"
 743                                     (mapcar #'argument-name entry-args))))
 744                    (dolist (tail chain-tails)
 745                      (setup-entry tail)
 746                      (deliver-expr codegen entry-target call)
 747                      (finish-entry tail)))))))
 748
 749       (codegen-functions codegen))))
 750
 751 (defmethod compute-effective-method-body :around
 752     ((method basic-effective-method) codegen target)
 753   (let* ((message (effective-method-message method))
 754          (keywordsp (keyword-message-p message))
 755          (keywords (effective-method-keywords method))
 756          (ap-addr (format nil "&~A" *sod-tmp-ap*))
 757          (set (format nil "\"~A:~A.~A\""
 758                       (sod-class-name (effective-method-class method))
 759                       (sod-class-nickname (sod-message-class message))
 760                       (sod-message-name message))))
 761     (labels ((call (target func &rest args)
 762                (apply #'deliver-call codegen target func args))
 763              (parse-keywords (body)
 764                (ensure-var codegen *sod-tmp-ap* c-type-va-list)
 765                (call :void "va_copy" *sod-tmp-ap* *sod-ap*)
 766                (funcall body)
 767                (call :void "va_end" *sod-tmp-ap*)))
 768       (cond ((not keywordsp)
 769              (call-next-method))
 770             ((null keywords)
 771              (let ((*keyword-struct-disposition* :null))
 772                (parse-keywords (lambda ()
 773                                  (with-temporary-var
 774                                      (codegen kw c-type-const-string)
 775                                    (call kw "va_arg"
 776                                          *sod-tmp-ap* c-type-const-string)
 777                                    (call :void "kw_parseempty" set
 778                                          kw ap-addr *null-pointer* 0))))
 779                (call-next-method)))
 780             (t
 781              (let* ((name
 782                      (effective-method-keyword-parser-function-name method))
 783                     (tag (effective-method-keyword-struct-tag method))
 784                     (kw-addr (format nil "&~A" *sod-keywords*))
 785                     (*keyword-struct-disposition* :local))
 786                (ensure-var codegen *sod-keywords* (c-type (struct tag)))
 787                (make-keyword-parser-function codegen method tag set keywords)
 788                (parse-keywords (lambda ()
 789                                  (call :void name kw-addr ap-addr
 790                                        *null-pointer* 0)))
 791                (call-next-method)))))))
 792
 793 (defmethod compute-method-entry-functions
 794     ((method simple-effective-method))
 795   (if (effective-method-primary-methods method)
 796       (call-next-method)
 797       nil))
 798
 799 (defmethod compute-effective-method-body
 800     ((method simple-effective-method) codegen target)
 801   (basic-effective-method-body codegen target method
 802                                (lambda (target)
 803                                  (simple-method-body method
 804                                                      codegen
 805                                                      target))))
 806
 807 ;;;--------------------------------------------------------------------------
 808 ;;; Standard method combination.
 809
 810 (export 'standard-message)
 811 (defclass standard-message (simple-message)
 812   ()
 813   (:documentation
 814    "Message class for standard method combinations.
 815
 816    Standard method combination is a simple method combination where the
 817    primary methods are invoked as a delegation chain, from most- to
 818    least-specific."))
 819
 820 (export 'standard-effective-method)
 821 (defclass standard-effective-method (simple-effective-method) ()
 822   (:documentation "Effective method counterpart to `standard-message'."))
 823
 824 (defmethod primary-method-class ((message standard-message))
 825   'delegating-direct-method)
 826
 827 (defmethod sod-message-effective-method-class ((message standard-message))
 828   'standard-effective-method)
 829
 830 (defmethod simple-method-body
 831     ((method standard-effective-method) codegen target)
 832   (invoke-delegation-chain codegen
 833                            target
 834                            (effective-method-basic-argument-names method)
 835                            (effective-method-primary-methods method)
 836                            nil))
 837
 838 ;;;----- That's all, folks --------------------------------------------------