├── LICENSE ├── README.org └── code ├── domain.lisp ├── generic-functions.lisp ├── packages.lisp ├── potentially-sealable-method.lisp ├── sealable-class.lisp ├── sealable-generic-function.lisp ├── sealable-metaobject-mixin.lisp ├── sealable-metaobjects.asd ├── specializer-prototype.lisp ├── static-call-signature.lisp └── utilities.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: Sealable Metaobjects 2 | 3 | [[https://heisig.xyz/sealable-metaobjects.jpg]] 4 | 5 | * Introduction 6 | We present an extension of the Common Lisp Object System (CLOS) that allows 7 | a compiler to inline a generic function under certain conditions. 8 | 9 | We should note that moving parts of the callee into the caller is usually a 10 | very bad idea. It prevents safe and efficient function redefinition and 11 | inflates the amount of generated machine code at the call site. Most 12 | severely, when moving parts of a generic function to the caller, we lose 13 | the ability to redefine or extend some of the involved objects and 14 | metaobjects. 15 | 16 | Nevertheless, there are two cases where the aforementioned drawbacks are 17 | tolerable. The one case is when passing built-in Common Lisp objects to 18 | specified functions. The other case is for user code that has such extreme 19 | performance demands that the alternative of using this technique would be 20 | to refrain from using generic functions altogether. 21 | 22 | * The Technique 23 | The goal is to inline a generic function under certain circumstances. 24 | These circumstances are: 25 | 26 | 1. It is possible to statically determine the generic function being 27 | called. 28 | 29 | 2. This generic function is sealed, i.e., it is an instance of 30 | SEALABLE-GENERIC-FUNCTION that has previously been passed to the 31 | function SEAL-GENERIC-FUNCTION. 32 | 33 | 3. This sealed generic function has at least one sealed method, i.e., a 34 | method of type POTENTIALLY-SEALABLE-METHOD that specializes, on each 35 | relevant argument, on a built-in or sealed class, or an eql specializer 36 | whose object is an instance of a built-in or sealed class. 37 | 38 | 4. It must be possible to determine, statically, that the types of all 39 | arguments in a specializing position uniquely determine the list of 40 | applicable methods. 41 | 42 | * Examples 43 | The following examples illustrate how sealable metaobjects can be used. 44 | Each example code can be evaluated as-is. However, for actual use, we 45 | recommend the following practices: 46 | 47 | - Sealable generic functions should be defined in a separate file that is 48 | loaded early. If this is not done, its methods may not use the correct 49 | method-class. (An alternative is to specify the method class of each 50 | method explicitly). 51 | - Metaobject sealing should be the very last step when loading a project. 52 | Ideally, all calls to SEAL-GENERIC-FUNCTION should be in a separate file 53 | that ASDF loads last. This way, sealing can also be disabled 54 | conveniently, e.g., to measure whether sealing actually improves 55 | performance (Which you should do!). 56 | 57 | *** Generic Plus 58 | This example shows how one can implement a generic version of =cl:+=. 59 | 60 | #+BEGIN_SRC lisp 61 | (defgeneric generic-binary-+ (a b) 62 | (:generic-function-class sealable-metaobjects:fast-generic-function)) 63 | 64 | (defmethod generic-binary-+ ((a number) (b number)) 65 | (+ a b)) 66 | 67 | (defmethod generic-binary-+ ((a character) (b character)) 68 | (+ (char-code a) 69 | (char-code b))) 70 | 71 | (sealable-metaobjects:seal-domain #'generic-binary-+ '(number number)) 72 | (sealable-metaobjects:seal-domain #'generic-binary-+ '(character character)) 73 | 74 | (defun generic-+ (&rest things) 75 | (cond ((null things) 0) 76 | ((null (rest things)) (first things)) 77 | (t (reduce #'generic-binary-+ things)))) 78 | 79 | (define-compiler-macro generic-+ (&rest things) 80 | (cond ((null things) 0) 81 | ((null (rest things)) (first things)) 82 | (t 83 | (flet ((symbolic-generic-binary-+ (a b) 84 | `(generic-binary-+ ,a ,b))) 85 | (reduce #'symbolic-generic-binary-+ things))))) 86 | #+END_SRC 87 | 88 | You can quickly verify that this new operator is as efficient as =cl:+=: 89 | 90 | #+BEGIN_SRC lisp 91 | (defun triple-1 (x) 92 | (declare (single-float x)) 93 | (+ x x x)) 94 | 95 | (defun triple-2 (x) 96 | (declare (single-float x)) 97 | (generic-+ x x x)) 98 | 99 | ;;; Both functions should compile to the same assembler code. 100 | (disassemble #'triple-1) 101 | (disassemble #'triple-2) 102 | #+END_SRC 103 | 104 | Yet, other than =cl:+=, =generic-+= can be extended by the user, just like 105 | a regular generic function. The only restriction is that new methods must 106 | not interfere with the behavior of methods that specialize on sealed types 107 | only. 108 | 109 | *** Generic Find 110 | This example illustrates how one can implement a fast, generic version of =cl:find=. 111 | 112 | #+BEGIN_SRC lisp 113 | (defgeneric generic-find (item sequence &key test) 114 | (:generic-function-class sealable-metaobjects:fast-generic-function)) 115 | 116 | (defmethod generic-find (elt (list list) &key (test #'eql)) 117 | (and (member elt list :test test) 118 | t)) 119 | 120 | (defmethod generic-find (elt (vector vector) &key (test #'eql)) 121 | (cl:find elt vector :test test)) 122 | 123 | (sealable-metaobjects:seal-domain #'generic-find '(t list)) 124 | (sealable-metaobjects:seal-domain #'generic-find '(t vector)) 125 | 126 | (defun small-prime-p (x) 127 | (generic-find x '(2 3 5 7 11))) 128 | 129 | ;; The call to GENERIC-FIND should have been replaced by a direct call to 130 | ;; the appropriate effective method. 131 | (disassemble #'small-prime-p) 132 | #+END_SRC 133 | 134 | * Related Work 135 | - https://github.com/guicho271828/inlined-generic-function 136 | - https://opendylan.org/books/drm/Define_Sealed_Domain 137 | - https://github.com/markcox80/specialization-store 138 | - http://home.pipeline.com/~hbaker1/CLOStrophobia.html 139 | - Generic Function Sealing by Paul Khuong (unpublished) 140 | -------------------------------------------------------------------------------- /code/domain.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:sealable-metaobjects) 2 | 3 | (defclass domain () 4 | ((%specializers 5 | :initform (required-argument :specializers) 6 | :initarg :specializers 7 | :reader domain-specializers) 8 | (%arity 9 | :initform (required-argument :arity) 10 | :initarg :arity 11 | :reader domain-arity))) 12 | 13 | (defmethod print-object ((domain domain) stream) 14 | (print-unreadable-object (domain stream :type t) 15 | (format stream "~{~S~^ ~}" 16 | (mapcar #'specializer-type (domain-specializers domain))))) 17 | 18 | (defun make-domain (specializers &aux (arity (list-length specializers))) 19 | (dolist (specializer specializers) 20 | (check-type specializer specializer)) 21 | (make-instance 'domain 22 | :specializers specializers 23 | :arity arity)) 24 | 25 | (defmethod ensure-domain ((domain domain)) 26 | domain) 27 | 28 | (defmethod ensure-domain ((sequence sequence)) 29 | (make-domain 30 | (map 'list #'ensure-specializer sequence))) 31 | 32 | (defmethod method-domain ((method method)) 33 | (make-domain (method-specializers method))) 34 | 35 | (defmethod domain-equal 36 | ((domain-1 domain) 37 | (domain-2 domain)) 38 | (and (= (domain-arity domain-1) 39 | (domain-arity domain-2)) 40 | (every #'eq 41 | (domain-specializers domain-1) 42 | (domain-specializers domain-2)))) 43 | 44 | (defmethod domain-intersectionp 45 | ((domain-1 domain) 46 | (domain-2 domain)) 47 | (assert (= (domain-arity domain-1) 48 | (domain-arity domain-2))) 49 | (every #'specializer-intersectionp 50 | (domain-specializers domain-1) 51 | (domain-specializers domain-2))) 52 | 53 | (defmethod domain-subsetp 54 | ((domain-1 domain) 55 | (domain-2 domain)) 56 | (assert (= (domain-arity domain-1) 57 | (domain-arity domain-2))) 58 | (every #'specializer-subsetp 59 | (domain-specializers domain-1) 60 | (domain-specializers domain-2))) 61 | -------------------------------------------------------------------------------- /code/generic-functions.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:sealable-metaobjects) 2 | 3 | ;;; Working with specializers. 4 | 5 | (defgeneric ensure-specializer (specializer-designator) 6 | (:method ((class class)) 7 | class) 8 | (:method ((symbol symbol)) 9 | (or (find-class symbol nil) 10 | (call-next-method))) 11 | (:method ((cons cons)) 12 | (if (typep cons '(cons (eql eql) (cons t null))) 13 | (intern-eql-specializer (second cons)) 14 | (call-next-method))) 15 | (:method ((object t)) 16 | (error "~@<~S is not a specializer, or a type designator that ~ 17 | can be converted to a specializer.~:@>" 18 | object))) 19 | 20 | (defgeneric specializer-type (specializer) 21 | (:method ((class class)) 22 | (class-name class)) 23 | (:method ((eql-specializer eql-specializer)) 24 | `(eql ,(eql-specializer-object eql-specializer)))) 25 | 26 | (defgeneric specializer-prototype (specializer &optional excluded-specializers) 27 | (:documentation 28 | "Returns an object that is of the type indicated by SPECIALIZER, but not 29 | of any of the types indicated the optionally supplied 30 | EXCLUDED-SPECIALIZERS. Returns a secondary value of T if such an object 31 | could be determined, and NIL if no such object was found. 32 | 33 | Examples: 34 | (specializer-prototype 35 | (find-class 'double-float)) 36 | => 5.0d0, T 37 | 38 | (specializer-prototype 39 | (find-class 'double-float) 40 | (list (intern-eql-specializer 5.0d0))) 41 | => 6.0d0, T 42 | 43 | (specializer-prototype 44 | (find-class 'real) 45 | (list (find-class 'rational) (find-class 'float))) 46 | => NIL, NIL 47 | ")) 48 | 49 | (defgeneric specializer-direct-superspecializers (specializer) 50 | (:method ((class class)) 51 | (class-direct-superclasses class)) 52 | (:method ((eql-specializer eql-specializer)) 53 | (list 54 | (class-of 55 | (eql-specializer-object eql-specializer))))) 56 | 57 | (defgeneric specializer-intersectionp (specializer-1 specializer-2) 58 | (:method ((class-1 class) (class-2 class)) 59 | (multiple-value-bind (disjointp success) 60 | (subtypep `(and ,class-1 ,class-2) nil) 61 | (assert success) 62 | (not disjointp))) 63 | (:method ((class class) (eql-specializer eql-specializer)) 64 | (typep (eql-specializer-object eql-specializer) class)) 65 | (:method ((eql-specializer eql-specializer) (class class)) 66 | (typep (eql-specializer-object eql-specializer) class)) 67 | (:method ((eql-specializer-1 eql-specializer) (eql-specializer-2 eql-specializer)) 68 | (eql (eql-specializer-object eql-specializer-1) 69 | (eql-specializer-object eql-specializer-2)))) 70 | 71 | (defgeneric specializer-subsetp (specializer-1 specializer-2) 72 | (:method ((class-1 class) (class-2 class)) 73 | (values (subtypep class-1 class-2))) 74 | (:method ((class class) (eql-specializer eql-specializer)) 75 | (subtypep class (specializer-type eql-specializer))) 76 | (:method ((eql-specializer eql-specializer) (class class)) 77 | (typep (eql-specializer-object eql-specializer) class)) 78 | (:method ((eql-specializer-1 eql-specializer) (eql-specializer-2 eql-specializer)) 79 | (eql (eql-specializer-object eql-specializer-1) 80 | (eql-specializer-object eql-specializer-2)))) 81 | 82 | ;;; Working with domains. 83 | 84 | (defgeneric ensure-domain (domain-designator)) 85 | 86 | (defgeneric method-domain (method)) 87 | 88 | (defgeneric domain-specializers (domain)) 89 | 90 | (defgeneric domain-arity (domain)) 91 | 92 | (defgeneric domain-equal (domain-1 domain-2)) 93 | 94 | (defgeneric domain-intersectionp (domain-1 domain-2)) 95 | 96 | (defgeneric domain-subsetp (domain-1 domain-2)) 97 | 98 | ;;; Checking for sealability. 99 | 100 | (defgeneric metaobject-sealable-p (metaobject) 101 | (:method ((class class)) (eql class (find-class t))) 102 | (:method ((generic-function generic-function)) nil) 103 | (:method ((method method)) nil) 104 | (:method ((built-in-class built-in-class)) t) 105 | (:method ((structure-class structure-class)) t) 106 | #+sbcl (:method ((system-class sb-pcl:system-class)) t)) 107 | 108 | (defgeneric class-sealable-p (class) 109 | (:method ((class class)) 110 | (metaobject-sealable-p class))) 111 | 112 | (defgeneric generic-function-sealable-p (generic-function) 113 | (:method ((generic-function generic-function)) 114 | (metaobject-sealable-p generic-function))) 115 | 116 | (defgeneric method-sealable-p (method) 117 | (:method ((method method)) 118 | (metaobject-sealable-p method))) 119 | 120 | (defgeneric specializer-sealable-p (specializer) 121 | (:method ((class class)) 122 | (class-sealable-p class)) 123 | (:method ((eql-specializer eql-specializer)) 124 | (class-sealable-p 125 | (class-of 126 | (eql-specializer-object eql-specializer))))) 127 | 128 | ;;; Checking for sealed-ness. 129 | 130 | (defgeneric metaobject-sealed-p (metaobject) 131 | (:method ((class class)) (eql class (find-class t))) 132 | (:method ((generic-function generic-function)) nil) 133 | (:method ((method method)) nil) 134 | (:method ((built-in-class built-in-class)) t) 135 | (:method ((structure-class structure-class)) t) 136 | #+sbcl (:method ((system-class sb-pcl:system-class)) t)) 137 | 138 | (defgeneric class-sealed-p (class) 139 | (:method ((class class)) 140 | (metaobject-sealed-p class))) 141 | 142 | (defgeneric generic-function-sealed-p (generic-function) 143 | (:method ((generic-function generic-function)) 144 | (metaobject-sealed-p generic-function))) 145 | 146 | (defgeneric method-sealed-p (method) 147 | (:method ((method method)) 148 | (metaobject-sealed-p method))) 149 | 150 | (defgeneric specializer-sealed-p (specializer) 151 | (:method ((class class)) 152 | (class-sealed-p class)) 153 | (:method ((eql-specializer eql-specializer)) 154 | (specializer-sealed-p 155 | (class-of 156 | (eql-specializer-object eql-specializer))))) 157 | 158 | ;;; Sealing of metaobjects. 159 | 160 | (defgeneric seal-metaobject (metaobject) 161 | ;; Invoke primary methods on SEAL-METAOBJECT at most once. 162 | (:method :around ((metaobject t)) 163 | (unless (metaobject-sealed-p metaobject) 164 | (call-next-method))) 165 | ;; Signal an error if the default primary method is reached. 166 | (:method ((metaobject t)) 167 | (error "Cannot seal the metaobject ~S." metaobject)) 168 | (:method :before ((class class)) 169 | ;; Class sealing implies finalization. 170 | (unless (class-finalized-p class) 171 | (finalize-inheritance class)) 172 | ;; A sealed class must have sealed superclasses. 173 | (loop for class in (rest (class-precedence-list class)) 174 | until (member class *standard-metaobjects*) 175 | do (seal-class class)))) 176 | 177 | (defgeneric seal-class (class) 178 | ;; Invoke primary methods on SEAL-CLASS at most once. 179 | (:method :around ((class class)) 180 | (unless (class-sealed-p class) 181 | (call-next-method))) 182 | (:method ((symbol symbol)) 183 | (seal-metaobject (find-class symbol))) 184 | (:method ((class class)) 185 | (seal-metaobject class))) 186 | 187 | (defgeneric seal-generic-function (generic-function) 188 | ;; Invoke primary methods on SEAL-GENERIC-FUNCTION at most once. 189 | (:method :around ((generic-function generic-function)) 190 | (unless (generic-function-sealed-p generic-function) 191 | (call-next-method))) 192 | (:method ((generic-function generic-function)) 193 | (seal-metaobject generic-function))) 194 | 195 | (defgeneric seal-method (method) 196 | ;; Invoke primary methods on SEAL-METHOD at most once. 197 | (:method :around ((method method)) 198 | (unless (method-sealed-p method) 199 | (call-next-method))) 200 | (:method ((method method)) 201 | (seal-metaobject method))) 202 | 203 | (defgeneric seal-domain (generic-function domain)) 204 | 205 | (defgeneric seal-specializer (specializer) 206 | (:method ((class class)) 207 | (seal-class class)) 208 | (:method ((eql-specializer eql-specializer)) 209 | (seal-class 210 | (class-of 211 | (eql-specializer-object eql-specializer))))) 212 | 213 | ;;; Method properties 214 | 215 | (defgeneric method-properties (method) 216 | (:method ((method method)) 217 | '())) 218 | 219 | (defgeneric validate-method-property (method method-property) 220 | (:method ((method method) (method-property t)) 221 | nil)) 222 | 223 | ;;; Miscellaneous 224 | 225 | (defgeneric sealed-domains (generic-function) 226 | (:method ((generic-function generic-function)) 227 | '())) 228 | 229 | (defgeneric compute-static-call-signatures (generic-function domain)) 230 | 231 | (defgeneric externalizable-object-p (object) 232 | ;; Built-in objects are usually externalizable. 233 | (:method ((object t)) 234 | (typep (class-of object) 'built-in-class)) 235 | ;; Functions are not externalizable by definition. 236 | (:method ((function function)) 237 | nil) 238 | ;; Structure objects may be externalizable even without an appropriate 239 | ;; method on MAKE-LOAD-FORM. 240 | (:method ((structure-object structure-object)) 241 | ;; TODO: Returning T here is a bit bold. Actually we'd have to check 242 | ;; whether each slot of the structure has a value that is 243 | ;; externalizable. 244 | t) 245 | ;; Standard objects are only externalizable if they have an appropriate 246 | ;; method on MAKE-LOAD-FORM. 247 | (:method ((standard-object standard-object)) 248 | (and (make-load-form standard-object) t))) 249 | -------------------------------------------------------------------------------- /code/packages.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-user) 2 | 3 | (defpackage #:sealable-metaobjects 4 | (:use #:closer-common-lisp) 5 | (:export 6 | #:ensure-specializer 7 | #:specializer-type 8 | #:specializer-prototype 9 | #:specializer-direct-superspecializers 10 | #:specializer-intersectionp 11 | #:specializer-subsetp 12 | 13 | #:domain 14 | #:ensure-domain 15 | #:method-domain 16 | #:domain-specializers 17 | #:domain-arity 18 | #:domain-equal 19 | #:domain-intersectionp 20 | #:domain-subsetp 21 | 22 | #:metaobject-sealable-p 23 | #:class-sealable-p 24 | #:generic-function-sealable-p 25 | #:method-sealable-p 26 | #:specializer-sealable-p 27 | 28 | #:metaobject-sealed-p 29 | #:class-sealed-p 30 | #:generic-function-sealed-p 31 | #:method-sealed-p 32 | #:specializer-sealed-p 33 | 34 | #:seal-class 35 | #:seal-generic-function 36 | #:seal-method 37 | #:seal-domain 38 | #:seal-specializer 39 | 40 | #:method-properties 41 | #:validate-method-property 42 | 43 | #:static-call-signature 44 | #:static-call-signature-types 45 | #:static-call-signature-prototypes 46 | 47 | #:sealed-domains 48 | #:compute-static-call-signatures 49 | #:externalizable-object-p 50 | #:sealable-class 51 | #:sealable-generic-function 52 | #:sealable-standard-generic-function 53 | #:potentially-sealable-method 54 | #:potentially-sealable-standard-method)) 55 | 56 | -------------------------------------------------------------------------------- /code/potentially-sealable-method.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:sealable-metaobjects) 2 | 3 | ;;; There is no portable way to add options to a method. So instead, we 4 | ;;; allow programmers to declare METHOD-PROPERTIES. 5 | ;;; 6 | ;;; Example: 7 | ;;; 8 | ;;; (defmethod foo (x y) 9 | ;;; (declare (method-properties inline)) 10 | ;;; (+ x y)) 11 | 12 | (declaim (declaration method-properties)) 13 | 14 | (defclass potentially-sealable-method (sealable-metaobject-mixin method) 15 | ((%method-properties 16 | :initarg .method-properties. 17 | :accessor method-properties 18 | :initform '()))) 19 | 20 | (defmethod shared-initialize :after 21 | ((psm potentially-sealable-method) 22 | slot-names &key ((.method-properties. method-properties) '()) &allow-other-keys) 23 | (declare (ignore slot-names)) 24 | (dolist (method-property method-properties) 25 | (unless (validate-method-property psm method-property) 26 | (error "~@<~S is not a valid method property for the method ~S.~@:>" 27 | method-property psm)))) 28 | 29 | ;;; Track all properties that have been declared in the body of the method 30 | ;;; lambda, and make them accessible as METHOD-PROPERTIES of that method. 31 | (defmethod make-method-lambda :around 32 | ((gf generic-function) 33 | (psm potentially-sealable-method) 34 | lambda 35 | environment) 36 | (declare (ignore environment)) 37 | (multiple-value-bind (method-lambda initargs) 38 | (call-next-method) 39 | (values 40 | method-lambda 41 | (list* '.method-properties. 42 | (let* ((declare-forms (remove-if-not (starts-with 'declare) lambda)) 43 | (declarations (apply #'append (mapcar #'rest declare-forms)))) 44 | (reduce #'union (remove-if-not (starts-with 'method-properties) declarations) 45 | :key #'rest 46 | :initial-value '())) 47 | initargs)))) 48 | 49 | (defmethod metaobject-sealable-p ((psm potentially-sealable-method)) 50 | (every #'specializer-sealed-p (method-specializers psm))) 51 | 52 | (defmethod seal-metaobject :before ((psm potentially-sealable-method)) 53 | (mapcar #'seal-specializer (method-specializers psm))) 54 | 55 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 56 | ;;; 57 | ;;; Derived Classes 58 | 59 | (defclass potentially-sealable-standard-method 60 | (standard-method potentially-sealable-method) 61 | ()) 62 | -------------------------------------------------------------------------------- /code/sealable-class.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:sealable-metaobjects) 2 | 3 | (defclass sealable-class (sealable-metaobject-mixin class) 4 | ()) 5 | -------------------------------------------------------------------------------- /code/sealable-generic-function.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:sealable-metaobjects) 2 | 3 | (defclass sealable-generic-function (sealable-metaobject-mixin generic-function) 4 | ((%sealed-domains 5 | :initform '() 6 | :type list 7 | :reader sealed-domains 8 | :writer (setf %sealed-domains))) 9 | (:default-initargs 10 | :method-class (find-class 'potentially-sealable-method)) 11 | (:metaclass funcallable-standard-class)) 12 | 13 | ;;; Check that the supplied domain is sane. 14 | (defmethod seal-domain 15 | ((sgf sealable-generic-function) 16 | (domain t)) 17 | (seal-domain sgf (ensure-domain domain))) 18 | 19 | (defmethod seal-domain :around 20 | ((sgf sealable-generic-function) 21 | (domain domain)) 22 | ;; Ensure that we don't seal any domain more than once. 23 | (unless (find domain (sealed-domains sgf) :test #'domain-equal) 24 | (call-next-method sgf domain))) 25 | 26 | ;;; Ensure that the generic function is sealed, and that the newly sealed 27 | ;;; domain is disjoint from other domains. 28 | (defmethod seal-domain :before 29 | ((sgf sealable-generic-function) 30 | (domain domain)) 31 | ;; Ensure that the length of the domain matches the number of mandatory 32 | ;; arguments of the generic function. 33 | (unless (= (domain-arity domain) 34 | (length (generic-function-argument-precedence-order sgf))) 35 | (error "~@" 37 | (mapcar #'specializer-type (domain-specializers domain)) 38 | (domain-arity domain) 39 | (generic-function-name sgf) 40 | (length (generic-function-argument-precedence-order sgf)))) 41 | ;; Attempt to seal the supplied generic function. 42 | (seal-generic-function sgf) 43 | ;; Ensure that the domain does not intersect any existing sealed domains. 44 | (dolist (existing-domain (sealed-domains sgf)) 45 | (when (domain-intersectionp domain existing-domain) 46 | (error "~@" 48 | (mapcar #'specializer-type domain) 49 | sgf 50 | (mapcar #'specializer-type existing-domain))))) 51 | 52 | ;;; Add a new sealed domain. 53 | (defmethod seal-domain 54 | ((sgf sealable-generic-function) 55 | (domain domain)) 56 | (dolist (method (generic-function-methods sgf)) 57 | (when (domain-intersectionp (method-domain method) domain) 58 | (unless (domain-subsetp (method-domain method) domain) 59 | (error "~@" 61 | method 62 | (mapcar #'specializer-type (method-specializers method)) 63 | (mapcar #'specializer-type (domain-specializers domain)))) 64 | (seal-method method))) 65 | (setf (%sealed-domains sgf) 66 | (cons domain (sealed-domains sgf)))) 67 | 68 | ;;; Skip the call to add-method if the list of specializers is equal to 69 | ;;; that of an existing, sealed method. 70 | (defmethod add-method :around 71 | ((sgf sealable-generic-function) 72 | (psm potentially-sealable-method)) 73 | (dolist (method (generic-function-methods sgf)) 74 | (when (and (method-sealed-p method) 75 | (equal (method-specializers psm) 76 | (method-specializers method))) 77 | (return-from add-method psm))) 78 | (call-next-method)) 79 | 80 | ;;; Ensure that the method to be added is disjoint from all sealed domains. 81 | (defmethod add-method :before 82 | ((sgf sealable-generic-function) 83 | (psm potentially-sealable-method)) 84 | (dolist (domain (sealed-domains sgf)) 85 | (when (domain-intersectionp domain (method-domain psm)) 86 | (error "~@" 89 | psm (method-specializers psm) 90 | sgf (mapcar #'specializer-type (domain-specializers domain)))))) 91 | 92 | ;;; Ensure that the method to be removed is disjoint from all sealed domains. 93 | (defmethod remove-method :before 94 | ((sgf sealable-generic-function) 95 | (psm potentially-sealable-method)) 96 | (dolist (domain (sealed-domains sgf)) 97 | (when (domain-intersectionp domain (method-domain psm)) 98 | (error "~@" 101 | psm (method-specializers psm) 102 | sgf (mapcar #'specializer-type (domain-specializers domain)))))) 103 | 104 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 105 | ;;; 106 | ;;; Derived Classes 107 | 108 | (defclass sealable-standard-generic-function 109 | (standard-generic-function sealable-generic-function) 110 | () 111 | (:default-initargs 112 | :method-class (find-class 'potentially-sealable-standard-method)) 113 | (:metaclass funcallable-standard-class)) 114 | -------------------------------------------------------------------------------- /code/sealable-metaobject-mixin.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:sealable-metaobjects) 2 | 3 | (defclass sealable-metaobject-mixin () 4 | ((%sealed-p :initform nil :reader metaobject-sealed-p))) 5 | 6 | (defmethod metaobject-sealable-p ((metaobject sealable-metaobject-mixin)) 7 | t) 8 | 9 | (defmethod seal-metaobject ((metaobject sealable-metaobject-mixin)) 10 | (setf (slot-value metaobject '%sealed-p) t)) 11 | 12 | ;;; It is an error to change the class of a sealed metaobject. 13 | (defmethod change-class :around 14 | ((metaobject sealable-metaobject-mixin) new-class &key &allow-other-keys) 15 | (declare (ignore new-class)) 16 | (if (metaobject-sealed-p metaobject) 17 | (error "Attempt to change the class of the sealed metaobject ~S." 18 | metaobject) 19 | (call-next-method))) 20 | 21 | ;;; It is an error to change any object's class to a sealed metaobject. 22 | (defmethod update-instance-for-different-class :around 23 | (previous (current sealable-metaobject-mixin) &key &allow-other-keys) 24 | (error "Attempt to change the class of ~S to the sealable metaobject ~S." 25 | previous (class-of current))) 26 | 27 | ;;; Attempts to reinitialize a sealed metaobject are silently ignored. 28 | (defmethod reinitialize-instance :around 29 | ((metaobject sealable-metaobject-mixin) &key &allow-other-keys) 30 | (if (metaobject-sealed-p metaobject) 31 | metaobject 32 | (call-next-method))) 33 | 34 | ;;; It is an error to change the class of an instance of a sealable 35 | ;;; metaobject. 36 | 37 | (defclass sealable-metaobject-instance (t) 38 | ()) 39 | 40 | (defmethod change-class :around 41 | ((instance sealable-metaobject-instance) new-class &key &allow-other-keys) 42 | (declare (ignore new-class)) 43 | (error "Attempt to change the class of the sealable metaobject instance ~S." 44 | instance)) 45 | 46 | (defmethod shared-initialize 47 | ((instance sealable-metaobject-mixin) 48 | (slot-names (eql t)) 49 | &rest initargs 50 | &key direct-superclasses) 51 | (unless (every #'class-sealable-p direct-superclasses) 52 | (error "~@" 54 | (find-if-not #'class-sealable-p direct-superclasses))) 55 | (apply #'call-next-method instance slot-names 56 | :direct-superclasses 57 | (adjoin (find-class 'sealable-metaobject-instance) direct-superclasses) 58 | initargs)) 59 | -------------------------------------------------------------------------------- /code/sealable-metaobjects.asd: -------------------------------------------------------------------------------- 1 | (defsystem "sealable-metaobjects" 2 | :author "Marco Heisig " 3 | :description "A CLOSsy way to trade genericity for performance." 4 | :license "MIT" 5 | :depends-on ("closer-mop") 6 | 7 | :serial t 8 | :components 9 | ((:file "packages") 10 | (:file "utilities") 11 | (:file "generic-functions") 12 | (:file "domain") 13 | 14 | ;; Sealable Metaobjects. 15 | (:file "sealable-metaobject-mixin") 16 | (:file "sealable-class") 17 | (:file "potentially-sealable-method") 18 | (:file "sealable-generic-function") 19 | 20 | ;; Analysis. 21 | (:file "specializer-prototype") 22 | (:file "static-call-signature"))) 23 | -------------------------------------------------------------------------------- /code/specializer-prototype.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:sealable-metaobjects) 2 | 3 | ;;; Finding a suitable prototype for eql specializers is easy. 4 | (defmethod specializer-prototype ((eql-specializer eql-specializer) 5 | &optional excluded-specializers) 6 | (if (member eql-specializer excluded-specializers) 7 | (values nil nil) 8 | (values (eql-specializer-object eql-specializer) t))) 9 | 10 | (defun eql-specializer-p (object) 11 | (typep object 'eql-specializer)) 12 | 13 | (defmethod specializer-prototype ((class class) &optional excluded-specializers) 14 | (let* ((excluded-non-eql-specializers (remove-if #'eql-specializer-p excluded-specializers)) 15 | (excluded-eql-specializers (remove-if-not #'eql-specializer-p excluded-specializers)) 16 | (excluded-objects (mapcar #'eql-specializer-object excluded-eql-specializers)) 17 | (excluded-types (mapcar #'specializer-type excluded-non-eql-specializers))) 18 | (map-class-prototypes 19 | (lambda (prototype) 20 | ;; The prototype must not be a member of the excluded objects. 21 | (when (not (member prototype excluded-objects)) 22 | ;; The prototype must not be of one of the excluded types. 23 | (when (notany 24 | (lambda (excluded-type) 25 | (typep prototype excluded-type)) 26 | excluded-types) 27 | (return-from specializer-prototype (values prototype t))))) 28 | class) 29 | (values nil nil))) 30 | 31 | ;;; The difficult part is to find suitable prototypes for specializers that 32 | ;;; are classes. Ideally, we want several prototypes for each class, such 33 | ;;; that we can avoid collisions with excluded specializers. Our technique 34 | ;;; is to find prototypes from two sources - the value returned by the MOP 35 | ;;; function CLASS-PROTOTYPE, and manually curated lists of prototypes for 36 | ;;; each class, which we store in the hash table *CLASS-PROTOTYPES*. 37 | 38 | (defvar *class-prototypes* (make-hash-table :test #'eq)) 39 | 40 | (defun map-class-prototypes (function class) 41 | (let ((visited-classes (make-hash-table :test #'eq))) 42 | (labels ((visit-class (class) 43 | (unless (gethash class visited-classes) 44 | (setf (gethash class visited-classes) t) 45 | (loop for prototype in (gethash class *class-prototypes* '()) do 46 | (funcall function prototype)) 47 | (mapc #'visit-class (class-direct-subclasses class)) 48 | ;; CLASS-PROTOTYPE is difficult to handle... 49 | (when (class-finalized-p class) 50 | (let ((prototype (class-prototype class))) 51 | ;; Surprisingly, some implementations don't always 52 | ;; return a CLASS-PROTOTYPE that is an instance of the 53 | ;; given class. So we only scan the prototype if it is 54 | ;; actually valid. 55 | (when (typep prototype class) 56 | (funcall function prototype))))))) 57 | (visit-class class)))) 58 | 59 | (defun register-class-prototype (prototype) 60 | (pushnew prototype (gethash (class-of prototype) *class-prototypes* '()) 61 | :test #'equalp)) 62 | 63 | ;; Register list prototypes. 64 | (register-class-prototype '(.prototype.)) 65 | (register-class-prototype nil) 66 | 67 | (defparameter *array-element-types* 68 | (remove-duplicates 69 | (mapcar #'upgraded-array-element-type 70 | (append '(short-float single-float double-float long-float base-char character t) 71 | '((complex short-float) 72 | (complex single-float) 73 | (complex double-float) 74 | (complex long-float)) 75 | (loop for bits from 1 to 64 76 | collect `(unsigned-byte ,bits) 77 | collect `(signed-byte ,bits)))) 78 | :test #'equal)) 79 | 80 | (defun array-initial-element (element-type) 81 | (cond ((subtypep element-type 'number) 82 | (coerce 0 element-type)) 83 | ((subtypep element-type 'character) 84 | (coerce #\0 element-type)) 85 | (t t))) 86 | 87 | ;; Register vector and array prototypes. 88 | (loop for adjustable in '(nil t) do 89 | (loop for fill-pointer in '(nil t) do 90 | (loop for dimensions in '(() (2) (2 2)) do 91 | (loop for element-type in *array-element-types* do 92 | (let ((storage-vector 93 | (make-array (reduce #'* dimensions) 94 | :element-type element-type 95 | :initial-element (array-initial-element element-type)))) 96 | (register-class-prototype 97 | (make-array dimensions 98 | :adjustable adjustable 99 | :fill-pointer (and (= 1 (length dimensions)) fill-pointer) 100 | :element-type element-type 101 | :displaced-to storage-vector)) 102 | (register-class-prototype 103 | (make-array dimensions 104 | :adjustable adjustable 105 | :fill-pointer (and (= 1 (length dimensions)) fill-pointer) 106 | :element-type element-type 107 | :initial-element (array-initial-element element-type)))))))) 108 | 109 | ;; Register integer and rational prototypes. 110 | (loop for integer in '(19 1337 1338 91676) do 111 | (register-class-prototype (+ integer)) 112 | (register-class-prototype (- integer))) 113 | (loop for bits = 1 then (* bits 2) until (>= bits 512) 114 | for value = (expt 2 bits) do 115 | (loop for value in (list (1+ value) value (1- value)) do 116 | (register-class-prototype value) 117 | (register-class-prototype (- value)) 118 | (register-class-prototype (/ value 17)))) 119 | 120 | ;; Register float and complex float prototypes. 121 | (register-class-prototype pi) 122 | (register-class-prototype (- pi)) 123 | (register-class-prototype (exp 1S0)) 124 | (register-class-prototype (exp 1F0)) 125 | (register-class-prototype (exp 1D0)) 126 | (register-class-prototype (exp 1L0)) 127 | (mapcar #'register-class-prototype 128 | (list most-positive-short-float 129 | most-positive-single-float 130 | most-positive-double-float 131 | most-positive-long-float 132 | most-negative-short-float 133 | most-negative-single-float 134 | most-negative-double-float 135 | most-positive-long-float 136 | short-float-epsilon 137 | single-float-epsilon 138 | double-float-epsilon 139 | long-float-epsilon 140 | short-float-negative-epsilon 141 | single-float-negative-epsilon 142 | double-float-negative-epsilon 143 | long-float-negative-epsilon)) 144 | (loop for base in '(-0.7L0 -0.1L0 -0.0L0 +0.0L0 +0.1L0 +0.7L0) do 145 | (loop for fp-type in '(short-float single-float double-float long-float) do 146 | (loop for exponent in '(1 2 3 5 7 23 99) do 147 | (let ((float (scale-float (coerce base fp-type) exponent))) 148 | (register-class-prototype float) 149 | (register-class-prototype (complex (float 0 float) float)))))) 150 | 151 | ;; Register character prototypes. 152 | (loop for char across "The quick brown fox jumps over the lazy dog." do 153 | (register-class-prototype (char-downcase char)) 154 | (register-class-prototype (char-upcase char))) 155 | (loop for char across "0123456789!$\"'(),_-./:;?+<=>#%&*@[\\]{\|}`^~" do 156 | (register-class-prototype char)) 157 | (loop for char in '(#\backspace #\tab #\newline #\linefeed #\page #\return #\space #\rubout) do 158 | (register-class-prototype char)) 159 | -------------------------------------------------------------------------------- /code/static-call-signature.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:sealable-metaobjects) 2 | 3 | ;;; In this file, we compute the static call signatures of a given, sealed 4 | ;;; generic function. A static call signature consists of a list of types, 5 | ;;; and a list of prototypes. The list of types is guaranteed to be 6 | ;;; non-overlapping with the types of any other call signature. The list 7 | ;;; of prototypes is chosen such that the list of applicable methods of 8 | ;;; these prototypes is representative for all arguments of the types of 9 | ;;; the call signature. 10 | 11 | (defclass static-call-signature () 12 | ((%types 13 | :initarg :types 14 | :reader static-call-signature-types) 15 | (%prototypes 16 | :initarg :prototypes 17 | :reader static-call-signature-prototypes))) 18 | 19 | (defmethod print-object ((scs static-call-signature) stream) 20 | (print-unreadable-object (scs stream :type t :identity t) 21 | (format stream "~S ~S" 22 | (static-call-signature-types scs) 23 | (static-call-signature-prototypes scs)))) 24 | 25 | (defmethod make-load-form 26 | ((static-call-signature static-call-signature) &optional environment) 27 | (make-load-form-saving-slots 28 | static-call-signature 29 | :slot-names '(%types %prototypes) 30 | :environment environment)) 31 | 32 | (defmethod externalizable-object-p 33 | ((static-call-signature static-call-signature)) 34 | (and 35 | (every #'externalizable-object-p 36 | (static-call-signature-types static-call-signature)) 37 | (every #'externalizable-object-p 38 | (static-call-signature-prototypes static-call-signature)))) 39 | 40 | (defmethod compute-static-call-signatures 41 | ((sgf sealable-generic-function) 42 | (domain domain)) 43 | (let* ((sealed-methods 44 | (remove-if-not 45 | (lambda (method) 46 | (domain-intersectionp (method-domain method) domain)) 47 | (generic-function-methods sgf))) 48 | (list-of-specializers 49 | (mapcar #'method-specializers sealed-methods)) 50 | (static-call-signatures '())) 51 | (unless (null list-of-specializers) 52 | (map-types-and-prototypes 53 | (lambda (types prototypes) 54 | (push (make-instance 'static-call-signature 55 | :types types 56 | :prototypes prototypes) 57 | static-call-signatures)) 58 | ;; Transpose the list of specializers so that we operate on each 59 | ;; argument instead of on each method. 60 | (apply #'mapcar #'list list-of-specializers) 61 | domain)) 62 | static-call-signatures)) 63 | 64 | (defun map-types-and-prototypes (fn specializers-list domain) 65 | (assert (= (length specializers-list) 66 | (domain-arity domain))) 67 | (labels ((rec (sl specializers types prototypes) 68 | (if (null sl) 69 | (funcall fn (reverse types) (reverse prototypes)) 70 | (loop for (type prototype) 71 | in (type-prototype-pairs 72 | (first sl) 73 | (first specializers)) 74 | do (rec (rest sl) 75 | (rest specializers) 76 | (cons type types) 77 | (cons prototype prototypes)))))) 78 | (rec specializers-list (domain-specializers domain) '() '()))) 79 | 80 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 81 | ;;; 82 | ;;; Reasoning About Specializer Specificity 83 | 84 | (defclass snode () 85 | (;; The specializer of an snode. 86 | (%specializer :initarg :specializer :accessor snode-specializer) 87 | ;; A (possibly empty) list of snodes for each child class or eql specializer. 88 | (%children :initform '() :accessor snode-children) 89 | ;; A list of snodes with one entry for each parent class. 90 | (%parents :initform '() :accessor snode-parents) 91 | ;; Whether the snode has already been visited. 92 | (%visitedp :initform nil :accessor snode-visitedp) 93 | ;; Whether the snode corresponds to a specializer of an existing method 94 | ;; or the domain. 95 | (%relevantp :initform nil :accessor snode-relevantp))) 96 | 97 | (defun snode-type (snode) 98 | (type-specifier-and 99 | (specializer-type (snode-specializer snode)) 100 | (type-specifier-not 101 | (apply #'type-specifier-or 102 | (loop for subspecializer in (snode-children snode) 103 | collect 104 | (specializer-type 105 | (snode-specializer subspecializer))))))) 106 | 107 | (defun snode-prototype (snode) 108 | (specializer-prototype 109 | (snode-specializer snode) 110 | (mapcar #'snode-specializer (snode-children snode)))) 111 | 112 | (defvar *snode-table*) 113 | 114 | (defun specializer-snode (specializer) 115 | (multiple-value-bind (snode present-p) 116 | (gethash specializer *snode-table*) 117 | (if present-p 118 | snode 119 | (let ((snode (make-instance 'snode :specializer specializer))) 120 | (setf (gethash specializer *snode-table*) snode) 121 | snode)))) 122 | 123 | (defun snode-add-edge (super-snode sub-snode) 124 | (pushnew super-snode (snode-parents sub-snode)) 125 | (pushnew sub-snode (snode-children super-snode)) 126 | (values)) 127 | 128 | (defun type-prototype-pairs (specializers domain) 129 | (let* ((*snode-table* (make-hash-table)) 130 | (specializer-snodes (mapcar #'specializer-snode specializers)) 131 | (domain-snode (specializer-snode domain))) 132 | ;; Initialize domain and specializer snodes. 133 | (dolist (snode specializer-snodes) 134 | (setf (snode-relevantp snode) t)) 135 | (setf (snode-relevantp domain-snode) t) 136 | ;; Now connect all snodes. 137 | (labels ((visit (current relevant) 138 | (unless (snode-visitedp current) 139 | (setf (snode-visitedp current) t) 140 | (unless (eql current domain) 141 | (dolist (specializer 142 | (specializer-direct-superspecializers 143 | (snode-specializer current))) 144 | (let ((super (specializer-snode specializer))) 145 | (cond ((snode-relevantp super) 146 | (snode-add-edge super relevant) 147 | (visit super super)) 148 | (t 149 | (visit super relevant))))))))) 150 | (mapc #'visit specializer-snodes specializer-snodes)) 151 | ;; Finally, build all pairs. 152 | (let ((pairs '())) 153 | (loop for snode being the hash-values of *snode-table* do 154 | (when (snode-relevantp snode) 155 | (multiple-value-bind (prototype prototype-p) 156 | (snode-prototype snode) 157 | (when prototype-p 158 | (push (list (snode-type snode) prototype) 159 | pairs))))) 160 | pairs))) 161 | 162 | -------------------------------------------------------------------------------- /code/utilities.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:sealable-metaobjects) 2 | 3 | (defun required-argument (name) 4 | (error "Required argument: ~S" name)) 5 | 6 | (defun starts-with (item) 7 | (lambda (sequence) 8 | (typecase sequence 9 | (list (eql (first sequence) item)) 10 | (sequence (eql (elt sequence 0) item)) 11 | (otherwise nil)))) 12 | 13 | (defun type-specifier-and (&rest type-specifiers) 14 | (let ((relevant (remove t type-specifiers))) 15 | (cond ((null relevant) t) 16 | ((null (cdr relevant)) (first relevant)) 17 | (t `(and ,@relevant))))) 18 | 19 | (defun type-specifier-or (&rest type-specifiers) 20 | (let ((relevant (remove nil type-specifiers))) 21 | (cond ((null relevant) nil) 22 | ((null (cdr relevant)) (first relevant)) 23 | (t `(or ,@relevant))))) 24 | 25 | (defun type-specifier-not (type-specifier) 26 | (cond ((eql type-specifier t) nil) 27 | ((eql type-specifier nil) t) 28 | (t `(not ,type-specifier)))) 29 | 30 | (defparameter *standard-metaobjects* 31 | (list (find-class 'standard-object) 32 | (find-class 'standard-class) 33 | (find-class 'standard-generic-function) 34 | (find-class 'standard-method) 35 | (find-class 'built-in-class))) 36 | --------------------------------------------------------------------------------