├── LICENSE ├── README.org ├── code ├── ccl.lisp ├── default.lisp ├── expand-effective-method-body.lisp ├── fast-generic-function.lisp ├── fast-generic-functions.asd ├── fast-method.lisp ├── generic-functions.lisp ├── lambda-lists.lisp ├── optimize-function-call.lisp ├── packages.lisp ├── sbcl.lisp └── utilities.lisp └── test-suite ├── classes.lisp ├── fast-generic-functions-test-suite.asd ├── functions.lisp ├── generic-functions.lisp ├── methods.lisp └── packages.lisp /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2019-2020 Marco Heisig 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in 13 | all copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 21 | THE SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.org: -------------------------------------------------------------------------------- 1 | #+TITLE: Fast Generic Functions 2 | 3 | This library introduces /fast generic functions/, i.e., functions that 4 | behave just like regular generic functions, except that the can be sealed 5 | on certain domains. If the compiler can then statically detect that the 6 | arguments to a fast generic function fall within such a domain, it will 7 | perform a variety of optimizations. 8 | 9 | * Example 1 - Generic Find 10 | 11 | This example illustrates how one can define a (hopefully) fast method 12 | for finding items in a sequence. 13 | 14 | The first step is to define a generic function whose generic function class 15 | is =fast-generic-function=. 16 | 17 | #+BEGIN_SRC lisp 18 | (defgeneric generic-find (item sequence &key test) 19 | (:generic-function-class fast-generic-functions:fast-generic-function)) 20 | #+END_SRC 21 | 22 | Once this definition is loaded (and only then, so you shouldn't put the 23 | next snippets in the same file as the defgeneric form), it is possible to 24 | add methods to it in the usual way. 25 | 26 | #+BEGIN_SRC lisp 27 | (defmethod generic-find (item (list list) &key (test #'eql)) 28 | (and (member item list :test test) 29 | t)) 30 | 31 | (defmethod generic-find (item (vector vector) &key (test #'eql)) 32 | (cl:find item vector :test test)) 33 | 34 | (seal-domain #'generic-find '(t list)) 35 | (seal-domain #'generic-find '(t vector)) 36 | #+END_SRC 37 | 38 | The novelty are the two calls to =seal-domain=. These calls seal the 39 | specified part of the function domain, and at the same time install 40 | compiler optimizations for calls to that generic function. 41 | 42 | Whenever the compiler can detect that the arguments of a call to a fast 43 | generic function fall within such a sealed domain, the entire call can be 44 | optimized in a variety of ways. By default, the call to the fast generic 45 | function's discriminating function will be replaced by a direct call to a 46 | custom effective method function. This means that there will be zero 47 | overhead for determining the generic function's behavior. The following 48 | example illustrates this: 49 | 50 | #+BEGIN_SRC lisp 51 | (defun small-prime-p (x) 52 | (generic-find x '(2 3 5 7 11))) 53 | 54 | ;; The call to GENERIC-FIND should have been replaced by a direct call to 55 | ;; the appropriate effective method function. 56 | (disassemble #'small-prime-p) 57 | #+END_SRC 58 | 59 | It is even possible to inline the entire effective method into the call 60 | site. However, to avoid code bloat, this feature is disabled by default. 61 | To enable it, each method withing the sealed domain must contain an 62 | appropriate declaration, as shown in the next example. 63 | 64 | * Example 2 - Extensible Number Functions 65 | 66 | #+BEGIN_SRC lisp 67 | (defgeneric binary-+ (x y) 68 | (:generic-function-class fast-generic-function)) 69 | 70 | (defmethod binary-+ ((x number) (y number)) 71 | (declare (method-properties inlineable)) 72 | (+ x y)) 73 | 74 | (seal-domain #'binary-+ '(number number)) 75 | #+END_SRC 76 | 77 | It is easy to generalize such a binary function to a function that accepts 78 | any number of arguments: 79 | 80 | #+BEGIN_SRC lisp 81 | (defun generic-+ (&rest things) 82 | (cond ((null things) 0) 83 | ((null (rest things)) (first things)) 84 | (t (reduce #'binary-+ things)))) 85 | 86 | (define-compiler-macro generic-+ (&rest things) 87 | (cond ((null things) 0) 88 | ((null (rest things)) (first things)) 89 | (t (reduce (lambda (a b) `(binary-+ ,a ,b)) things)))) 90 | #+END_SRC 91 | 92 | With all this in place, we can use our =generic-+= function much like 93 | Common Lisp's built-in =+= without worrying about performance. The next 94 | code snippet shows that in fact, each call to =generic-+= is inlined and 95 | turned into a single =addss= instruction. 96 | 97 | #+BEGIN_SRC lisp 98 | (disassemble 99 | (compile nil 100 | '(lambda (x y z) 101 | (declare (single-float x y z)) 102 | (generic-+ x y z)))) 103 | 104 | ;; disassembly for (lambda (x y z)) 105 | ;; Size: 38 bytes. Origin: #x52FD9354 106 | ;; 54: 498B4510 mov RAX, [R13+16] 107 | ;; 58: 488945F8 mov [RBP-8], RAX 108 | ;; 5C: 0F28CC movaps XMM1, XMM4 109 | ;; 5F: F30F58CB addss XMM1, XMM3 110 | ;; 63: F30F58CA addss XMM1, XMM2 111 | ;; 67: 660F7ECA movd EDX, XMM1 112 | ;; 6B: 48C1E220 shl RDX, 32 113 | ;; 6F: 80CA19 or DL, 25 114 | ;; 72: 488BE5 mov RSP, RBP 115 | ;; 75: F8 clc 116 | ;; 76: 5D pop RBP 117 | ;; 77: C3 ret 118 | ;; 78: CC10 int3 16 119 | #+END_SRC 120 | 121 | Once a fast generic function has been sealed, it is not possible to add, 122 | remove, or redefine methods within the sealed domain. However, outside of 123 | the sealed domain, it behaves just like a standard generic function. That 124 | means we can extend its behavior, e.g., to allow addition of strings: 125 | 126 | #+BEGIN_SRC lisp 127 | (defmethod binary-+ ((x string) (y string)) 128 | (concatenate 'string x y)) 129 | 130 | (generic-+ "foo" "bar" "baz") 131 | ;; => "foobarbaz" 132 | #+END_SRC 133 | 134 | * Specializing on a User-Defined Class 135 | 136 | By default, only built-in classes and structure classes can appear as 137 | specializers of a method within a sealed domain of a fast generic function. 138 | However, it is also possible to define custom sealable classes. This 139 | example illustrates how. 140 | 141 | Since this example has plenty of dependencies (metaobject definition and 142 | use, generic function definition and method defintion, sealing and use of a 143 | sealed function), each of the following snippets of code should be put into 144 | its own file. 145 | 146 | In the first snippet, we define sealable standard class, that is both a 147 | sealable class and a standard class. 148 | 149 | #+BEGIN_SRC lisp 150 | (defclass sealable-standard-class 151 | (sealable-metaobjects:sealable-class standard-class) 152 | ()) 153 | 154 | (defmethod validate-superclass 155 | ((class sealable-standard-class) 156 | (superclass standard-class)) 157 | t) 158 | #+END_SRC 159 | 160 | In the next snippet, we define a class =foo= whose metaclass is our newly 161 | introduced =sealable-standard-class=. Because the implementation of fast 162 | generic functions uses literal instances to find an optimized effective 163 | method function at load time, each sealable class must also have a suitable 164 | method on =make-load-form=. 165 | 166 | #+BEGIN_SRC lisp 167 | (defclass foo () 168 | ((x :reader x :initarg :x)) 169 | (:metaclass sealable-standard-class)) 170 | 171 | (defmethod make-load-form ((foo foo) &optional env) 172 | (make-load-form-saving-slots foo :slot-names '(x) :environment env)) 173 | #+END_SRC 174 | 175 | In the next snippet, we define a fast generic function =op=. 176 | 177 | #+BEGIN_SRC lisp 178 | (defgeneric op (foo) 179 | (:generic-function-class fast-generic-functions:fast-generic-function)) 180 | #+END_SRC 181 | 182 | Once we have loaded the definition of =op=, we can add individual methods 183 | and seal some of them. In particular, we can add a method that specializes 184 | on the =foo= class. 185 | 186 | We could also have defined this method without =foo= being a sealable 187 | class, but then the call to =seal-domain= would have signaled an error. 188 | 189 | #+BEGIN_SRC lisp 190 | (defmethod op ((foo foo)) 191 | (* 2 (x foo))) 192 | 193 | (sealable-metaobjects:seal-domain #'op '(foo)) 194 | #+END_SRC 195 | 196 | Finally, we have everything in place for having optimized calls to =op= in 197 | the case where its argument is of type =foo=. 198 | 199 | #+BEGIN_SRC lisp 200 | (defun bar () 201 | (let ((foo (make-instance 'foo :x 42))) 202 | (declare (foo foo)) 203 | (op foo))) 204 | #+END_SRC 205 | 206 | If this example is too intimidating for you, please remember that you can 207 | always specialize fast methods on built-in classes (like integer and 208 | simple-vector) or structure classes (everything defined via =defstruct=). 209 | -------------------------------------------------------------------------------- /code/ccl.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:fast-generic-functions) 2 | 3 | (defmethod seal-domain :after 4 | ((fast-generic-function fast-generic-function) 5 | (domain list)) 6 | (values)) 7 | -------------------------------------------------------------------------------- /code/default.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:fast-generic-functions) 2 | 3 | (defmethod seal-domain :after 4 | ((fast-generic-function fast-generic-function) 5 | (domain list)) 6 | (setf (compiler-macro-function (generic-function-name fast-generic-function)) 7 | (fast-generic-function-compiler-macro fast-generic-function))) 8 | 9 | (defun fast-generic-function-compiler-macro (fast-generic-function) 10 | (lambda (form environment) 11 | (block compiler-macro 12 | (dolist (sealed-domain (sealed-domains fast-generic-function)) 13 | (dolist (scs (compute-static-call-signatures fast-generic-function sealed-domain)) 14 | (when (loop for argument in (rest form) 15 | for type in (static-call-signature-types scs) 16 | always (compiler-typep argument type environment)) 17 | (return-from compiler-macro 18 | `(funcall 19 | ,(optimize-function-call fast-generic-function static-call-signature) 20 | ,@(rest form)))))) 21 | form))) 22 | 23 | (defun compiler-typep (form type environment) 24 | "Try to statically determine whether FORM is provably of TYPE in the 25 | supplied ENVIRONMENT. A value of T means that the result of evaluating 26 | FORM is provably the supplied TYPE. A value of NIL means that the result 27 | of evaluating FORM may or may not be of the supplied TYPE." 28 | (or 29 | ;; In a first step, we try to abuse CONSTANTP to perform a portable 30 | ;; compile-time type query. To do so, we generate a form that is 31 | ;; constant if the type relation holds, and that diverges when the type 32 | ;; relation does not hold. Unfortunately, most implementations of 33 | ;; CONSTANTP are not sophisticated for our trick to work. But one day, 34 | ;; this might suddenly start working really well. 35 | (constantp 36 | `(unless (typep ,form ',type) 37 | (tagbody label (go label))) 38 | environment) 39 | ;; Our fallback solution. We may not be able to check the type relation 40 | ;; for arbitrary forms, but we certainly can check the type relation if 41 | ;; FORM is a constant. 42 | (and (constantp form) 43 | (typep (eval form) type environment)))) 44 | -------------------------------------------------------------------------------- /code/expand-effective-method-body.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:fast-generic-functions) 2 | 3 | (defun expand-effective-method-body 4 | (effective-method generic-function lambda-list) 5 | (let ((%no-primary-method (find-symbol "%NO-PRIMARY-METHOD" :sb-pcl))) 6 | (trivial-macroexpand-all:macroexpand-all 7 | `(let ((.gf. #',(generic-function-name generic-function))) 8 | (declare (ignorable .gf.)) 9 | #+sbcl(declare (sb-ext:disable-package-locks common-lisp:call-method)) 10 | #+sbcl(declare (sb-ext:disable-package-locks common-lisp:make-method)) 11 | #+sbcl(declare (sb-ext:disable-package-locks sb-pcl::check-applicable-keywords)) 12 | #+sbcl(declare (sb-ext:disable-package-locks ,%no-primary-method)) 13 | (macrolet 14 | (;; SBCL introduces explicit keyword argument checking into 15 | ;; the effective method. Since we do our own checking, we 16 | ;; can safely disable it. However, we touch the relevant 17 | ;; variables to prevent unused variable warnings. 18 | #+sbcl 19 | (sb-pcl::check-applicable-keywords (&rest args) 20 | (declare (ignore args)) 21 | `(progn sb-pcl::.valid-keys. sb-pcl::.keyargs-start. (values))) 22 | ;; SBCL introduces a magic form to report when there are no 23 | ;; primary methods. The problem is that this form contains a 24 | ;; reference to the literal generic function, which is not an 25 | ;; externalizable object. Our solution is to replace it with 26 | ;; something portable. 27 | #+sbcl 28 | ,@(when %no-primary-method 29 | `((,%no-primary-method (&rest args) 30 | (declare (ignore args)) 31 | `(apply #'no-primary-method .gf. ,@',(lambda-list-apply-arguments lambda-list)))))) 32 | ,(wrap-in-call-method-macrolet 33 | effective-method 34 | generic-function 35 | lambda-list)))))) 36 | 37 | (defun wrap-in-call-method-macrolet (form generic-function lambda-list) 38 | `(macrolet ((call-method (method &optional next-methods) 39 | (expand-call-method 40 | method 41 | next-methods 42 | ',lambda-list 43 | ',(class-name 44 | (generic-function-method-class generic-function))))) 45 | ,(wrap-in-reinitialize-arguments form lambda-list))) 46 | 47 | (defun wrap-in-reinitialize-arguments (form lambda-list) 48 | (let ((anonymized-lambda-list 49 | (anonymize-ordinary-lambda-list lambda-list))) 50 | `(flet ((reinitialize-arguments ,anonymized-lambda-list 51 | ,@(mapcar 52 | (lambda (place value) 53 | `(setf ,place ,value)) 54 | (lambda-list-variables lambda-list) 55 | (lambda-list-variables anonymized-lambda-list)))) 56 | (declare (ignorable #'reinitialize-arguments)) 57 | (declare (inline reinitialize-arguments)) 58 | ,form))) 59 | 60 | (defun expand-call-method (method next-methods lambda-list method-class) 61 | (wrap-in-next-methods 62 | (call-fast-method-lambda 63 | (coerce-to-fast-method method lambda-list method-class) 64 | lambda-list) 65 | next-methods 66 | lambda-list 67 | method-class)) 68 | 69 | (defun coerce-to-fast-method (method lambda-list method-class) 70 | (cond ((typep method 'fast-method) 71 | method) 72 | ((and (consp method) 73 | (eql (car method) 'make-method) 74 | (null (cddr method))) 75 | (make-instance method-class 76 | :lambda-list lambda-list 77 | :specializers (make-list (length (parse-ordinary-lambda-list lambda-list)) 78 | :initial-element (find-class 't)) 79 | :qualifiers '() 80 | :function #'values 81 | '.lambda. 82 | `(lambda ,lambda-list 83 | (declare (ignorable ,@(lambda-list-variables lambda-list))) 84 | ,(second method)))) 85 | (t 86 | (error "Cannot turn ~S into an inlineable method." 87 | method)))) 88 | 89 | (defun wrap-in-next-methods (form next-methods lambda-list method-class) 90 | (if (null next-methods) 91 | `(flet ((next-method-p () nil) 92 | (call-next-method () 93 | (apply 94 | #'no-next-method 95 | .gf. 96 | (class-prototype (find-class ',method-class)) 97 | ,@(lambda-list-apply-arguments lambda-list)))) 98 | (declare (ignorable #'next-method-p #'call-next-method)) 99 | ,form) 100 | (wrap-in-next-methods 101 | `(flet ((next-method-p () t) 102 | (call-next-method (&rest args) 103 | (unless (null args) 104 | (apply #'reinitialize-arguments args)) 105 | (call-method ,(first next-methods) ,(rest next-methods)))) 106 | (declare (ignorable #'next-method-p #'call-next-method)) 107 | ,form) 108 | (rest next-methods) 109 | lambda-list 110 | method-class))) 111 | 112 | (defun call-fast-method-lambda (method lambda-list) 113 | (multiple-value-bind (g-required g-optional g-rest-var g-keyword) 114 | (parse-ordinary-lambda-list lambda-list) 115 | (multiple-value-bind (m-required m-optional m-rest-var m-keyword) 116 | (parse-ordinary-lambda-list (method-lambda-list method)) 117 | ;; Assert that the method has arguments that are congruent to those 118 | ;; of the corresponding generic function. 119 | (assert (or (= (length g-required) 120 | (length m-required)))) 121 | (assert (= (length g-optional) 122 | (length m-optional))) 123 | (when (null g-rest-var) 124 | (assert (null m-rest-var))) 125 | `(funcall 126 | ,(fast-method-lambda method) 127 | ;; Required arguments. 128 | ,@(mapcar #'required-info-variable g-required) 129 | ;; Optional arguments. 130 | ,@(loop for g-info in g-optional 131 | for m-info in m-optional 132 | append 133 | (if (null (optional-info-suppliedp g-info)) 134 | `(,(optional-info-variable g-info)) 135 | (let ((value 136 | `(if ,(optional-info-suppliedp g-info) 137 | ,(optional-info-variable g-info) 138 | ,(optional-info-initform m-info)))) 139 | (if (null (optional-info-suppliedp m-info)) 140 | `(,value) 141 | `(,value ,(optional-info-suppliedp g-info)))))) 142 | ;; The rest argument. 143 | ,@(if (null m-rest-var) 144 | `() 145 | `(,g-rest-var)) 146 | ;; Keyword arguments. 147 | ,@(loop for m-info in m-keyword 148 | for g-info = (find (keyword-info-keyword m-info) g-keyword 149 | :key #'keyword-info-keyword) 150 | append 151 | (if (null (keyword-info-suppliedp g-info)) 152 | `(,(keyword-info-variable g-info)) 153 | (let ((value 154 | `(if ,(keyword-info-suppliedp g-info) 155 | ,(keyword-info-variable g-info) 156 | ,(keyword-info-initform m-info)))) 157 | (if (null (keyword-info-suppliedp m-info)) 158 | `(,value) 159 | `(,value ,(keyword-info-suppliedp g-info)))))))))) 160 | 161 | -------------------------------------------------------------------------------- /code/fast-generic-function.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:fast-generic-functions) 2 | 3 | (defclass fast-generic-function (sealable-standard-generic-function) 4 | ((%full-effective-method-cache :initform '() :accessor full-effective-method-cache) 5 | (%flat-effective-method-cache :initform '() :accessor flat-effective-method-cache)) 6 | (:default-initargs 7 | :method-class (find-class 'fast-method)) 8 | (:metaclass funcallable-standard-class)) 9 | 10 | (defmethod compute-effective-method-function 11 | ((fgf fast-generic-function) effective-method options) 12 | (let ((lambda-list 13 | (anonymize-ordinary-lambda-list 14 | ;; Unfortunately, we don't know the list of applicable methods 15 | ;; anymore at this stage. So instead, we consider all methods 16 | ;; applicable. 17 | (compute-effective-method-lambda-list fgf (generic-function-methods fgf))))) 18 | (compile 19 | nil 20 | `(lambda ,lambda-list 21 | ,(expand-effective-method-body effective-method fgf lambda-list))))) 22 | -------------------------------------------------------------------------------- /code/fast-generic-functions.asd: -------------------------------------------------------------------------------- 1 | (defsystem "fast-generic-functions" 2 | :author "Marco Heisig " 3 | :description "Seal your generic functions for an extra boost in performance." 4 | :license "MIT" 5 | :depends-on 6 | ("closer-mop" 7 | "trivial-macroexpand-all" 8 | "sealable-metaobjects") 9 | 10 | :in-order-to ((test-op (load-op "fast-generic-functions-test-suite"))) 11 | 12 | :serial t 13 | :components 14 | ((:file "packages") 15 | (:file "utilities") 16 | (:file "lambda-lists") 17 | (:file "expand-effective-method-body") 18 | (:file "generic-functions") 19 | (:file "fast-method") 20 | (:file "fast-generic-function") 21 | (:file "optimize-function-call") 22 | (:file "default" :if-feature (:not (:or :sbcl :ccl))) 23 | (:file "sbcl" :if-feature :sbcl) 24 | (:file "ccl" :if-feature :ccl))) 25 | -------------------------------------------------------------------------------- /code/fast-method.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:fast-generic-functions) 2 | 3 | (defclass fast-method (potentially-sealable-standard-method) 4 | ((%lambda 5 | :initarg .lambda. 6 | :reader fast-method-lambda 7 | :initform (required-argument '.lambda.)))) 8 | 9 | (defmethod validate-method-property 10 | ((method fast-method) (property (eql 'inlineable))) 11 | t) 12 | 13 | (defmethod make-method-lambda :around 14 | ((gf sealable-standard-generic-function) 15 | (fast-method fast-method) 16 | lambda 17 | environment) 18 | (multiple-value-bind (method-lambda initargs) 19 | (call-next-method) 20 | (values 21 | method-lambda 22 | (list* 23 | '.lambda. 24 | (make-fast-method-lambda gf fast-method lambda environment) 25 | initargs)))) 26 | 27 | (defun make-fast-method-lambda 28 | (generic-function method lambda environment) 29 | (declare (ignore method)) 30 | (destructuring-bind (lambda-symbol lambda-list &rest body) lambda 31 | (assert (eql lambda-symbol 'lambda)) 32 | (multiple-value-bind (required optional rest-var keyword allow-other-keys-p auxiliary) 33 | (parse-ordinary-lambda-list lambda-list) 34 | (multiple-value-bind (forms declarations) 35 | (parse-body body) 36 | (let ((partially-flattened-lambda-list 37 | `(,@(lambda-list-variables 38 | (unparse-ordinary-lambda-list 39 | required optional rest-var keyword allow-other-keys-p '())) 40 | ,@(unparse-ordinary-lambda-list '() '() nil '() nil auxiliary)))) 41 | (trivial-macroexpand-all:macroexpand-all 42 | `(lambda ,partially-flattened-lambda-list 43 | (declare (ignorable ,@(mapcar #'required-info-variable required))) 44 | ,@declarations 45 | (block ,(block-name (generic-function-name generic-function)) 46 | ,@forms)) 47 | environment)))))) 48 | -------------------------------------------------------------------------------- /code/generic-functions.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:fast-generic-functions) 2 | 3 | (defgeneric optimize-function-call (generic-function static-call-signature)) 4 | 5 | (defgeneric no-primary-method (generic-function &rest arguments) 6 | (:method ((generic-function generic-function) &rest arguments) 7 | (error "~@" 9 | generic-function arguments))) 10 | 11 | -------------------------------------------------------------------------------- /code/lambda-lists.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:fast-generic-functions) 2 | 3 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 4 | ;;; 5 | ;;; Lambda List Parsing 6 | 7 | (deftype local-variable () 8 | '(and symbol (not (satisfies constantp)))) 9 | 10 | (defclass required-info () 11 | ((%variable 12 | :initarg :variable 13 | :reader required-info-variable 14 | :type local-variable 15 | :initform (required-argument :variable)))) 16 | 17 | (defclass optional-info () 18 | ((%variable 19 | :initarg :variable 20 | :reader optional-info-variable 21 | :type local-variable 22 | :initform (required-argument :variable)) 23 | (%initform 24 | :initarg :initform 25 | :reader optional-info-initform 26 | :initform nil) 27 | (%suppliedp 28 | :initarg :suppliedp 29 | :reader optional-info-suppliedp 30 | :type (or null local-variable) 31 | :initform nil))) 32 | 33 | (defclass keyword-info () 34 | ((%keyword 35 | :initarg :keyword 36 | :reader keyword-info-keyword 37 | :type keyword 38 | :initform (required-argument :keyword)) 39 | (%variable 40 | :initarg :variable 41 | :reader keyword-info-variable 42 | :type local-variable 43 | :initform (required-argument :variable)) 44 | (%initform 45 | :initarg :initform 46 | :reader keyword-info-initform 47 | :initform nil) 48 | (%suppliedp 49 | :initarg :suppliedp 50 | :reader keyword-info-suppliedp 51 | :type (or null local-variable) 52 | :initform nil))) 53 | 54 | (defclass auxiliary-info () 55 | ((%variable 56 | :initarg :variable 57 | :reader auxiliary-info-variable 58 | :type local-variable 59 | :initform (required-argument :variable)) 60 | (%initform 61 | :initarg :initform 62 | :reader auxiliary-info-initform 63 | :initform nil))) 64 | 65 | (defun parse-ordinary-lambda-list (lambda-list) 66 | "Returns six values: 67 | 68 | 1. A list of REQUIRED-INFO instances, one for each required argument. 69 | 70 | 2. A list of OPTIONAL-INFO instances, one for each optional argument. 71 | 72 | 3. The name of the rest variable, or NIL, if there is none. 73 | 74 | 4. A list of KEYWORD-INFO instances, one for each keyword argument. 75 | 76 | 5. A boolean, indicating whether &allow-other-keys is present. 77 | 78 | 6. A list of AUXILIARY-INFO instances, one for each auxiliary argument. 79 | 80 | Can parse all but specialized lambda lists. 81 | " 82 | (let ((required '()) 83 | (optional '()) 84 | (keyword '()) 85 | (auxiliary '()) 86 | (rest-var nil) 87 | (allow-other-keys-p nil)) 88 | (labels ((fail () 89 | (error "Malformed lambda list: ~S" lambda-list)) 90 | (parse-required (lambda-list) 91 | (unless (endp lambda-list) 92 | (let ((item (first lambda-list))) 93 | (case item 94 | (&optional (parse-&optional (rest lambda-list))) 95 | (&rest (parse-&rest (rest lambda-list))) 96 | (&key (parse-&key (rest lambda-list))) 97 | (&aux (parse-&aux (rest lambda-list))) 98 | (#.(set-difference lambda-list-keywords '(&optional &rest &key &aux)) 99 | (fail)) 100 | (otherwise 101 | (push (parse-reqired-item item) required) 102 | (parse-required (rest lambda-list))))))) 103 | (parse-&optional (lambda-list) 104 | (unless (endp lambda-list) 105 | (let ((item (first lambda-list))) 106 | (case item 107 | (&rest (parse-&rest (rest lambda-list))) 108 | (&key (parse-&key (rest lambda-list))) 109 | (&aux (parse-&aux (rest lambda-list))) 110 | (#.(set-difference lambda-list-keywords '(&rest &key &aux)) 111 | (fail)) 112 | (otherwise 113 | (push (parse-optional-item item) optional) 114 | (parse-&optional (rest lambda-list))))))) 115 | (parse-&rest (lambda-list) 116 | (unless (consp lambda-list) 117 | (fail)) 118 | (let ((item (first lambda-list))) 119 | (unless (symbolp item) 120 | (fail)) 121 | (unless (null rest-var) 122 | (fail)) 123 | (setf rest-var item) 124 | (unless (endp (rest lambda-list)) 125 | (case (first (rest lambda-list)) 126 | (&key (parse-&key (rest (rest lambda-list)))) 127 | (&aux (parse-&aux (rest (rest lambda-list)))) 128 | (otherwise (fail)))))) 129 | (parse-&key (lambda-list) 130 | (unless (endp lambda-list) 131 | (let ((item (first lambda-list))) 132 | (case item 133 | (&allow-other-keys (parse-&allow-other-keys (rest lambda-list))) 134 | (&aux (parse-&aux (rest lambda-list))) 135 | (#.(set-difference lambda-list-keywords '(&allow-other-keys &aux)) 136 | (fail)) 137 | (otherwise 138 | (push (parse-keyword-item item) keyword) 139 | (parse-&key (rest lambda-list))))))) 140 | (parse-&allow-other-keys (lambda-list) 141 | (setf allow-other-keys-p t) 142 | (unless (endp lambda-list) 143 | (case (first lambda-list) 144 | (&aux (parse-&aux (rest lambda-list))) 145 | (otherwise 146 | (fail))))) 147 | (parse-&aux (lambda-list) 148 | (unless (endp lambda-list) 149 | (let ((item (first lambda-list))) 150 | (case item 151 | (#.lambda-list-keywords (fail)) 152 | (otherwise 153 | (push (parse-auxiliary-item item) auxiliary) 154 | (parse-&aux (rest lambda-list)))))))) 155 | (parse-required lambda-list)) 156 | (values 157 | (nreverse required) 158 | (nreverse optional) 159 | rest-var 160 | (nreverse keyword) 161 | allow-other-keys-p 162 | (nreverse auxiliary)))) 163 | 164 | (defun parse-reqired-item (item) 165 | (unless (typep item 'local-variable) 166 | (error "Not a valid lambda list variable: ~S" 167 | item)) 168 | (make-instance 'required-info 169 | :variable item)) 170 | 171 | (defun parse-optional-item (item) 172 | (typecase item 173 | (local-variable 174 | (make-instance 'optional-info 175 | :variable item)) 176 | ((cons local-variable null) 177 | (make-instance 'optional-info 178 | :variable (first item))) 179 | ((cons local-variable (cons t null)) 180 | (make-instance 'optional-info 181 | :variable (first item) 182 | :initform (second item))) 183 | ((cons local-variable (cons t (cons local-variable null))) 184 | (make-instance 'optional-info 185 | :variable (first item) 186 | :initform (second item) 187 | :suppliedp (third item))) 188 | (t (error "Invalid &optional lambda list item: ~S" 189 | item)))) 190 | 191 | (defun parse-keyword-item (item) 192 | (labels ((fail () 193 | (error "Invalid &key lambda list item: ~S" 194 | item)) 195 | (parse-keyword-var (item) 196 | (etypecase item 197 | (symbol 198 | (values (intern (symbol-name item) :keyword) 199 | item)) 200 | ((cons symbol null) 201 | (values (intern (symbol-name (first item)) :keyword) 202 | (first item))) 203 | ((cons keyword (cons symbol null)) 204 | (values (first item) 205 | (second item))) 206 | (t (fail))))) 207 | (typecase item 208 | (local-variable 209 | (make-instance 'keyword-info 210 | :variable item 211 | :keyword (intern (symbol-name item) :keyword))) 212 | ((cons t null) 213 | (multiple-value-bind (keyword variable) 214 | (parse-keyword-var (first item)) 215 | (make-instance 'keyword-info 216 | :variable variable 217 | :keyword keyword))) 218 | ((cons t (cons t null)) 219 | (multiple-value-bind (keyword variable) 220 | (parse-keyword-var (first item)) 221 | (make-instance 'keyword-info 222 | :variable variable 223 | :keyword keyword 224 | :initform (second item)))) 225 | ((cons t (cons t (cons local-variable null))) 226 | (multiple-value-bind (keyword variable) 227 | (parse-keyword-var (first item)) 228 | (make-instance 'keyword-info 229 | :variable variable 230 | :keyword keyword 231 | :initform (second item) 232 | :suppliedp (third item)))) 233 | (t (fail))))) 234 | 235 | (defun parse-auxiliary-item (item) 236 | (typecase item 237 | (local-variable 238 | (make-instance 'auxiliary-info 239 | :variable item)) 240 | ((cons local-variable null) 241 | (make-instance 'auxiliary-info 242 | :variable (first item))) 243 | ((cons local-variable (cons t null)) 244 | (make-instance 'auxiliary-info 245 | :variable (first item) 246 | :initform (second item))) 247 | (t (error "Invalid &aux lambda list item: ~S" 248 | item)))) 249 | 250 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 251 | ;;; 252 | ;;; Lambda List Unparsing 253 | 254 | (defun unparse-ordinary-lambda-list 255 | (required optional rest-var keyword allow-other-keys-p auxiliary) 256 | (append 257 | (unparse-required required) 258 | (unparse-optional optional) 259 | (unparse-rest rest-var) 260 | (unparse-keyword keyword allow-other-keys-p) 261 | (unparse-auxiliary auxiliary))) 262 | 263 | (defun unparse-required (required) 264 | (mapcar 265 | (lambda (info) 266 | (required-info-variable info)) 267 | required)) 268 | 269 | (defun unparse-optional (optional) 270 | (if (null optional) 271 | `() 272 | `(&optional 273 | ,@(mapcar 274 | (lambda (info) 275 | `(,(optional-info-variable info) 276 | ,(optional-info-initform info) 277 | ,@(if (optional-info-suppliedp info) 278 | `(,(optional-info-suppliedp info)) 279 | `()))) 280 | optional)))) 281 | 282 | (defun unparse-keyword (keyword allow-other-keys-p) 283 | (if (and (null keyword) 284 | (not allow-other-keys-p)) 285 | `() 286 | `(&key 287 | ,@(mapcar 288 | (lambda (info) 289 | `((,(keyword-info-keyword info) ,(keyword-info-variable info)) 290 | ,(keyword-info-initform info) 291 | ,@(if (keyword-info-suppliedp info) 292 | `(,(keyword-info-suppliedp info)) 293 | `()))) 294 | keyword) 295 | ,@(if allow-other-keys-p 296 | '(&allow-other-keys) 297 | '())))) 298 | 299 | (defun unparse-rest (rest-var) 300 | (if (null rest-var) 301 | `() 302 | `(&rest ,rest-var))) 303 | 304 | (defun unparse-auxiliary (auxiliary) 305 | (if (null auxiliary) 306 | `() 307 | `(&aux 308 | ,@(mapcar 309 | (lambda (info) 310 | (list (auxiliary-info-variable info) 311 | (auxiliary-info-initform info))) 312 | auxiliary)))) 313 | 314 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 315 | ;;; 316 | ;;; Lambda List Info Anonymization 317 | 318 | (defun anonymize-ordinary-lambda-list (lambda-list) 319 | (multiple-value-bind (required optional rest-var keyword allow-other-keys-p auxiliary) 320 | (parse-ordinary-lambda-list lambda-list) 321 | (unparse-ordinary-lambda-list 322 | (mapcar #'anonymize-required-info required) 323 | (mapcar #'anonymize-optional-info optional) 324 | (if (null rest-var) 325 | nil 326 | (gensymify rest-var)) 327 | (mapcar #'anonymize-keyword-info keyword) 328 | allow-other-keys-p 329 | (mapcar #'anonymize-auxiliary-info auxiliary)))) 330 | 331 | (defun anonymize-required-info (info) 332 | (make-instance 'required-info 333 | :variable (gensymify (required-info-variable info)))) 334 | 335 | (defun anonymize-optional-info (info) 336 | (make-instance 'optional-info 337 | :variable (gensymify (optional-info-variable info)) 338 | :initform (optional-info-initform info) 339 | :suppliedp (if (optional-info-suppliedp info) 340 | (gensymify (optional-info-suppliedp info)) 341 | nil))) 342 | 343 | (defun anonymize-keyword-info (info) 344 | (make-instance 'keyword-info 345 | :variable (gensymify (keyword-info-variable info)) 346 | :keyword (keyword-info-keyword info) 347 | :initform (keyword-info-initform info) 348 | :suppliedp (if (keyword-info-suppliedp info) 349 | (gensymify (keyword-info-suppliedp info)) 350 | nil))) 351 | 352 | (defun anonymize-auxiliary-info (info) 353 | (make-instance 'auxiliary-info 354 | :variable (gensymify (auxiliary-info-variable info)) 355 | :initform (auxiliary-info-initform info))) 356 | 357 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 358 | ;;; 359 | ;;; Miscellaneous 360 | 361 | (defun normalize-ordinary-lambda-list (lambda-list) 362 | (multiple-value-call #'unparse-ordinary-lambda-list 363 | (parse-ordinary-lambda-list lambda-list))) 364 | 365 | (defun lambda-list-variables (lambda-list) 366 | (multiple-value-bind (required optional rest-var keyword allow-other-keys-p auxiliary) 367 | (parse-ordinary-lambda-list lambda-list) 368 | (declare (ignore allow-other-keys-p)) 369 | (let ((variables '())) 370 | (dolist (info required) 371 | (push (required-info-variable info) variables)) 372 | (dolist (info optional) 373 | (push (optional-info-variable info) variables) 374 | (when (optional-info-suppliedp info) 375 | (push (optional-info-suppliedp info) variables))) 376 | (unless (null rest-var) 377 | (push rest-var variables)) 378 | (dolist (info keyword) 379 | (push (keyword-info-variable info) variables) 380 | (when (keyword-info-suppliedp info) 381 | (push (keyword-info-suppliedp info) variables))) 382 | (dolist (info auxiliary) 383 | (push (auxiliary-info-variable info) variables)) 384 | (nreverse variables)))) 385 | 386 | (defun lambda-list-apply-arguments (lambda-list) 387 | (multiple-value-bind (required optional rest-var keyword) 388 | (parse-ordinary-lambda-list lambda-list) 389 | (append 390 | (mapcar #'required-info-variable required) 391 | (mapcar #'optional-info-variable optional) 392 | (if rest-var 393 | `(,rest-var) 394 | `(,@(loop for info in keyword 395 | collect (keyword-info-keyword info) 396 | collect (keyword-info-variable info)) 397 | '()))))) 398 | -------------------------------------------------------------------------------- /code/optimize-function-call.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:fast-generic-functions) 2 | 3 | (defmethod optimize-function-call :around 4 | ((fast-generic-function fast-generic-function) 5 | (static-call-signature static-call-signature)) 6 | (call-next-method)) 7 | 8 | (defmethod optimize-function-call 9 | ((fast-generic-function fast-generic-function) 10 | (static-call-signature static-call-signature)) 11 | (let ((applicable-methods 12 | (compute-applicable-methods 13 | fast-generic-function 14 | (static-call-signature-prototypes static-call-signature)))) 15 | (cond (;; Inline the entire effective method. 16 | (every #'inlineable-method-p applicable-methods) 17 | (effective-method-lambda fast-generic-function static-call-signature nil)) 18 | ;; Inline only the optional/keyword parsing step. 19 | ((and (externalizable-object-p static-call-signature) 20 | (intersection (generic-function-lambda-list fast-generic-function) 21 | '(&optional &key &rest))) 22 | (let ((lambda-list 23 | (anonymize-ordinary-lambda-list 24 | (compute-effective-method-lambda-list 25 | fast-generic-function applicable-methods)))) 26 | `(lambda ,lambda-list 27 | (funcall 28 | (load-time-value 29 | (the function 30 | (lookup-flat-effective-method 31 | #',(generic-function-name fast-generic-function) 32 | ',static-call-signature))) 33 | ,@(lambda-list-variables lambda-list))))) 34 | ;; Eliminate the dispatch function. 35 | ((externalizable-object-p static-call-signature) 36 | `(lambda (&rest args) 37 | (apply 38 | (load-time-value 39 | (the function 40 | (lookup-full-effective-method 41 | #',(generic-function-name fast-generic-function) 42 | ',static-call-signature))) 43 | args))) 44 | ;; Give up. 45 | (t nil)))) 46 | 47 | (defun inlineable-method-p (method) 48 | (member 'inlineable (method-properties method))) 49 | 50 | (defun effective-method-lambda 51 | (generic-function static-call-signature flatten-arguments) 52 | (let* ((applicable-methods 53 | (compute-applicable-methods 54 | generic-function 55 | (static-call-signature-prototypes static-call-signature))) 56 | (effective-method-lambda-list 57 | (compute-effective-method-lambda-list 58 | generic-function applicable-methods)) 59 | (anonymized-lambda-list 60 | (anonymize-ordinary-lambda-list effective-method-lambda-list))) 61 | `(lambda ,(if flatten-arguments 62 | (lambda-list-variables anonymized-lambda-list) 63 | anonymized-lambda-list) 64 | (declare (optimize (safety 0))) 65 | ,@(loop for type in (static-call-signature-types static-call-signature) 66 | for argument in anonymized-lambda-list 67 | collect `(declare (ignorable ,argument)) 68 | collect `(declare (type ,type ,argument))) 69 | (locally (declare (optimize (safety 1))) 70 | ,(expand-effective-method-body 71 | (compute-effective-method 72 | generic-function 73 | (generic-function-method-combination generic-function) 74 | applicable-methods) 75 | generic-function 76 | anonymized-lambda-list))))) 77 | 78 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 79 | ;;; 80 | ;;; Computing the Effective Method Lambda List 81 | 82 | (defun compute-effective-method-lambda-list (generic-function applicable-methods) 83 | (multiple-value-bind (required optional rest-var keyword allow-other-keys) 84 | (parse-ordinary-lambda-list (generic-function-lambda-list generic-function)) 85 | (let ((method-parses 86 | (mapcar 87 | (lambda (method) 88 | (multiple-value-list 89 | (parse-ordinary-lambda-list 90 | (method-lambda-list method)))) 91 | applicable-methods))) 92 | (unparse-ordinary-lambda-list 93 | (merge-required-infos required (mapcar #'first method-parses)) 94 | (merge-optional-infos optional (mapcar #'second method-parses)) 95 | rest-var 96 | (merge-keyword-infos keyword (mapcar #'fourth method-parses)) 97 | (merge-allow-other-keys allow-other-keys (mapcar #'fifth method-parses)) 98 | '())))) 99 | 100 | (defun merge-required-infos (g-required m-requireds) 101 | (dolist (m-required m-requireds g-required) 102 | (assert (= (length m-required) 103 | (length g-required))))) 104 | 105 | (defun merge-optional-infos (g-optional m-optionals) 106 | (let ((n (length g-optional))) 107 | (dolist (m-optional m-optionals) 108 | (assert (= (length m-optional) n))) 109 | (unless (zerop n) 110 | (loop for g-info in g-optional 111 | for m-infos in (apply #'mapcar #'list m-optionals) 112 | collect 113 | ;; Now we have two cases - the one is that at least one method 114 | ;; cares about the suppliedp flag, the other one is that no 115 | ;; method cares. Even if a method doesn't reference the 116 | ;; suppliedp flag itself, it may still need it to decide whether 117 | ;; to supply its initform or not. Because of this, the suppliedp 118 | ;; parameter can only be discarded globally when the initforms of 119 | ;; all methods are constant and equal. 120 | (let ((global-initform (optional-info-initform (first m-infos))) 121 | (no-one-cares (not (optional-info-suppliedp (first m-infos))))) 122 | (dolist (m-info m-infos) 123 | (with-accessors ((variable optional-info-variable) 124 | (initform optional-info-initform) 125 | (suppliedp optional-info-suppliedp)) 126 | m-info 127 | (unless (and (constantp initform) 128 | (equal initform global-initform) 129 | (not suppliedp)) 130 | (setf no-one-cares nil)))) 131 | (if no-one-cares 132 | (make-instance 'optional-info 133 | :variable (optional-info-variable g-info) 134 | :initform global-initform) 135 | (make-instance 'optional-info 136 | :variable (optional-info-variable g-info) 137 | :initform nil 138 | :suppliedp (optional-info-suppliedp g-info)))))))) 139 | 140 | (defun merge-keyword-infos (g-keyword m-keywords) 141 | ;; First we assemble an alist whose keys are keywords and whose values 142 | ;; are all method keyword info objects that read this keyword. 143 | (let ((alist '())) 144 | (dolist (g-info g-keyword) 145 | (pushnew (list (keyword-info-keyword g-info)) alist)) 146 | (dolist (m-keyword m-keywords) 147 | (dolist (m-info m-keyword) 148 | (let* ((key (keyword-info-keyword m-info)) 149 | (entry (assoc key alist))) 150 | (if (consp entry) 151 | (push m-info (cdr entry)) 152 | (push (list key m-info) alist))))) 153 | (loop for (key . m-infos) in alist 154 | collect 155 | ;; Merging keyword info objects is handled just like in the case 156 | ;; of optional info objects above. 157 | (let ((global-initform (keyword-info-initform (first m-infos))) 158 | (no-one-cares (not (keyword-info-suppliedp (first m-infos)))) 159 | ;; Not actually g-info, but we need some place to grab a 160 | ;; variable name form. 161 | (g-info (or (find key g-keyword :key #'keyword-info-keyword) 162 | (first m-infos)))) 163 | (dolist (m-info m-infos) 164 | (with-accessors ((initform keyword-info-initform) 165 | (suppliedp keyword-info-suppliedp)) 166 | m-info 167 | (unless (and (constantp initform) 168 | (equal initform global-initform) 169 | (not suppliedp)) 170 | (setf no-one-cares nil)))) 171 | (if no-one-cares 172 | (make-instance 'keyword-info 173 | :keyword key 174 | :variable (keyword-info-variable g-info) 175 | :initform global-initform) 176 | (make-instance 'keyword-info 177 | :keyword key 178 | :variable (keyword-info-variable g-info) 179 | :initform nil 180 | :suppliedp (or (keyword-info-suppliedp g-info) 181 | (gensymify "SUPPLIEDP")))))))) 182 | 183 | (defun merge-allow-other-keys (g-allow-other-keys m-allow-other-keys-list) 184 | (reduce 185 | (lambda (a b) (or a b)) 186 | m-allow-other-keys-list 187 | :initial-value g-allow-other-keys)) 188 | 189 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 190 | ;;; 191 | ;;; Effective Method Lookup 192 | 193 | (declaim (ftype (function * function) lookup-full-effective-method)) 194 | (declaim (ftype (function * function) lookup-flat-effective-method)) 195 | 196 | (defun lookup-full-effective-method 197 | (generic-function static-call-signature) 198 | (with-accessors ((alist full-effective-method-cache)) generic-function 199 | (let* ((key (static-call-signature-types static-call-signature)) 200 | (entry (assoc key alist :test #'equal))) 201 | (if (consp entry) 202 | (cdr entry) 203 | (let ((fn (compile nil (effective-method-lambda 204 | generic-function 205 | static-call-signature 206 | nil)))) 207 | (push (cons key fn) alist) 208 | fn))))) 209 | 210 | (defun lookup-flat-effective-method 211 | (generic-function static-call-signature) 212 | (with-accessors ((alist flat-effective-method-cache)) generic-function 213 | (let* ((key (static-call-signature-types static-call-signature)) 214 | (entry (assoc key alist :test #'equal))) 215 | (if (consp entry) 216 | (cdr entry) 217 | (let ((fn (compile nil (effective-method-lambda 218 | generic-function 219 | static-call-signature 220 | t)))) 221 | (push (cons key fn) alist) 222 | fn))))) 223 | -------------------------------------------------------------------------------- /code/packages.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-user) 2 | 3 | (defpackage #:fast-generic-functions 4 | (:use 5 | #:closer-common-lisp) 6 | 7 | (:import-from 8 | #:sealable-metaobjects 9 | #:method-properties 10 | #:validate-method-property 11 | #:seal-domain 12 | #:domain 13 | #:sealed-domains 14 | #:compute-static-call-signatures 15 | #:static-call-signature 16 | #:static-call-signature-types 17 | #:static-call-signature-prototypes 18 | #:externalizable-object-p 19 | #:sealable-class 20 | #:sealable-generic-function 21 | #:sealable-standard-generic-function 22 | #:potentially-sealable-method 23 | #:potentially-sealable-standard-method) 24 | 25 | (:export 26 | #:method-properties 27 | #:seal-domain 28 | #:validate-method-property 29 | #:fast-generic-function 30 | #:fast-method 31 | #:inlineable 32 | #:no-primary-method)) 33 | -------------------------------------------------------------------------------- /code/sbcl.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:fast-generic-functions) 2 | 3 | (defmethod seal-domain :after 4 | ((fast-generic-function fast-generic-function) 5 | (domain domain)) 6 | (let ((name (generic-function-name fast-generic-function))) 7 | ;; Ensure that the function is known. 8 | (unless (sb-c::info :function :info name) 9 | (eval `(sb-c:defknown ,name * * ()))) 10 | ;; Create an IR1-transform for each static call signature. 11 | (dolist (static-call-signature (compute-static-call-signatures fast-generic-function domain)) 12 | (with-accessors ((types static-call-signature-types) 13 | (prototypes static-call-signature-prototypes)) 14 | static-call-signature 15 | (eval 16 | `(sb-c:deftransform ,name ((&rest args) (,@types &rest t)) 17 | (or (optimize-function-call #',name ',static-call-signature) 18 | (sb-c::give-up-ir1-transform)))))))) 19 | -------------------------------------------------------------------------------- /code/utilities.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:fast-generic-functions) 2 | 3 | (defun parse-body (body) 4 | (let ((declarations '()) 5 | (documentation nil)) 6 | (loop for (item . rest) on body do 7 | (cond ((and (stringp item) (consp rest)) 8 | (if (not documentation) 9 | (setf documentation item) 10 | (error "Multiple documentation strings in body: ~%~S~% and~%~S." 11 | documentation item))) 12 | ((and (listp item) (eq (first item) 'declare)) 13 | (push item declarations)) 14 | (t 15 | (return-from parse-body 16 | (values 17 | (list* item rest) 18 | (reverse declarations) 19 | documentation))))))) 20 | 21 | (defun block-name (function-name) 22 | (etypecase function-name 23 | ((and symbol (not null)) function-name) 24 | ((cons (eql setf) (cons symbol null)) (second function-name)))) 25 | 26 | (defun required-argument (name) 27 | (error "Required argument: ~S" name)) 28 | 29 | (defgeneric gensymify (object) 30 | (:method ((string string)) 31 | (gensym (string-upcase (concatenate 'string string "-")))) 32 | (:method ((symbol symbol)) 33 | (if (null (symbol-package symbol)) 34 | ;; If we are dealing with uninterned symbols, we strip any 35 | ;; non-alphanumeric characters. This has the effect that 36 | ;; gensymification of gensyms doesn't just add more and more 37 | ;; digits and hypens. 38 | (let ((name (symbol-name symbol))) 39 | (gensymify (subseq name 0 (1+ (position-if #'alpha-char-p name :from-end t))))) 40 | (gensymify (symbol-name symbol)))) 41 | (:method ((object t)) 42 | (gensymify (princ-to-string object)))) 43 | 44 | (defun null-lexical-environement-p (environment) 45 | (declare (ignorable environment)) 46 | (or (null environment) 47 | #+sbcl (sb-c::null-lexenv-p environment))) 48 | -------------------------------------------------------------------------------- /test-suite/classes.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:fast-generic-functions-test-suite) 2 | 3 | (defstruct point 4 | (x nil :type number) 5 | (y nil :type number)) 6 | -------------------------------------------------------------------------------- /test-suite/fast-generic-functions-test-suite.asd: -------------------------------------------------------------------------------- 1 | (defsystem "fast-generic-functions-test-suite" 2 | :depends-on ("closer-mop" "fast-generic-functions") 3 | 4 | :serial t 5 | :components 6 | ((:file "packages") 7 | (:file "generic-functions") 8 | (:file "classes") 9 | (:file "methods") 10 | (:file "functions"))) 11 | -------------------------------------------------------------------------------- /test-suite/functions.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:fast-generic-functions-test-suite) 2 | 3 | (defun generic-+ (&rest things) 4 | (cond ((null things) 0) 5 | ((null (rest things)) (first things)) 6 | (t (reduce #'generic-binary-+ things)))) 7 | 8 | (define-compiler-macro generic-+ (&rest things) 9 | (cond ((null things) 0) 10 | ((null (rest things)) (first things)) 11 | (t 12 | (flet ((symbolic-generic-binary-+ (a b) 13 | `(generic-binary-+ ,a ,b))) 14 | (reduce #'symbolic-generic-binary-+ things))))) 15 | 16 | (defun generic-* (&rest things) 17 | (cond ((null things) 0) 18 | ((null (rest things)) (first things)) 19 | (t (reduce #'generic-binary-* things)))) 20 | 21 | (define-compiler-macro generic-* (&rest things) 22 | (cond ((null things) 1) 23 | ((null (rest things)) (first things)) 24 | (t 25 | (flet ((symbolic-generic-binary-* (a b) 26 | `(generic-binary-* ,a ,b))) 27 | (reduce #'symbolic-generic-binary-* things))))) 28 | 29 | (defun generic-find-user (item list) 30 | (declare (list list)) 31 | (generic-find item list)) 32 | 33 | (assert (= 42 (generic-find-user 42 '(1 3 17 42 9)))) 34 | 35 | (defun generic-+-user-1 (x y z) 36 | (declare (double-float x y z)) 37 | (generic-+ x y z)) 38 | 39 | (defun generic-+-user-2 (p) 40 | (declare (point p)) 41 | (generic-+ p p)) 42 | 43 | (defun generic-*-user (x y z) 44 | (declare (single-float x y z)) 45 | (generic-* x y z)) 46 | 47 | (assert (= (generic-*-user 5.0 6.0 7.0) 210.0)) 48 | 49 | (defun rest-args-user (x y z) 50 | (declare (single-float x y z)) 51 | (rest-args x y z z z)) 52 | 53 | (assert (= (rest-args-user 5.0 6.0 7.0) 14)) 54 | 55 | (defun crazy-next-method-caller-user (a b) 56 | (declare (integer a) (integer b)) 57 | (crazy-next-method-caller a b)) 58 | 59 | (assert (= (crazy-next-method-caller-user 5 6) 116)) 60 | (assert (= (crazy-next-method-caller-user 1 2) 68)) 61 | 62 | (defun keyword-function-user (x y) 63 | (declare (integer x y)) 64 | (keyword-function x :y y)) 65 | 66 | (assert (equal (keyword-function-user 8 3) '(8 3 nil (8 3 4)))) 67 | (assert (equal (keyword-function-user 1 2) '(1 2 nil (1 2 4)))) 68 | -------------------------------------------------------------------------------- /test-suite/generic-functions.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:fast-generic-functions-test-suite) 2 | 3 | (defgeneric generic-find (item sequence &key test) 4 | (:argument-precedence-order sequence item) 5 | (:generic-function-class fast-generic-function)) 6 | 7 | (defgeneric generic-binary-+ (a b) 8 | (:generic-function-class fast-generic-function)) 9 | 10 | (defgeneric generic-binary-* (a b) 11 | (:generic-function-class fast-generic-function)) 12 | 13 | (defgeneric rest-args (a1 a2 &rest rest) 14 | (:argument-precedence-order a2 a1) 15 | (:generic-function-class fast-generic-function)) 16 | 17 | (defgeneric crazy-next-method-caller (a b) 18 | (:generic-function-class fast-generic-function)) 19 | 20 | (defgeneric keyword-function (x &key y z) 21 | (:generic-function-class fast-generic-function)) 22 | -------------------------------------------------------------------------------- /test-suite/methods.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:fast-generic-functions-test-suite) 2 | 3 | ;;; GENERIC-FIND 4 | 5 | (defmethod generic-find (elt (list list) &key (test #'eql)) 6 | (loop for item in list 7 | when (funcall test item elt) do (return item))) 8 | 9 | (defmethod generic-find (elt (vector vector) &key (test #'eql)) 10 | (cl:find elt vector :test test)) 11 | 12 | (seal-domain #'generic-find '(t sequence)) 13 | 14 | ;;; GENERIC-BINARY-+ 15 | 16 | (defmethod generic-binary-+ :around ((a number) (b number)) 17 | (print '(:around number number)) 18 | (print (call-next-method))) 19 | 20 | (defmethod generic-binary-+ ((a point) (b point)) 21 | (print '(point point)) 22 | (make-point 23 | :x (+ (point-x a) (point-x b)) 24 | :y (+ (point-y a) (point-y b)))) 25 | 26 | (defmethod generic-binary-+ ((a number) (b number)) 27 | (print '(number number)) 28 | (+ a b)) 29 | 30 | (defmethod generic-binary-+ ((a integer) (b integer)) 31 | (print '(integer integer)) 32 | (+ a b)) 33 | 34 | (defmethod generic-binary-+ ((a double-float) (b double-float)) 35 | (print '(double-float double-float)) 36 | (+ a b)) 37 | 38 | (defmethod generic-binary-+ ((a character) (b character)) 39 | (print '(character character)) 40 | (+ (char-code a) 41 | (char-code b))) 42 | 43 | (defmethod generic-binary-+ ((a double-float) (b number)) 44 | (print '(double-float t)) 45 | (+ a b)) 46 | 47 | (seal-domain #'generic-binary-+ '(number number)) 48 | 49 | ;;; GENERIC-BINARY-* 50 | 51 | (defmethod generic-binary-* ((a double-float) (b double-float)) 52 | (declare (method-properties inlineable)) 53 | (* a b)) 54 | 55 | (defmethod generic-binary-* ((a single-float) (b single-float)) 56 | (declare (method-properties inlineable)) 57 | (* a b)) 58 | 59 | (seal-domain #'generic-binary-* '(number number)) 60 | 61 | ;;; REST-ARGS 62 | 63 | (defmethod rest-args (a1 (a2 number) &rest rest) 64 | (+ a1 a2 (length rest))) 65 | 66 | (seal-domain #'rest-args '(t number)) 67 | 68 | ;;; CRAZY-NEXT-METHOD-CALLER 69 | 70 | (defmethod crazy-next-method-caller ((a number) (b number)) 71 | (declare (method-properties inlineable)) 72 | (+ a b)) 73 | 74 | (defmethod crazy-next-method-caller ((a real) (b real)) 75 | (declare (method-properties inlineable)) 76 | (call-next-method (* b 5) (* a 7))) 77 | 78 | (defmethod crazy-next-method-caller ((a integer) (b integer)) 79 | (declare (method-properties inlineable)) 80 | (call-next-method (+ b 2) (+ a 7))) 81 | 82 | (seal-domain #'crazy-next-method-caller '(number number)) 83 | 84 | ;;; KEYWORD-FUNCTION 85 | 86 | (defmethod keyword-function ((x integer) &key y z) 87 | (list x y z (call-next-method x :y y))) 88 | 89 | (defmethod keyword-function ((x real) &key (y 3) (z 4)) 90 | (list x y z)) 91 | 92 | (seal-domain #'keyword-function '(real)) 93 | -------------------------------------------------------------------------------- /test-suite/packages.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-user) 2 | 3 | (defpackage #:fast-generic-functions-test-suite 4 | (:use 5 | #:closer-common-lisp 6 | #:fast-generic-functions)) 7 | --------------------------------------------------------------------------------