Coverage report: /home/ellis/comp/core/lib/obj/meta/sealed.lisp

KindCoveredAll%
expression435964 45.1
branch3298 32.7
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;; obj/meta/sealed.lisp --- Sealed Meta-objects
2
 
3
 ;; see https://github.com/marcoheisig/sealable-metaobjects
4
 
5
 ;;; Commentary:
6
 
7
 ;; From the sealable-metaobjects readme:
8
 
9
 #| 
10
 
11
 The goal is to inline a generic function under certain circumstances. These
12
 circumstances are:
13
 
14
 1 It is possible to statically determine the generic function being called.
15
 
16
 2 This generic function is sealed, i.e., it is an instance of
17
   SEALABLE-GENERIC-FUNCTION that has previously been passed to the function
18
   SEAL-GENERIC-FUNCTION.
19
 
20
 3 This sealed generic function has at least one sealed method, i.e., a method
21
   of type POTENTIALLY-SEALABLE-METHOD that specializes, on each relevant
22
   argument, on a built-in or sealed class, or an eql specializer whose object
23
   is an instance of a built-in or sealed class.
24
 
25
 4 It must be possible to determine, statically, that the types of all
26
   arguments in a specializing position uniquely determine the list of
27
   applicable methods.
28
 
29
 Examples
30
 
31
 The following examples illustrate how sealable metaobjects can be used. Each
32
 example code can be evaluated as-is.  However, for actual use, we recommend
33
 the following practices:
34
 
35
 * Sealable generic functions should be defined in a separate file that is
36
   loaded early. If this is not done, its methods may not use the correct
37
   method-class. (An alternative is to specify the method class of each method
38
   explicitly).
39
 
40
 * Metaobject sealing should be the very last step when loading a
41
   project. Ideally, all calls to SEAL-GENERIC-FUNCTION should be in a separate
42
   file that ASDF loads last. This way, sealing can also be disabled
43
   conveniently, e.g., to measure whether sealing actually improves
44
   performance (Which you should do!).
45
 
46
 Generic Plus
47
 
48
 This example shows how one can implement a generic version of cl:+.
49
 
50
 (defgeneric generic-binary-+ (a b)
51
   (:generic-function-class fast-generic-function))
52
 
53
 (defmethod generic-binary-+ ((a number) (b number))
54
   (+ a b))
55
 
56
 (defmethod generic-binary-+ ((a character) (b character))
57
   (+ (char-code a)
58
      (char-code b)))
59
 
