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