changelog shortlog graph tags branches changeset files revisions annotate raw help

Mercurial > core / lisp/lib/obj/meta/fast.lisp

changeset 698: 96958d3eb5b0
parent: 10faf95f90dd
author: Richard Westhaver <ellis@rwest.io>
date: Fri, 04 Oct 2024 22:04:59 -0400
permissions: -rw-r--r--
description: fixes 
     1 ;;; obj/meta/fast.lisp --- Fast generic functions
     2 
     3 ;; see https://github.com/marcoheisig/fast-generic-functions
     4 
     5 ;;; Code:
     6 (in-package :obj/meta/fast)
     7 
     8 (deftype local-variable ()
     9   '(and symbol (not (satisfies constantp))))
    10 
    11 (defclass required-info ()
    12   ((%variable
    13     :initarg :variable
    14     :reader required-info-variable
    15     :type local-variable
    16     :initform (required-argument :variable))))
    17 
    18 (defclass optional-info ()
    19   ((%variable
    20     :initarg :variable
    21     :reader optional-info-variable
    22     :type local-variable
    23     :initform (required-argument :variable))
    24    (%initform
    25     :initarg :initform
    26     :reader optional-info-initform
    27     :initform nil)
    28    (%suppliedp
    29     :initarg :suppliedp
    30     :reader optional-info-suppliedp
    31     :type (or null local-variable)
    32     :initform nil)))
    33 
    34 (defclass keyword-info ()
    35   ((%keyword
    36     :initarg :keyword
    37     :reader keyword-info-keyword
    38     :type keyword
    39     :initform (required-argument :keyword))
    40    (%variable
    41     :initarg :variable
    42     :reader keyword-info-variable
    43     :type local-variable
    44     :initform (required-argument :variable))
    45    (%initform
    46     :initarg :initform
    47     :reader keyword-info-initform
    48     :initform nil)
    49    (%suppliedp
    50     :initarg :suppliedp
    51     :reader keyword-info-suppliedp
    52     :type (or null local-variable)
    53     :initform nil)))
    54 
    55 (defclass auxiliary-info ()
    56   ((%variable
    57     :initarg :variable
    58     :reader auxiliary-info-variable
    59     :type local-variable
    60     :initform (required-argument :variable))
    61    (%initform
    62     :initarg :initform
    63     :reader auxiliary-info-initform
    64     :initform nil)))
    65 
    66 (defun parse-ordinary-lambda-list (lambda-list)
    67   "Returns six values:
    68 
    69  1. A list of REQUIRED-INFO instances, one for each required argument.
    70 
    71  2. A list of OPTIONAL-INFO instances, one for each optional argument.
    72 
    73  3. The name of the rest variable, or NIL, if there is none.
    74 
    75  4. A list of KEYWORD-INFO instances, one for each keyword argument.
    76 
    77  5. A boolean, indicating whether &allow-other-keys is present.
    78 
    79  6. A list of AUXILIARY-INFO instances, one for each auxiliary argument.
    80 
    81 Can parse all but specialized lambda lists.
    82 "
    83   (let ((required '())
    84         (optional '())
    85         (keyword '())
    86         (auxiliary '())
    87         (rest-var nil)
    88         (allow-other-keys-p nil))
    89     (labels ((fail ()
    90                (error "Malformed lambda list: ~S" lambda-list))
    91              (parse-required (lambda-list)
    92                (unless (endp lambda-list)
    93                  (let ((item (first lambda-list)))
    94                    (case item
    95                      (&optional (parse-&optional (rest lambda-list)))
    96                      (&rest (parse-&rest (rest lambda-list)))
    97                      (&key (parse-&key (rest lambda-list)))
    98                      (&aux (parse-&aux (rest lambda-list)))
    99                      (#.(set-difference lambda-list-keywords '(&optional &rest &key &aux))
   100                       (fail))
   101                      (otherwise
   102                       (push (parse-reqired-item item) required)
   103                       (parse-required (rest lambda-list)))))))
   104              (parse-&optional (lambda-list)
   105                (unless (endp lambda-list)
   106                  (let ((item (first lambda-list)))
   107                    (case item
   108                      (&rest (parse-&rest (rest lambda-list)))
   109                      (&key (parse-&key (rest lambda-list)))
   110                      (&aux (parse-&aux (rest lambda-list)))
   111                      (#.(set-difference lambda-list-keywords '(&rest &key &aux))
   112                       (fail))
   113                      (otherwise
   114                       (push (parse-optional-item item) optional)
   115                       (parse-&optional (rest lambda-list)))))))
   116              (parse-&rest (lambda-list)
   117                (unless (consp lambda-list)
   118                  (fail))
   119                (let ((item (first lambda-list)))
   120                  (unless (symbolp item)
   121                    (fail))
   122                  (unless (null rest-var)
   123                    (fail))
   124                  (setf rest-var item)
   125                  (unless (endp (rest lambda-list))
   126                    (case (first (rest lambda-list))
   127                      (&key (parse-&key (rest (rest lambda-list))))
   128                      (&aux (parse-&aux (rest (rest lambda-list))))
   129                      (otherwise (fail))))))
   130              (parse-&key (lambda-list)
   131                (unless (endp lambda-list)
   132                  (let ((item (first lambda-list)))
   133                    (case item
   134                      (&allow-other-keys (parse-&allow-other-keys (rest lambda-list)))
   135                      (&aux (parse-&aux (rest lambda-list)))
   136                      (#.(set-difference lambda-list-keywords '(&allow-other-keys &aux))
   137                       (fail))
   138                      (otherwise
   139                       (push (parse-keyword-item item) keyword)
   140                       (parse-&key (rest lambda-list)))))))
   141              (parse-&allow-other-keys (lambda-list)
   142                (setf allow-other-keys-p t)
   143                (unless (endp lambda-list)
   144                  (case (first lambda-list)
   145                    (&aux (parse-&aux (rest lambda-list)))
   146                    (otherwise
   147                     (fail)))))
   148              (parse-&aux (lambda-list)
   149                (unless (endp lambda-list)
   150                  (let ((item (first lambda-list)))
   151                    (case item
   152                      (#.lambda-list-keywords (fail))
   153                      (otherwise
   154                       (push (parse-auxiliary-item item) auxiliary)
   155                       (parse-&aux (rest lambda-list))))))))
   156       (parse-required lambda-list))
   157     (values
   158      (nreverse required)
   159      (nreverse optional)
   160      rest-var
   161      (nreverse keyword)
   162      allow-other-keys-p
   163      (nreverse auxiliary))))
   164 
   165 (defun parse-reqired-item (item)
   166   (unless (typep item 'local-variable)
   167     (error "Not a valid lambda list variable: ~S"
   168            item))
   169   (make-instance 'required-info
   170     :variable item))
   171 
   172 (defun parse-optional-item (item)
   173   (typecase item
   174     (local-variable
   175      (make-instance 'optional-info
   176        :variable item))
   177     ((cons local-variable null)
   178      (make-instance 'optional-info
   179        :variable (first item)))
   180     ((cons local-variable (cons t null))
   181      (make-instance 'optional-info
   182        :variable (first item)
   183        :initform (second item)))
   184     ((cons local-variable (cons t (cons local-variable null)))
   185      (make-instance 'optional-info
   186        :variable (first item)
   187        :initform (second item)
   188        :suppliedp (third item)))
   189     (t (error "Invalid &optional lambda list item: ~S"
   190               item))))
   191 
   192 (defun parse-keyword-item (item)
   193   (labels ((fail ()
   194              (error "Invalid &key lambda list item: ~S"
   195                     item))
   196            (parse-keyword-var (item)
   197            (etypecase item
   198              (symbol
   199               (values (intern (symbol-name item) :keyword)
   200                       item))
   201              ((cons symbol null)
   202               (values (intern (symbol-name (first item)) :keyword)
   203                       (first item)))
   204              ((cons keyword (cons symbol null))
   205               (values (first item)
   206                       (second item)))
   207              (t (fail)))))
   208     (typecase item
   209       (local-variable
   210        (make-instance 'keyword-info
   211          :variable item
   212          :keyword (intern (symbol-name item) :keyword)))
   213       ((cons t null)
   214        (multiple-value-bind (keyword variable)
   215            (parse-keyword-var (first item))
   216          (make-instance 'keyword-info
   217            :variable variable
   218            :keyword keyword)))
   219       ((cons t (cons t null))
   220        (multiple-value-bind (keyword variable)
   221            (parse-keyword-var (first item))
   222          (make-instance 'keyword-info
   223            :variable variable
   224            :keyword keyword
   225            :initform (second item))))
   226       ((cons t (cons t (cons local-variable null)))
   227        (multiple-value-bind (keyword variable)
   228            (parse-keyword-var (first item))
   229          (make-instance 'keyword-info
   230            :variable variable
   231            :keyword keyword
   232            :initform (second item)
   233            :suppliedp (third item))))
   234       (t (fail)))))
   235 
   236 (defun parse-auxiliary-item (item)
   237   (typecase item
   238     (local-variable
   239      (make-instance 'auxiliary-info
   240        :variable item))
   241     ((cons local-variable null)
   242      (make-instance 'auxiliary-info
   243        :variable (first item)))
   244     ((cons local-variable (cons t null))
   245      (make-instance 'auxiliary-info
   246        :variable (first item)
   247        :initform (second item)))
   248     (t (error "Invalid &aux lambda list item: ~S"
   249               item))))
   250 
   251 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   252 ;;;
   253 ;;; Lambda List Unparsing
   254 
   255 (defun unparse-ordinary-lambda-list
   256     (required optional rest-var keyword allow-other-keys-p auxiliary)
   257   (append
   258    (unparse-required required)
   259    (unparse-optional optional)
   260    (unparse-rest rest-var)
   261    (unparse-keyword keyword allow-other-keys-p)
   262    (unparse-auxiliary auxiliary)))
   263 
   264 (defun unparse-required (required)
   265   (mapcar
   266    (lambda (info)
   267      (required-info-variable info))
   268    required))
   269 
   270 (defun unparse-optional (optional)
   271   (if (null optional)
   272       `()
   273       `(&optional
   274         ,@(mapcar
   275            (lambda (info)
   276              `(,(optional-info-variable info)
   277                ,(optional-info-initform info)
   278                ,@(if (optional-info-suppliedp info)
   279                      `(,(optional-info-suppliedp info))
   280                      `())))
   281            optional))))
   282 
   283 (defun unparse-keyword (keyword allow-other-keys-p)
   284   (if (and (null keyword)
   285            (not allow-other-keys-p))
   286       `()
   287       `(&key
   288         ,@(mapcar
   289            (lambda (info)
   290              `((,(keyword-info-keyword info) ,(keyword-info-variable info))
   291                ,(keyword-info-initform info)
   292                ,@(if (keyword-info-suppliedp info)
   293                      `(,(keyword-info-suppliedp info))
   294                      `())))
   295            keyword)
   296         ,@(if allow-other-keys-p
   297               '(&allow-other-keys)
   298               '()))))
   299 
   300 (defun unparse-rest (rest-var)
   301   (if (null rest-var)
   302       `()
   303       `(&rest ,rest-var)))
   304 
   305 (defun unparse-auxiliary (auxiliary)
   306   (if (null auxiliary)
   307       `()
   308       `(&aux
   309         ,@(mapcar
   310            (lambda (info)
   311              (list (auxiliary-info-variable info)
   312                    (auxiliary-info-initform info)))
   313            auxiliary))))
   314 
   315 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   316 ;;;
   317 ;;; Lambda List Info Anonymization
   318 
   319 (defun anonymize-ordinary-lambda-list (lambda-list)
   320   (multiple-value-bind (required optional rest-var keyword allow-other-keys-p auxiliary)
   321       (parse-ordinary-lambda-list lambda-list)
   322     (unparse-ordinary-lambda-list
   323      (mapcar #'anonymize-required-info required)
   324      (mapcar #'anonymize-optional-info optional)
   325      (if (null rest-var)
   326          nil
   327          (gensymify rest-var))
   328      (mapcar #'anonymize-keyword-info keyword)
   329      allow-other-keys-p
   330      (mapcar #'anonymize-auxiliary-info auxiliary))))
   331 
   332 (defun anonymize-required-info (info)
   333   (make-instance 'required-info
   334     :variable (gensymify (required-info-variable info))))
   335 
   336 (defun anonymize-optional-info (info)
   337   (make-instance 'optional-info
   338     :variable (gensymify (optional-info-variable info))
   339     :initform (optional-info-initform info)
   340     :suppliedp (if (optional-info-suppliedp info)
   341                    (gensymify (optional-info-suppliedp info))
   342                    nil)))
   343 
   344 (defun anonymize-keyword-info (info)
   345   (make-instance 'keyword-info
   346     :variable (gensymify (keyword-info-variable info))
   347     :keyword (keyword-info-keyword info)
   348     :initform (keyword-info-initform info)
   349     :suppliedp (if (keyword-info-suppliedp info)
   350                    (gensymify (keyword-info-suppliedp info))
   351                    nil)))
   352 
   353 (defun anonymize-auxiliary-info (info)
   354   (make-instance 'auxiliary-info
   355     :variable (gensymify (auxiliary-info-variable info))
   356     :initform (auxiliary-info-initform info)))
   357 
   358 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   359 ;;;
   360 ;;; Miscellaneous
   361 
   362 (defun normalize-ordinary-lambda-list (lambda-list)
   363   (multiple-value-call #'unparse-ordinary-lambda-list
   364     (parse-ordinary-lambda-list lambda-list)))
   365 
   366 (defun lambda-list-variables (lambda-list)
   367   (multiple-value-bind (required optional rest-var keyword allow-other-keys-p auxiliary)
   368       (parse-ordinary-lambda-list lambda-list)
   369     (declare (ignore allow-other-keys-p))
   370     (let ((variables '()))
   371       (dolist (info required)
   372         (push (required-info-variable info) variables))
   373       (dolist (info optional)
   374         (push (optional-info-variable info) variables)
   375         (when (optional-info-suppliedp info)
   376           (push (optional-info-suppliedp info) variables)))
   377       (unless (null rest-var)
   378         (push rest-var variables))
   379       (dolist (info keyword)
   380         (push (keyword-info-variable info) variables)
   381         (when (keyword-info-suppliedp info)
   382           (push (keyword-info-suppliedp info) variables)))
   383       (dolist (info auxiliary)
   384         (push (auxiliary-info-variable info) variables))
   385       (nreverse variables))))
   386 
   387 (defun lambda-list-apply-arguments (lambda-list)
   388   (multiple-value-bind (required optional rest-var keyword)
   389       (parse-ordinary-lambda-list lambda-list)
   390     (append
   391      (mapcar #'required-info-variable required)
   392      (mapcar #'optional-info-variable optional)
   393      (if rest-var
   394          `(,rest-var)
   395          `(,@(loop for info in keyword
   396                    collect (keyword-info-keyword info)
   397                    collect (keyword-info-variable info))
   398            '())))))
   399 
   400 ;;; expand-effective-method-body
   401 (defun expand-effective-method-body
   402     (effective-method generic-function lambda-list)
   403   (macroexpand-all
   404    `(let ((.gf. #',(sb-mop:generic-function-name generic-function)))
   405       (declare (ignorable .gf.))
   406       (declare (sb-ext:disable-package-locks common-lisp:call-method))
   407       (declare (sb-ext:disable-package-locks common-lisp:make-method))
   408       (declare (sb-ext:disable-package-locks sb-pcl::check-applicable-keywords))
   409       (declare (sb-ext:disable-package-locks sb-pcl::no-primary-method))
   410       (macrolet
   411           (;; SBCL introduces explicit keyword argument checking into
   412            ;; the effective method.  Since we do our own checking, we
   413            ;; can safely disable it.  However, we touch the relevant
   414            ;; variables to prevent unused variable warnings.
   415            #+sbcl
   416            (sb-pcl::check-applicable-keywords (&rest args)
   417              (declare (ignore args))
   418              `(progn sb-pcl::.valid-keys. sb-pcl::.keyargs-start. (values)))
   419            ;; SBCL introduces a magic form to report when there are no
   420            ;; primary methods.  The problem is that this form contains a
   421            ;; reference to the literal generic function, which is not an
   422            ;; externalizable object.  Our solution is to replace it with
   423            ;; something portable.
   424            #+sbcl
   425            (sb-pcl::no-primary-method (&rest args)
   426              (declare (ignore args))
   427              `(apply #'no-primary-method .gf. ,@',(lambda-list-apply-arguments lambda-list))))
   428         ,(wrap-in-call-method-macrolet
   429           effective-method
   430           generic-function
   431           lambda-list)))))
   432 
   433 (defun wrap-in-call-method-macrolet (form generic-function lambda-list)
   434   `(macrolet ((call-method (method &optional next-methods)
   435                 (expand-call-method
   436                  method
   437                  next-methods
   438                  ',lambda-list
   439                  ',(class-name
   440                     (sb-mop:generic-function-method-class generic-function)))))
   441      ,(wrap-in-reinitialize-arguments form lambda-list)))
   442 
   443 (defun wrap-in-reinitialize-arguments (form lambda-list)
   444   (let ((anonymized-lambda-list
   445           (anonymize-ordinary-lambda-list lambda-list)))
   446     `(flet ((reinitialize-arguments ,anonymized-lambda-list
   447               ,@(mapcar
   448                  (lambda (place value)
   449                    `(setf ,place ,value))
   450                  (lambda-list-variables lambda-list)
   451                  (lambda-list-variables anonymized-lambda-list))))
   452        (declare (ignorable #'reinitialize-arguments))
   453        (declare (inline reinitialize-arguments))
   454        ,form)))
   455 
   456 (defun expand-call-method (method next-methods lambda-list method-class)
   457   (wrap-in-next-methods
   458    (call-fast-method-lambda
   459     (coerce-to-fast-method method lambda-list method-class)
   460     lambda-list)
   461    next-methods
   462    lambda-list
   463    method-class))
   464 
   465 (defun coerce-to-fast-method (method lambda-list method-class)
   466   (cond ((typep method 'fast-method)
   467          method)
   468         ((and (consp method)
   469               (eql (car method) 'make-method)
   470               (null (cddr method)))
   471          (make-instance method-class
   472            :lambda-list lambda-list
   473            :specializers (make-list (length (parse-ordinary-lambda-list lambda-list))
   474                                     :initial-element (find-class 't))
   475            :qualifiers '()
   476            :function #'values
   477            'lambda
   478            `(lambda ,lambda-list
   479               (declare (ignorable ,@(lambda-list-variables lambda-list)))
   480               ,(second method))))
   481         (t
   482          (error "Cannot turn ~S into an inlineable method."
   483                 method))))
   484 
   485 (defun wrap-in-next-methods (form next-methods lambda-list method-class)
   486   (if (null next-methods)
   487       `(flet ((next-method-p () nil)
   488               (call-next-method ()
   489                 (apply
   490                  #'no-next-method
   491                  .gf.
   492                  (class-prototype (find-class ',method-class))
   493                  ,@(lambda-list-apply-arguments lambda-list))))
   494          (declare (ignorable #'next-method-p #'call-next-method))
   495          ,form)
   496       (wrap-in-next-methods
   497        `(flet ((next-method-p () t)
   498                (call-next-method (&rest args)
   499                  (unless (null args)
   500                    (apply #'reinitialize-arguments args))
   501                  (call-method ,(first next-methods) ,(rest next-methods))))
   502           (declare (ignorable #'next-method-p #'call-next-method))
   503           ,form)
   504        (rest next-methods)
   505        lambda-list
   506        method-class)))
   507 
   508 (defun call-fast-method-lambda (method lambda-list)
   509   (multiple-value-bind (g-required g-optional g-rest-var g-keyword)
   510       (parse-ordinary-lambda-list lambda-list)
   511     (multiple-value-bind (m-required m-optional m-rest-var m-keyword)
   512         (parse-ordinary-lambda-list (sb-mop:method-lambda-list method))
   513       ;; Assert that the method has arguments that are congruent to those
   514       ;; of the corresponding generic function.
   515       (assert (or (= (length g-required)
   516                      (length m-required))))
   517       (assert (= (length g-optional)
   518                  (length m-optional)))
   519       (when (null g-rest-var)
   520         (assert (null m-rest-var)))
   521       `(funcall
   522         ,(fast-method-lambda method)
   523         ;; Required arguments.
   524         ,@(mapcar #'required-info-variable g-required)
   525         ;; Optional arguments.
   526         ,@(loop for g-info in g-optional
   527                 for m-info in m-optional
   528                 append
   529                 (if (null (optional-info-suppliedp g-info))
   530                     `(,(optional-info-variable g-info))
   531                     (let ((value
   532                             `(if ,(optional-info-suppliedp g-info)
   533                                  ,(optional-info-variable g-info)
   534                                  ,(optional-info-initform m-info))))
   535                       (if (null (optional-info-suppliedp m-info))
   536                           `(,value)
   537                           `(,value ,(optional-info-suppliedp g-info))))))
   538         ;; The rest argument.
   539         ,@(if (null m-rest-var)
   540               `()
   541               `(,g-rest-var))
   542         ;; Keyword arguments.
   543         ,@(loop for m-info in m-keyword
   544                 for g-info = (find (keyword-info-keyword m-info) g-keyword
   545                                    :key #'keyword-info-keyword)
   546                 append
   547                 (if (null (keyword-info-suppliedp g-info))
   548                     `(,(keyword-info-variable g-info))
   549                     (let ((value
   550                             `(if ,(keyword-info-suppliedp g-info)
   551                                  ,(keyword-info-variable g-info)
   552                                  ,(keyword-info-initform m-info))))
   553                       (if (null (keyword-info-suppliedp m-info))
   554                           `(,value)
   555                           `(,value ,(keyword-info-suppliedp g-info))))))))))
   556 
   557 ;;; generic functions
   558 (defgeneric optimize-function-call (generic-function static-call-signature))
   559 
   560 ;; may need to change this to conform with sb-pcl..
   561 (defgeneric no-primary-method (generic-function &rest arguments)
   562   (:method ((generic-function generic-function) &rest arguments)
   563     (error "~@<No primary method for call to the generic function ~S with ~
   564              arguments ~S.~:@>"
   565            generic-function arguments)))
   566 
   567 ;;; fast-method
   568 (defclass fast-method (potentially-sealable-standard-method)
   569   ((%lambda
   570     :initarg .lambda.
   571     :reader fast-method-lambda
   572     :initform (required-argument '.lambda.))))
   573 
   574 (defmethod validate-method-property
   575     ((method fast-method) (property (eql 'inlineable)))
   576   t)
   577 
   578 (defmethod make-method-lambda :around
   579     ((gf sealable-standard-generic-function)
   580      (fast-method fast-method)
   581      lambda
   582      environment)
   583   (multiple-value-bind (method-lambda initargs)
   584       (call-next-method)
   585     (values
   586      method-lambda
   587      (list*
   588       '.lambda.
   589       (make-fast-method-lambda gf fast-method lambda environment)
   590       initargs))))
   591 
   592 ;; utility for the function below
   593 (defun block-name (function-name)
   594   (etypecase function-name
   595     ((and symbol (not null)) function-name)
   596     ((cons (eql setf) (cons symbol null)) (second function-name))))
   597 
   598 (defun make-fast-method-lambda
   599     (generic-function method lambda environment)
   600   (declare (ignore method))
   601   (destructuring-bind (lambda-symbol lambda-list &rest body) lambda
   602     (assert (eql lambda-symbol 'lambda))
   603     (multiple-value-bind (required optional rest-var keyword allow-other-keys-p auxiliary)
   604         (parse-ordinary-lambda-list lambda-list)
   605       (multiple-value-bind (forms declarations)
   606           (parse-body body)
   607         (let ((partially-flattened-lambda-list
   608                 `(,@(lambda-list-variables
   609                      (unparse-ordinary-lambda-list
   610                       required optional rest-var keyword allow-other-keys-p '()))
   611                   ,@(unparse-ordinary-lambda-list '() '() nil '() nil auxiliary))))
   612           (macroexpand-all
   613            `(lambda ,partially-flattened-lambda-list
   614               (declare (ignorable ,@(mapcar #'required-info-variable required)))
   615               ,@declarations
   616               (block ,(block-name (sb-mop:generic-function-name generic-function))
   617                 ,@forms))
   618            environment))))))
   619 
   620 (defclass fast-generic-function (sealable-standard-generic-function)
   621   ((%full-effective-method-cache :initform '() :accessor full-effective-method-cache)
   622    (%flat-effective-method-cache :initform '() :accessor flat-effective-method-cache))
   623   (:default-initargs
   624    :method-class (find-class 'fast-method))
   625   (:metaclass sb-mop:funcallable-standard-class))
   626 
   627 (defmethod compute-effective-method-function
   628     ((fgf fast-generic-function) effective-method options)
   629   (let ((lambda-list
   630           (anonymize-ordinary-lambda-list
   631            ;; Unfortunately, we don't know the list of applicable methods
   632            ;; anymore at this stage.  So instead, we consider all methods
   633            ;; applicable.
   634            (compute-effective-method-lambda-list fgf (sb-mop:generic-function-methods fgf)))))
   635     (compile
   636      nil
   637      `(lambda ,lambda-list
   638         ,(expand-effective-method-body effective-method fgf lambda-list)))))
   639 
   640 ;;; optimize-function-call
   641 (defmethod optimize-function-call :around
   642     ((fast-generic-function fast-generic-function)
   643      (static-call-signature static-call-signature))
   644   (call-next-method))
   645 
   646 (defmethod optimize-function-call
   647     ((fast-generic-function fast-generic-function)
   648      (static-call-signature static-call-signature))
   649   (let ((applicable-methods
   650           (compute-applicable-methods
   651            fast-generic-function
   652            (static-call-signature-prototypes static-call-signature))))
   653     (cond (;; Inline the entire effective method.
   654            (every #'inlineable-method-p applicable-methods)
   655            (effective-method-lambda fast-generic-function static-call-signature nil))
   656           ;; Inline only the optional/keyword parsing step.
   657           ((and (externalizable-object-p static-call-signature)
   658                 (intersection (sb-mop:generic-function-lambda-list fast-generic-function)
   659                               '(&optional &key &rest)))
   660            (let ((lambda-list
   661                    (anonymize-ordinary-lambda-list
   662                     (compute-effective-method-lambda-list
   663                      fast-generic-function applicable-methods))))
   664              `(lambda ,lambda-list
   665                 (funcall
   666                  (load-time-value
   667                   (the function
   668                        (lookup-flat-effective-method
   669                         #',(sb-mop:generic-function-name fast-generic-function)
   670                         ',static-call-signature)))
   671                  ,@(lambda-list-variables lambda-list)))))
   672           ;; Eliminate the dispatch function.
   673           ((externalizable-object-p static-call-signature)
   674            `(lambda (&rest args)
   675               (apply
   676                (load-time-value
   677                 (the function
   678                      (lookup-full-effective-method
   679                       #',(sb-mop:generic-function-name fast-generic-function)
   680                       ',static-call-signature)))
   681                args)))
   682           ;; Give up.
   683           (t nil))))
   684 
   685 (defun inlineable-method-p (method)
   686   (member 'inlineable (method-properties method)))
   687 
   688 (defun effective-method-lambda
   689     (generic-function static-call-signature flatten-arguments)
   690   (let* ((applicable-methods
   691            (compute-applicable-methods
   692             generic-function
   693             (static-call-signature-prototypes static-call-signature)))
   694          (effective-method-lambda-list
   695            (compute-effective-method-lambda-list
   696             generic-function applicable-methods))
   697          (anonymized-lambda-list
   698            (anonymize-ordinary-lambda-list effective-method-lambda-list)))
   699     `(lambda ,(if flatten-arguments
   700                   (lambda-list-variables anonymized-lambda-list)
   701                   anonymized-lambda-list)
   702        (declare (optimize (safety 0)))
   703        ,@(loop for type in (static-call-signature-types static-call-signature)
   704                for argument in anonymized-lambda-list
   705                collect `(declare (ignorable ,argument))
   706                collect `(declare (type ,type ,argument)))
   707        (locally (declare (optimize (safety 1)))
   708          ,(expand-effective-method-body
   709            (sb-mop:compute-effective-method
   710             generic-function
   711             (sb-mop:generic-function-method-combination generic-function)
   712             applicable-methods)
   713            generic-function
   714            anonymized-lambda-list)))))
   715 
   716 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   717 ;;;
   718 ;;; Computing the Effective Method Lambda List
   719 
   720 (defun merge-required-infos (g-required m-requireds)
   721   (dolist (m-required m-requireds g-required)
   722     (assert (= (length m-required)
   723                (length g-required)))))
   724 
   725 (defun merge-optional-infos (g-optional m-optionals)
   726   (let ((n (length g-optional)))
   727     (dolist (m-optional m-optionals)
   728       (assert (= (length m-optional) n)))
   729     (unless (zerop n)
   730       (loop for g-info in g-optional
   731             for m-infos in (apply #'mapcar #'list m-optionals)
   732             collect
   733             ;; Now we have two cases - the one is that at least one method
   734             ;; cares about the suppliedp flag, the other one is that no
   735             ;; method cares.  Even if a method doesn't reference the
   736             ;; suppliedp flag itself, it may still need it to decide whether
   737             ;; to supply its initform or not.  Because of this, the suppliedp
   738             ;; parameter can only be discarded globally when the initforms of
   739             ;; all methods are constant and equal.
   740             (let ((global-initform (optional-info-initform (first m-infos)))
   741                   (no-one-cares (not (optional-info-suppliedp (first m-infos)))))
   742               (dolist (m-info m-infos)
   743                 (with-accessors ((variable optional-info-variable)
   744                                  (initform optional-info-initform)
   745                                  (suppliedp optional-info-suppliedp))
   746                     m-info
   747                   (unless (and (constantp initform)
   748                                (equal initform global-initform)
   749                                (not suppliedp))
   750                     (setf no-one-cares nil))))
   751               (if no-one-cares
   752                   (make-instance 'optional-info
   753                     :variable (optional-info-variable g-info)
   754                     :initform global-initform)
   755                   (make-instance 'optional-info
   756                     :variable (optional-info-variable g-info)
   757                     :initform nil
   758                     :suppliedp (optional-info-suppliedp g-info))))))))
   759 
   760 (defun merge-keyword-infos (g-keyword m-keywords)
   761   ;; First we assemble an alist whose keys are keywords and whose values
   762   ;; are all method keyword info objects that read this keyword.
   763   (let ((alist '()))
   764     (dolist (g-info g-keyword)
   765       (pushnew (list (keyword-info-keyword g-info)) alist))
   766     (dolist (m-keyword m-keywords)
   767       (dolist (m-info m-keyword)
   768         (let* ((key (keyword-info-keyword m-info))
   769                (entry (assoc key alist)))
   770           (if (consp entry)
   771               (push m-info (cdr entry))
   772               (push (list key m-info) alist)))))
   773     (loop for (key . m-infos) in alist
   774           collect
   775           ;; Merging keyword info objects is handled just like in the case
   776           ;; of optional info objects above.
   777           (let ((global-initform (keyword-info-initform (first m-infos)))
   778                 (no-one-cares (not (keyword-info-suppliedp (first m-infos))))
   779                 ;; Not actually g-info, but we need some place to grab a
   780                 ;; variable name form.
   781                 (g-info (or (find key g-keyword :key #'keyword-info-keyword)
   782                             (first m-infos))))
   783             (dolist (m-info m-infos)
   784               (with-accessors ((initform keyword-info-initform)
   785                                (suppliedp keyword-info-suppliedp))
   786                   m-info
   787                 (unless (and (constantp initform)
   788                              (equal initform global-initform)
   789                              (not suppliedp))
   790                   (setf no-one-cares nil))))
   791             (if no-one-cares
   792                 (make-instance 'keyword-info
   793                   :keyword key
   794                   :variable (keyword-info-variable g-info)
   795                   :initform global-initform)
   796                 (make-instance 'keyword-info
   797                   :keyword key
   798                   :variable (keyword-info-variable g-info)
   799                   :initform nil
   800                   :suppliedp (or (keyword-info-suppliedp g-info)
   801                                  (gensymify "SUPPLIEDP"))))))))
   802 
   803 (defun merge-allow-other-keys (g-allow-other-keys m-allow-other-keys-list)
   804   (reduce
   805    (lambda (a b) (or a b))
   806    m-allow-other-keys-list
   807    :initial-value g-allow-other-keys))
   808 
   809 (defun compute-effective-method-lambda-list (generic-function applicable-methods)
   810   (multiple-value-bind (required optional rest-var keyword allow-other-keys)
   811       (parse-ordinary-lambda-list (sb-mop:generic-function-lambda-list generic-function))
   812     (let ((method-parses
   813             (mapcar
   814              (lambda (method)
   815                (multiple-value-list
   816                 (parse-ordinary-lambda-list
   817                  (sb-mop:method-lambda-list method))))
   818              applicable-methods)))
   819       (unparse-ordinary-lambda-list
   820        (merge-required-infos required (mapcar #'first method-parses))
   821        (merge-optional-infos optional (mapcar #'second method-parses))
   822        rest-var
   823        (merge-keyword-infos keyword (mapcar #'fourth method-parses))
   824        (merge-allow-other-keys allow-other-keys (mapcar #'fifth method-parses))
   825        '()))))
   826 
   827 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   828 ;;;
   829 ;;; Effective Method Lookup
   830 
   831 (declaim (ftype (function * function) lookup-full-effective-method))
   832 (declaim (ftype (function * function) lookup-flat-effective-method))
   833 
   834 (defun lookup-full-effective-method
   835     (generic-function static-call-signature)
   836   (with-accessors ((alist full-effective-method-cache)) generic-function
   837     (let* ((key (static-call-signature-types static-call-signature))
   838            (entry (assoc key alist :test #'equal)))
   839       (if (consp entry)
   840           (cdr entry)
   841           (let ((fn (compile nil (effective-method-lambda
   842                                   generic-function
   843                                   static-call-signature
   844                                   nil))))
   845             (push (cons key fn) alist)
   846             fn)))))
   847 
   848 (defun lookup-flat-effective-method
   849     (generic-function static-call-signature)
   850   (with-accessors ((alist flat-effective-method-cache)) generic-function
   851     (let* ((key (static-call-signature-types static-call-signature))
   852            (entry (assoc key alist :test #'equal)))
   853       (if (consp entry)
   854           (cdr entry)
   855           (let ((fn (compile nil (effective-method-lambda
   856                                   generic-function
   857                                   static-call-signature
   858                                   t))))
   859             (push (cons key fn) alist)
   860             fn)))))
   861 
   862 (defmethod seal-domain :after
   863     ((fast-generic-function fast-generic-function)
   864      (domain domain))
   865   (let ((name (sb-mop:generic-function-name fast-generic-function)))
   866     ;; Ensure that the function is known.
   867     (unless (sb-c::info :function :info name)
   868       (compile nil (eval `(sb-c:defknown ,name * * ()))))
   869     ;; Create an IR1-transform for each static call signature.
   870     (dolist (static-call-signature (compute-static-call-signatures fast-generic-function domain))
   871       (with-accessors ((types static-call-signature-types)
   872                        (prototypes static-call-signature-prototypes))
   873           static-call-signature
   874         (eval
   875          `(sb-c:deftransform ,name ((&rest args) (,@types &rest *))
   876             (or (optimize-function-call #',name ',static-call-signature)
   877                 (sb-c::give-up-ir1-transform))))))))