60
 (seal-domain #'generic-binary-+ '(number number))
61
 (seal-domain #'generic-binary-+ '(character character))
62
 
63
 (defun generic-+ (&rest things)
64
   (cond ((null things) 0)
65
         ((null (rest things)) (first things))
66
         (t (reduce #'generic-binary-+ things))))
67
 
68
 (define-compiler-macro generic-+ (&rest things)
69
   (cond ((null things) 0)
70
         ((null (rest things)) (first things))
71
         (t
72
          (flet ((symbolic-generic-binary-+ (a b)
73
                   `(generic-binary-+ ,a ,b)))
74
            (reduce #'symbolic-generic-binary-+ things)))))
75
 
76
 You can quickly verify that this new operator is as efficient as cl:+:
77
 
78
 (defun triple-1 (x)
79
   (declare (single-float x))
80
   (+ x x x))
81
 
82
 (defun triple-2 (x)
83
   (declare (single-float x))
84
   (generic-+ x x x))
85
 
86
 ;;; Both functions should compile to the same assembler code.
87
 (disassemble #'triple-1)
88
 (disassemble #'triple-2)
89
 
90
 Yet, other than cl:+, generic-+ can be extended by the user, just like a
91
 regular generic function. The only restriction is that new methods must not
92
 interfere with the behavior of methods that specialize on sealed types only.
93
 
94
 Generic Find
95
 
96
 This example illustrates how one can implement a fast, generic version of
97
 cl:find.
98
 
99
 (defgeneric generic-find (item sequence &key test)
100
   (:generic-function-class fast-generic-function))
101
 
102
 (defmethod generic-find (elt (list list) &key (test #'eql))
103
   (and (member elt list :test test)
104
        t))
105
 
106
 (defmethod generic-find (elt (vector vector) &key (test #'eql))
107
   (cl:find elt vector :test test))
108
 
109
 (seal-domain #'generic-find '(t list))
110
 (seal-domain #'generic-find '(t vector))
111
 
112
 (defun small-prime-p (x)
113
   (generic-find x '(2 3 5 7 11)))
114
 
115
 ;; The call to GENERIC-FIND should have been replaced by a direct call to
116
 ;; the appropriate effective method.
117
 (disassemble #'small-prime-p)
118
 
119
 |#
120
 ;;; Code:
121
 (in-package :obj/meta/sealed)
122
 
123
 (defun %starts-with (item)
124
   (lambda (sequence)
125
     (typecase sequence
126
       (list (eql (first sequence) item))
127
       (sequence (eql (elt sequence 0) item))
128
       (otherwise nil))))
129
 
130
 (defun type-specifier-and (&rest type-specifiers)
131
   (let ((relevant (remove t type-specifiers)))
132
     (cond ((null relevant) t)
133
           ((null (cdr relevant)) (first relevant))
134
           (t `(and ,@relevant)))))
135
 
136
 (defun type-specifier-or (&rest type-specifiers)
137
   (let ((relevant (remove nil type-specifiers)))
138
     (cond ((null relevant) nil)
139
           ((null (cdr relevant)) (first relevant))
140
           (t `(or ,@relevant)))))
141
 
142
 (defun type-specifier-not (type-specifier)
143
   (cond ((eql type-specifier t) nil)
144
         ((eql type-specifier nil) t)
145
         (t `(not ,type-specifier))))
146
 
147
 (defgeneric ensure-specializer (specializer-designator)
148
   (:method ((class class))
149
     class)
150
   (:method ((symbol symbol))
151
     (or (find-class symbol nil)
152
         (call-next-method)))
153
   (:method ((cons cons))
154
     (if (typep cons '(cons (eql eql) (cons t null)))
155
         (intern-eql-specializer (second cons))
156
         (call-next-method)))
157
   (:method ((object t))
158
     (error "~@<~S is not a specializer, or a type designator that ~
159
                 can be converted to a specializer.~:@>"
160
            object)))
161
 
162
 (defgeneric specializer-type (specializer)
163
   (:method ((class class))
164
     (class-name class))
165
   (:method ((eql-specializer eql-specializer))
166
     `(eql ,(eql-specializer-object eql-specializer))))
167
 
168
 (defgeneric specializer-prototype (specializer &optional excluded-specializers)
169
   (:documentation
170
    "Returns an object that is of the type indicated by SPECIALIZER, but not
171
 of any of the types indicated the optionally supplied
172
 EXCLUDED-SPECIALIZERS.  Returns a secondary value of T if such an object
173
 could be determined, and NIL if no such object was found.
174
 
175
 Examples:
176
  (specializer-prototype
177
    (find-class 'double-float))
178
  => 5.0d0, T
179
 
180
  (specializer-prototype
181
    (find-class 'double-float)
182
    (list (intern-eql-specializer 5.0d0)))
183
  => 6.0d0, T
184
 
185
  (specializer-prototype
186
    (find-class 'real)
187
    (list (find-class 'rational) (find-class 'float)))
188
  => NIL, NIL
189
 "))
190
 
191
 (defgeneric specializer-direct-superspecializers (specializer)
192
   (:method ((class class))
193
     (class-direct-superclasses class))
194
   (:method ((eql-specializer eql-specializer))
195
     (list
196
      (class-of
197
       (eql-specializer-object eql-specializer)))))
198
 
199
 (defgeneric specializer-intersectionp (specializer-1 specializer-2)
200
   (:method ((class-1 class) (class-2 class))
201
     (multiple-value-bind (disjointp success)
202
         (subtypep `(and ,class-1 ,class-2) nil)
203
       (assert success)
204
       (not disjointp)))
205
   (:method ((class class) (eql-specializer eql-specializer))
206
     (typep (eql-specializer-object eql-specializer) class))
207
   (:method ((eql-specializer eql-specializer) (class class))
208
     (typep (eql-specializer-object eql-specializer) class))
209
   (:method ((eql-specializer-1 eql-specializer) (eql-specializer-2 eql-specializer))
210
     (eql (eql-specializer-object eql-specializer-1)
211
          (eql-specializer-object eql-specializer-2))))
212
 
213
 (defgeneric specializer-subsetp (specializer-1 specializer-2)
214
   (:method ((class-1 class) (class-2 class))
215
     (values (subtypep class-1 class-2)))
216
   (:method ((class class) (eql-specializer eql-specializer))
217
     (subtypep class (specializer-type eql-specializer)))
218
   (:method ((eql-specializer eql-specializer) (class class))
219
     (typep (eql-specializer-object eql-specializer) class))
220
   (:method ((eql-specializer-1 eql-specializer) (eql-specializer-2 eql-specializer))
221
     (eql (eql-specializer-object eql-specializer-1)
222
          (eql-specializer-object eql-specializer-2))))
223
 
224
 ;;; Working with domains.
225
 
226
 (defgeneric ensure-domain (domain-designator))
227
 
228
 (defgeneric method-domain (method))
229
 
230
 (defgeneric domain-specializers (domain))
231
 
232
 (defgeneric domain-arity (domain))
233
 
234
 (defgeneric domain-equal (domain-1 domain-2))
235
 
236
 (defgeneric domain-intersectionp (domain-1 domain-2))
237
 
238
 (defgeneric domain-subsetp (domain-1 domain-2))
239
 
240
 ;;; Checking for sealability.
241
 
242
 (defgeneric metaobject-sealable-p (metaobject)
243
   (:method ((class class)) (eql class (find-class t)))
244
   (:method ((generic-function generic-function)) nil)
245
   (:method ((method method)) nil)
246
   (:method ((built-in-class built-in-class)) t)
247
   (:method ((structure-class structure-class)) t)
248
   (:method ((system-class sb-pcl:system-class)) t))
249
 
250
 (defgeneric class-sealable-p (class)
251
   (:method ((class class))
252
     (metaobject-sealable-p class)))
253
 
254
 (defgeneric generic-function-sealable-p (generic-function)
255
   (:method ((generic-function generic-function))
256
     (metaobject-sealable-p generic-function)))
257
 
258
 (defgeneric method-sealable-p (method)
259
   (:method ((method method))
260
     (metaobject-sealable-p method)))
261
 
262
 (defgeneric specializer-sealable-p (specializer)
263
   (:method ((class class))
264
     (class-sealable-p class))
265
   (:method ((eql-specializer eql-specializer))
266
     (class-sealable-p
267
      (class-of
268
       (eql-specializer-object eql-specializer)))))
269
 
270
 ;;; Checking for sealed-ness.
271
 
272
 (defgeneric metaobject-sealed-p (metaobject)
273
   (:method ((class class)) (eql class (find-class t)))
274
   (:method ((generic-function generic-function)) nil)
275
   (:method ((method method)) nil)
276
   (:method ((built-in-class built-in-class)) t)
277
   (:method ((structure-class structure-class)) t)
278
   (:method ((system-class sb-pcl:system-class)) t))
279
 
280
 (defgeneric class-sealed-p (class)
281
   (:method ((class class))
282
     (metaobject-sealed-p class)))
283
 
284
 (defgeneric generic-function-sealed-p (generic-function)
285
   (:method ((generic-function generic-function))
286
     (metaobject-sealed-p generic-function)))
287
 
288
 (defgeneric method-sealed-p (method)
289
   (:method ((method method))
290
     (metaobject-sealed-p method)))
291
 
292
 (defgeneric specializer-sealed-p (specializer)
293
   (:method ((class class))
294
     (class-sealed-p class))
295
   (:method ((eql-specializer eql-specializer))
296
     (specializer-sealed-p
297
      (class-of
298
       (eql-specializer-object eql-specializer)))))
299
 
300
 ;;; Sealing of metaobjects.
301
 
302
 (defgeneric seal-metaobject (metaobject)
303
   ;; Invoke primary methods on SEAL-METAOBJECT at most once.
304
   (:method :around ((metaobject t))
305
     (unless (metaobject-sealed-p metaobject)
306
       (call-next-method)))
307
   ;; Signal an error if the default primary method is reached.
308
   (:method ((metaobject t))
309
     (error "Cannot seal the metaobject ~S." metaobject))
310
   (:method :before ((class class))
311
     ;; Class sealing implies finalization.
312
     (unless (class-finalized-p class)
313
       (finalize-inheritance class))
314
     ;; A sealed class must have sealed superclasses.
315
     (loop for class in (rest (class-precedence-list class))
316
           until (member class *standard-metaobjects*)
317
           do (seal-class class))))
318
 
319
 (defgeneric seal-class (class)
320
   ;; Invoke primary methods on SEAL-CLASS at most once.
321
   (:method :around ((class class))
322
     (unless (class-sealed-p class)
323
       (call-next-method)))
324
   (:method ((symbol symbol))
325
     (seal-metaobject (find-class symbol)))
326
   (:method ((class class))
327
     (seal-metaobject class)))
328
 
329
 (defgeneric seal-generic-function (generic-function)
330
   ;; Invoke primary methods on SEAL-GENERIC-FUNCTION at most once.
331
   (:method :around ((generic-function generic-function))
332
     (unless (generic-function-sealed-p generic-function)
333
       (call-next-method)))
334
   (:method ((generic-function generic-function))
335
     (seal-metaobject generic-function)))
336
 
337
 (defgeneric seal-method (method)
338
   ;; Invoke primary methods on SEAL-METHOD at most once.
339
   (:method :around ((method method))
340
     (unless (method-sealed-p method)
341
       (call-next-method)))
342
   (:method ((method method))
343
     (seal-metaobject method)))
344
 
345
 (defgeneric seal-domain (generic-function domain))
346
 
347
 (defgeneric seal-specializer (specializer)
348
   (:method ((class class))
349
     (seal-class class))
350
   (:method ((eql-specializer eql-specializer))
351
     (seal-class
352
      (class-of
353
       (eql-specializer-object eql-specializer)))))
354
 
355
 ;;; Method properties
356
 
357
 (defgeneric method-properties (method)
358
   (:method ((method method))
359
     '()))
360
 
361
 (defgeneric validate-method-property (method method-property)
362
   (:method ((method method) (method-property t))
363
     nil))
364
 
365
 ;;; Miscellaneous
366
 
367
 (defgeneric sealed-domains (generic-function)
368
   (:method ((generic-function generic-function))
369
     '()))
370
 
371
 (defgeneric compute-static-call-signatures (generic-function domain))
372
 
373
 (defgeneric externalizable-object-p (object)
374
   ;; Built-in objects are usually externalizable.
375
   (:method ((object t))
376
     (typep (class-of object) 'built-in-class))
377
   ;; Functions are not externalizable by definition.
378
   (:method ((function function))
379
     nil)
380
   ;; Structure objects may be externalizable even without an appropriate
381
   ;; method on MAKE-LOAD-FORM.
382
   (:method ((structure-object structure-object))
383
     ;; TODO: Returning T here is a bit bold.  Actually we'd have to check
384
     ;; whether each slot of the structure has a value that is
385
     ;; externalizable.
386
     t)
387
   ;; Standard objects are only externalizable if they have an appropriate
388
   ;; method on MAKE-LOAD-FORM.
389
   (:method ((standard-object standard-object))
390
     (and (make-load-form standard-object) t)))
391
 
392
 (defclass domain ()
393
   ((%specializers
394
     :initform (required-argument :specializers)
395
     :initarg :specializers
396
     :reader domain-specializers)
397
    (%arity
398
     :initform (required-argument :arity)
399
     :initarg :arity
400
     :reader domain-arity)))
401
 
402
 (defmethod print-object ((domain domain) stream)
403
   (print-unreadable-object (domain stream :type t)
404
     (format stream "~{~S~^ ~}"
405
             (mapcar #'specializer-type (domain-specializers domain)))))
406
 
407
 (defun make-domain (specializers &aux (arity (list-length specializers)))
408
   (dolist (specializer specializers)
409
     (check-type specializer specializer))
410
   (make-instance 'domain
411
     :specializers specializers
412
     :arity arity))
413
 
414
 (defmethod ensure-domain ((domain domain))
415
   domain)
416
 
417
 (defmethod ensure-domain ((sequence sequence))
418
   (make-domain
419
    (map 'list #'ensure-specializer sequence)))
420
 
421
 (defmethod method-domain ((method method))
422
   (make-domain (method-specializers method)))
423
 
424
 (defmethod domain-equal
425
     ((domain-1 domain)
426
      (domain-2 domain))
427
   (and (= (domain-arity domain-1)
428
           (domain-arity domain-2))
429
        (every #'eq
430
               (domain-specializers domain-1)
431
               (domain-specializers domain-2))))
432
 
433
 (defmethod domain-intersectionp
434
     ((domain-1 domain)
435
      (domain-2 domain))
436
   (assert (= (domain-arity domain-1)
437
              (domain-arity domain-2)))
438
   (every #'specializer-intersectionp
439
          (domain-specializers domain-1)
440
          (domain-specializers domain-2)))
441
 
442
 (defmethod domain-subsetp
443
     ((domain-1 domain)
444
      (domain-2 domain))
445
   (assert (= (domain-arity domain-1)
446
              (domain-arity domain-2)))
447
   (every #'specializer-subsetp
448
          (domain-specializers domain-1)
449
          (domain-specializers domain-2)))
450
 
451
 (defclass sealable-metaobject-mixin ()
452
   ((%sealed-p :initform nil :reader metaobject-sealed-p)))
453
 
454
 (defmethod metaobject-sealable-p ((metaobject sealable-metaobject-mixin))
455
   t)
456
 
457
 (defmethod seal-metaobject ((metaobject sealable-metaobject-mixin))
458
   (setf (slot-value metaobject '%sealed-p) t))
459
 
460
 ;;; It is an error to change the class of a sealed metaobject.
461
 (defmethod change-class :around
462
     ((metaobject sealable-metaobject-mixin) new-class &key &allow-other-keys)
463
   (declare (ignore new-class))
464
   (if (metaobject-sealed-p metaobject)
465
       (error "Attempt to change the class of the sealed metaobject ~S."
466
              metaobject)
467
       (call-next-method)))
468
 
469
 ;;; It is an error to change any object's class to a sealed metaobject.
470
 (defmethod update-instance-for-different-class :around
471
     (previous (current sealable-metaobject-mixin) &key &allow-other-keys)
472
   (error "Attempt to change the class of ~S to the sealable metaobject ~S."
473
          previous (class-of current)))
474
 
475
 ;;; Attempts to reinitialize a sealed metaobject are silently ignored.
476
 (defmethod reinitialize-instance :around
477
     ((metaobject sealable-metaobject-mixin) &key &allow-other-keys)
478
   (if (metaobject-sealed-p metaobject)
479
       metaobject
480
       (call-next-method)))
481
 
482
 ;;; It is an error to change the class of an instance of a sealable
483
 ;;; metaobject.
484
 
485
 (defclass sealable-metaobject-instance (t)
486
   ())
487
 
488
 (defmethod change-class :around
489
     ((instance sealable-metaobject-instance) new-class &key &allow-other-keys)
490
   (declare (ignore new-class))
491
   (error "Attempt to change the class of the sealable metaobject instance ~S."
492
          instance))
493
 
494
 (defmethod shared-initialize
495
     ((instance sealable-metaobject-mixin)
496
      (slot-names (eql t))
497
      &rest initargs
498
      &key direct-superclasses)
499
   (unless (every #'class-sealable-p direct-superclasses)
500
     (error "~@<The superclasses of a sealable metaobject must be sealable. ~
501
                The superclass ~S violates this restriction.~:@>"
502
            (find-if-not #'class-sealable-p direct-superclasses)))
503
   (apply #'call-next-method instance slot-names
504
          :direct-superclasses
505
          (adjoin (find-class 'sealable-metaobject-instance) direct-superclasses)
506
          initargs))
507
 
508
 (defclass sealable-class (sealable-metaobject-mixin class)
509
   ())
510
 
511
 ;;; There is no portable way to add options to a method.  So instead, we
512
 ;;; allow programmers to declare METHOD-PROPERTIES.
513
 ;;;
514
 ;;; Example:
515
 ;;;
516
 ;;; (defmethod foo (x y)
517
 ;;;   (declare (method-properties inline))
518
 ;;;   (+ x y))
519
 
520
 (declaim (declaration method-properties))
521
 
522
 (defclass potentially-sealable-method (sealable-metaobject-mixin method)
523
   ((%method-properties
524
     :initarg .method-properties.
525
     :accessor method-properties
526
     :initform '())))
527
 
528
 (defmethod shared-initialize :after
529
     ((psm potentially-sealable-method)
530
      slot-names &key ((.method-properties. method-properties) '()) &allow-other-keys)
531
   (declare (ignore slot-names))
532
   (dolist (method-property method-properties)
533
     (unless (validate-method-property psm method-property)
534
       (error "~@<~S is not a valid method property for the method ~S.~@:>"
535
              method-property psm))))
536
 
537
 ;;; Track all properties that have been declared in the body of the method
538
 ;;; lambda, and make them accessible as METHOD-PROPERTIES of that method.
539
 (defmethod make-method-lambda :around
540
     ((gf generic-function)
541
      (psm potentially-sealable-method)
542
      lambda
543
      environment)
544
   (declare (ignore environment))
545
   (multiple-value-bind (method-lambda initargs)
546
       (call-next-method)
547
     (values
548
      method-lambda
549
      (list* '.method-properties.
550
             (let* ((declare-forms (remove-if-not (%starts-with 'declare) lambda))
551
                    (declarations (apply #'append (mapcar #'rest declare-forms))))
552
               (reduce #'union (remove-if-not (%starts-with 'method-properties) declarations)
553
                       :key #'rest
554
                       :initial-value '()))
555
             initargs))))
556
 
557
 (defmethod metaobject-sealable-p ((psm potentially-sealable-method))
558
   (every #'specializer-sealed-p (method-specializers psm)))
559
 
560
 (defmethod seal-metaobject :before ((psm potentially-sealable-method))
561
   (mapcar #'seal-specializer (method-specializers psm)))
562
 
563
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
564
 ;;;
565
 ;;; Derived Classes
566
 
567
 (defclass potentially-sealable-standard-method
568
     (standard-method potentially-sealable-method)
569
   ())
570
 
571
 (defclass sealable-generic-function (sealable-metaobject-mixin generic-function)
572
   ((%sealed-domains
573
     :initform '()
574
     :type list
575
     :reader sealed-domains
576
     :writer (setf %sealed-domains)))
577
   (:default-initargs
578
    :method-class (find-class 'potentially-sealable-method))
579
   (:metaclass funcallable-standard-class))
580
 
581
 ;;; Check that the supplied domain is sane.
582
 (defmethod seal-domain
583
     ((sgf sealable-generic-function)
584
      (domain t))
585
   (seal-domain sgf (ensure-domain domain)))
586
 
587
 (defmethod seal-domain :around
588
     ((sgf sealable-generic-function)
589
      (domain domain))
590
   ;; Ensure that we don't seal any domain more than once.
591
   (unless (find domain (sealed-domains sgf) :test #'domain-equal)
592
     (call-next-method sgf domain)))
593
 
594
 ;;; Ensure that the generic function is sealed, and that the newly sealed
595
 ;;; domain is disjoint from other domains.
596
 (defmethod seal-domain :before
597
     ((sgf sealable-generic-function)
598
      (domain domain))
599
   ;; Ensure that the length of the domain matches the number of mandatory
600
   ;; arguments of the generic function.
601
   (unless (= (domain-arity domain)
602
              (length (generic-function-argument-precedence-order sgf)))
603
     (error "~@<Cannot seal the domain ~S with arity ~R ~
604
                of the generic function ~S with arity ~R.~@:>"
605
            (mapcar #'specializer-type (domain-specializers domain))
606
            (domain-arity domain)
607
            (generic-function-name sgf)
608
            (length (generic-function-argument-precedence-order sgf))))
609
   ;; Attempt to seal the supplied generic function.
610
   (seal-generic-function sgf)
611
   ;; Ensure that the domain does not intersect any existing sealed domains.
612
   (dolist (existing-domain (sealed-domains sgf))
613
     (when (domain-intersectionp domain existing-domain)
614
       (error "~@<Cannot seal the domain ~S of the generic function ~S, ~
615
                because it intersects with the existing domain ~S.~@:>"
616
              (mapcar #'specializer-type domain)
617
              sgf
618
              (mapcar #'specializer-type existing-domain)))))
619
 
620
 ;;; Add a new sealed domain.
621
 (defmethod seal-domain
622
     ((sgf sealable-generic-function)
623
      (domain domain))
624
   (dolist (method (generic-function-methods sgf))
625
     (when (domain-intersectionp (method-domain method) domain)
626
       (unless (domain-subsetp (method-domain method) domain)
627
         (error "~@<The method ~S with specializers ~S is only partially ~
628
                    within the sealed domain ~S.~:@>"
629
                method
630
                (mapcar #'specializer-type (method-specializers method))
631
                (mapcar #'specializer-type (domain-specializers domain))))
632
       (seal-method method)))
633
   (setf (%sealed-domains sgf)
634
         (cons domain (sealed-domains sgf))))
635
 
636
 ;;; Skip the call to add-method if the list of specializers is equal to
637
 ;;; that of an existing, sealed method.
638
 (defmethod add-method :around
639
     ((sgf sealable-generic-function)
640
      (psm potentially-sealable-method))
641
   (dolist (method (generic-function-methods sgf))
642
     (when (and (method-sealed-p method)
643
                (equal (method-specializers psm)
644
                       (method-specializers method)))
645
       (return-from add-method psm)))
646
   (call-next-method))
647
 
648
 ;;; Ensure that the method to be added is disjoint from all sealed domains.
649
 (defmethod add-method :before
650
     ((sgf sealable-generic-function)
651
      (psm potentially-sealable-method))
652
   (dolist (domain (sealed-domains sgf))
653
     (when (domain-intersectionp domain (method-domain psm))
654
       (error "~@<Cannot add the method ~S with specializers ~S to ~
655
                  the sealed generic function ~S, because it intersects ~
656
                  with the existing sealed domain ~S.~:@>"
657
              psm (method-specializers psm)
658
              sgf (mapcar #'specializer-type (domain-specializers domain))))))
659
 
660
 ;;; Ensure that the method to be removed is disjoint from all sealed domains.
661
 (defmethod remove-method :before
662
     ((sgf sealable-generic-function)
663
      (psm potentially-sealable-method))
664
   (dolist (domain (sealed-domains sgf))
665
     (when (domain-intersectionp domain (method-domain psm))
666
       (error "~@<Cannot remove the method ~S with specializers ~S from ~
667
                  the sealed generic function ~S, because it intersects ~
668
                  with the existing sealed domain ~S.~:@>"
669
              psm (method-specializers psm)
670
              sgf (mapcar #'specializer-type (domain-specializers domain))))))
671
 
672
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
673
 ;;;
674
 ;;; Derived Classes
675
 
676
 (defclass sealable-standard-generic-function
677
     (standard-generic-function sealable-generic-function)
678
   ()
679
   (:default-initargs
680
    :method-class (find-class 'potentially-sealable-standard-method))
681
   (:metaclass funcallable-standard-class))
682
 
683
 ;;; Finding a suitable prototype for eql specializers is easy.
684
 (defmethod specializer-prototype ((eql-specializer eql-specializer)
685
                                   &optional excluded-specializers)
686
   (if (member eql-specializer excluded-specializers)
687
       (values nil nil)
688
       (values (eql-specializer-object eql-specializer) t)))
689
 
690
 (defun eql-specializer-p (object)
691
   (typep object 'eql-specializer))
692
 
693
 (defmethod specializer-prototype ((class class) &optional excluded-specializers)
694
   (let* ((excluded-non-eql-specializers (remove-if #'eql-specializer-p excluded-specializers))
695
          (excluded-eql-specializers (remove-if-not #'eql-specializer-p excluded-specializers))
696
          (excluded-objects (mapcar #'eql-specializer-object excluded-eql-specializers))
697
          (excluded-types (mapcar #'specializer-type excluded-non-eql-specializers)))
698
     (map-class-prototypes
699
      (lambda (prototype)
700
        ;; The prototype must not be a member of the excluded objects.
701
        (when (not (member prototype excluded-objects))
702
          ;; The prototype must not be of one of the excluded types.
703
          (when (notany
704
                 (lambda (excluded-type)
705
                   (typep prototype excluded-type))
706
                 excluded-types)
707
            (return-from specializer-prototype (values prototype t)))))
708
      class)
709
     (values nil nil)))
710
 
711
 ;;; The difficult part is to find suitable prototypes for specializers that
712
 ;;; are classes.  Ideally, we want several prototypes for each class, such
713
 ;;; that we can avoid collisions with excluded specializers.  Our technique
714
 ;;; is to find prototypes from two sources - the value returned by the MOP
715
 ;;; function CLASS-PROTOTYPE, and manually curated lists of prototypes for
716
 ;;; each class, which we store in the hash table *CLASS-PROTOTYPES*.
717
 
718
 (defvar *class-prototypes* (make-hash-table :test #'eq))
719
 
720
 (defun map-class-prototypes (function class)
721
   (let ((visited-classes (make-hash-table :test #'eq)))
722
     (labels ((visit-class (class)
723
                (unless (gethash class visited-classes)
724
                  (setf (gethash class visited-classes) t)
725
                  (loop for prototype in (gethash class *class-prototypes* '()) do
726
                    (funcall function prototype))
727
                  (mapc #'visit-class (class-direct-subclasses class))
728
                  ;; CLASS-PROTOTYPE is difficult to handle...
729
                  (when (class-finalized-p class)
730
                    (let ((prototype (class-prototype class)))
731
                      ;; Surprisingly, some implementations don't always
732
                      ;; return a CLASS-PROTOTYPE that is an instance of the
733
                      ;; given class.  So we only scan the prototype if it is
734
                      ;; actually valid.
735
                      (when (typep prototype class)
736
                        (funcall function prototype)))))))
737
       (visit-class class))))
738
 
739
 (defun register-class-prototype (prototype)
740
   (pushnew prototype (gethash (class-of prototype) *class-prototypes* '())
741
            :test #'equalp))
742
 
743
 ;; Register list prototypes.
744
 (register-class-prototype '(.prototype.))
745
 (register-class-prototype nil)
746
 
747
 (defparameter *array-element-types*
748
   (remove-duplicates
749
    (mapcar #'upgraded-array-element-type
750
            (append '(short-float single-float double-float long-float base-char character t)
751
                    '((complex short-float)
752
                      (complex single-float)
753
                      (complex double-float)
754
                      (complex long-float))
755
                    (loop for bits from 1 to 64
756
                          collect `(unsigned-byte ,bits)
757
                          collect `(signed-byte ,bits))))
758
    :test #'equal))
759
 
760
 (defun array-initial-element (element-type)
761
   (cond ((subtypep element-type 'number)
762
          (coerce 0 element-type))
763
         ((subtypep element-type 'character)
764
          (coerce #\0 element-type))
765
         (t t)))
766
 
767
 ;; Register vector and array prototypes.
768
 (loop for adjustable in '(nil t) do
769
   (loop for fill-pointer in '(nil t) do
770
     (loop for dimensions in '(() (2) (2 2)) do
771
       (loop for element-type in *array-element-types* do
772
         (let ((storage-vector
773
                 (make-array (reduce #'* dimensions)
774
                             :element-type element-type
775
                             :initial-element (array-initial-element element-type))))
776
           (register-class-prototype
777
            (make-array dimensions
778
                        :adjustable adjustable
779
                        :fill-pointer (and (= 1 (length dimensions)) fill-pointer)
780
                        :element-type element-type
781
                        :displaced-to storage-vector))
782
           (register-class-prototype
783
            (make-array dimensions
784
                        :adjustable adjustable
785
                        :fill-pointer (and (= 1 (length dimensions)) fill-pointer)
786
                        :element-type element-type
787
                        :initial-element (array-initial-element element-type))))))))
788
 
789
 ;; Register integer and rational prototypes.
790
 (loop for integer in '(19 1337 1338 91676) do
791
   (register-class-prototype (+ integer))
792
   (register-class-prototype (- integer)))
793
 (loop for bits = 1 then (* bits 2) until (>= bits 512)
794
       for value = (expt 2 bits) do
795
         (loop for value in (list (1+ value) value (1- value)) do
796
           (register-class-prototype value)
797
           (register-class-prototype (- value))
798
           (register-class-prototype (/ value 17))))
799
 
800
 ;; Register float and complex float prototypes.
801
 (register-class-prototype pi)
802
 (register-class-prototype (- pi))
803
 (register-class-prototype (exp 1S0))
804
 (register-class-prototype (exp 1F0))
805
 (register-class-prototype (exp 1D0))
806
 (register-class-prototype (exp 1L0))
807
 (mapcar #'register-class-prototype
808
         (list most-positive-short-float
809
               most-positive-single-float
810
               most-positive-double-float
811
               most-positive-long-float
812
               most-negative-short-float
813
               most-negative-single-float
814
               most-negative-double-float
815
               most-positive-long-float
816
               short-float-epsilon
817
               single-float-epsilon
818
               double-float-epsilon
819
               long-float-epsilon
820
               short-float-negative-epsilon
821
               single-float-negative-epsilon
822
               double-float-negative-epsilon
823
               long-float-negative-epsilon))
824
 (loop for base in '(-0.7L0 -0.1L0 -0.0L0 +0.0L0 +0.1L0 +0.7L0) do
825
   (loop for fp-type in '(short-float single-float double-float long-float) do
826
     (loop for exponent in '(1 2 3 5 7 23 99) do
827
       (let ((float (scale-float (coerce base fp-type) exponent)))
828
         (register-class-prototype float)
829
         (register-class-prototype (complex (float 0 float) float))))))
830
 
831
 ;; Register character prototypes.
832
 (loop for char across "The quick brown fox jumps over the lazy dog." do
833
   (register-class-prototype (char-downcase char))
834
   (register-class-prototype (char-upcase char)))
835
 (loop for char across "0123456789!$\"'(),_-./:;?+<=>#%&*@[\\]{\|}`^~" do
836
   (register-class-prototype char))
837
 (loop for char in '(#\backspace #\tab #\newline #\linefeed #\page #\return #\space #\rubout) do
838
   (register-class-prototype char))
839
 
840
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
841
 ;;;
842
 ;;; Reasoning About Specializer Specificity
843
 
844
 (defclass snode ()
845
   (;; The specializer of an snode.
846
    (%specializer :initarg :specializer :accessor snode-specializer)
847
    ;; A (possibly empty) list of snodes for each child class or eql specializer.
848
    (%children :initform '() :accessor snode-children)
849
    ;; A list of snodes with one entry for each parent class.
850
    (%parents :initform '() :accessor snode-parents)
851
    ;; Whether the snode has already been visited.
852
    (%visitedp :initform nil :accessor snode-visitedp)
853
    ;; Whether the snode corresponds to a specializer of an existing method
854
    ;; or the domain.
855
    (%relevantp :initform nil :accessor snode-relevantp)))
856
 
857
 (defun snode-type (snode)
858
   (type-specifier-and
859
    (specializer-type (snode-specializer snode))
860
    (type-specifier-not
861
     (apply #'type-specifier-or
862
            (loop for subspecializer in (snode-children snode)
863
                  collect
864
                  (specializer-type
865
                   (snode-specializer subspecializer)))))))
866
 
867
 (defun snode-prototype (snode)
868
   (specializer-prototype
869
    (snode-specializer snode)
870
    (mapcar #'snode-specializer (snode-children snode))))
871
 
872
 (defvar *snode-table*)
873
 
874
 (defun specializer-snode (specializer)
875
   (multiple-value-bind (snode present-p)
876
       (gethash specializer *snode-table*)
877
     (if present-p
878
         snode
879
         (let ((snode (make-instance 'snode :specializer specializer)))
880
           (setf (gethash specializer *snode-table*) snode)
881
           snode))))
882
 
883
 (defun snode-add-edge (super-snode sub-snode)
884
   (pushnew super-snode (snode-parents sub-snode))
885
   (pushnew sub-snode (snode-children super-snode))
886
   (values))
887
 
888
 (defun type-prototype-pairs (specializers domain)
889
   (let* ((*snode-table* (make-hash-table))
890
          (specializer-snodes (mapcar #'specializer-snode specializers))
891
          (domain-snode (specializer-snode domain)))
892
     ;; Initialize domain and specializer snodes.
893
     (dolist (snode specializer-snodes)
894
       (setf (snode-relevantp snode) t))
895
     (setf (snode-relevantp domain-snode) t)
896
     ;; Now connect all snodes.
897
     (labels ((visit (current relevant)
898
                (unless (snode-visitedp current)
899
                  (setf (snode-visitedp current) t)
900
                  (unless (eql current domain)
901
                    (dolist (specializer
902
                             (specializer-direct-superspecializers
903
                              (snode-specializer current)))
904
                      (let ((super (specializer-snode specializer)))
905
                        (cond ((snode-relevantp super)
906
                               (snode-add-edge super relevant)
907
                               (visit super super))
908
                              (t
909
                               (visit super relevant)))))))))
910
       (mapc #'visit specializer-snodes specializer-snodes))
911
     ;; Finally, build all pairs.
912
     (let ((pairs '()))
913
       (loop for snode being the hash-values of *snode-table* do
914
         (when (snode-relevantp snode)
915
           (multiple-value-bind (prototype prototype-p)
916
               (snode-prototype snode)
917
             (when prototype-p
918
               (push (list (snode-type snode) prototype)
919
                     pairs)))))
920
       pairs)))
921
 
922
 ;;; In this file, we compute the static call signatures of a given, sealed
923
 ;;; generic function. A static call signature consists of a list of types,
924
 ;;; and a list of prototypes.  The list of types is guaranteed to be
925
 ;;; non-overlapping with the types of any other call signature.  The list
926
 ;;; of prototypes is chosen such that the list of applicable methods of
927
 ;;; these prototypes is representative for all arguments of the types of
928
 ;;; the call signature.
929
 
930
 (defclass static-call-signature ()
931
   ((%types
932
     :initarg :types
933
     :reader static-call-signature-types)
934
    (%prototypes
935
     :initarg :prototypes
936
     :reader static-call-signature-prototypes)))
937
 
938
 (defmethod print-object ((scs static-call-signature) stream)
939
   (print-unreadable-object (scs stream :type t :identity t)
940
     (format stream "~S ~S"
941
             (static-call-signature-types scs)
942
             (static-call-signature-prototypes scs))))
943
 
944
 (defmethod make-load-form
945
     ((static-call-signature static-call-signature) &optional environment)
946
   (make-load-form-saving-slots
947
    static-call-signature
948
    :slot-names '(%types %prototypes)
949
    :environment environment))
950
 
951
 (defmethod externalizable-object-p
952
     ((static-call-signature static-call-signature))
953
   (and
954
    (every #'externalizable-object-p
955
           (static-call-signature-types static-call-signature))
956
    (every #'externalizable-object-p
957
           (static-call-signature-prototypes static-call-signature))))
958
 
959
 (defmethod compute-static-call-signatures
960
     ((sgf sealable-generic-function)
961
      (domain domain))
962
   (let* ((sealed-methods
963
            (remove-if-not
964
             (lambda (method)
965
               (domain-intersectionp (method-domain method) domain))
966
             (generic-function-methods sgf)))
967
          (list-of-specializers
968
            (mapcar #'method-specializers sealed-methods))
969
          (static-call-signatures '()))
970
     (unless (null list-of-specializers)
971
       (map-types-and-prototypes
972
        (lambda (types prototypes)
973
          (push (make-instance 'static-call-signature
974
                  :types types
975
                  :prototypes prototypes)
976
                static-call-signatures))
977
        ;; Transpose the list of specializers so that we operate on each
978
        ;; argument instead of on each method.
979
        (apply #'mapcar #'list list-of-specializers)
980
        domain))
981
     static-call-signatures))
982
 
983
 (defun map-types-and-prototypes (fn specializers-list domain)
984
   (assert (= (length specializers-list)
985
              (domain-arity domain)))
986
   (labels ((rec (sl specializers types prototypes)
987
              (if (null sl)
988
                  (funcall fn (reverse types) (reverse prototypes))
989
                  (loop for (type prototype)
990
                          in (type-prototype-pairs
991
                              (first sl)
992
                              (first specializers))
993
                        do (rec (rest sl)
994
                                (rest specializers)
995
                                (cons type types)
996
                                (cons prototype prototypes))))))
997
     (rec specializers-list (domain-specializers domain) '() '())))