forked from dmitryvk/sbcl-win32-threads
/
class.lisp
1566 lines (1486 loc) · 70.2 KB
/
class.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
;;;; This file contains structures and functions for the maintenance of
;;;; basic information about defined types. Different object systems
;;;; can be supported simultaneously.
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
(in-package "SB!KERNEL")
(!begin-collecting-cold-init-forms)
;;;; the CLASSOID structure
;;; The CLASSOID structure is a supertype of all classoid types. A
;;; CLASSOID is also a CTYPE structure as recognized by the type
;;; system. (FIXME: It's also a type specifier, though this might go
;;; away as with the merger of SB-PCL:CLASS and CL:CLASS it's no
;;; longer necessary)
(def!struct (classoid
(:make-load-form-fun classoid-make-load-form-fun)
(:include ctype
(class-info (type-class-or-lose 'classoid)))
(:constructor nil)
#-no-ansi-print-object
(:print-object
(lambda (class stream)
(let ((name (classoid-name class)))
(print-unreadable-object (class stream
:type t
:identity (not name))
(format stream
;; FIXME: Make sure that this prints
;; reasonably for anonymous classes.
"~:[anonymous~;~:*~S~]~@[ (~(~A~))~]"
name
(classoid-state class))))))
#-sb-xc-host (:pure nil))
;; the value to be returned by CLASSOID-NAME.
(name nil :type symbol)
;; the current layout for this class, or NIL if none assigned yet
(layout nil :type (or layout null))
;; How sure are we that this class won't be redefined?
;; :READ-ONLY = We are committed to not changing the effective
;; slots or superclasses.
;; :SEALED = We can't even add subclasses.
;; NIL = Anything could happen.
(state nil :type (member nil :read-only :sealed))
;; direct superclasses of this class
(direct-superclasses () :type list)
;; representation of all of the subclasses (direct or indirect) of
;; this class. This is NIL if no subclasses or not initalized yet;
;; otherwise, it's an EQ hash-table mapping CLASSOID objects to the
;; subclass layout that was in effect at the time the subclass was
;; created.
(subclasses nil :type (or null hash-table))
;; the PCL class (= CL:CLASS, but with a view to future flexibility
;; we don't just call it the CLASS slot) object for this class, or
;; NIL if none assigned yet
(pcl-class nil))
(defun classoid-make-load-form-fun (class)
(/show "entering CLASSOID-MAKE-LOAD-FORM-FUN" class)
(let ((name (classoid-name class)))
(unless (and name (eq (find-classoid name nil) class))
(/show "anonymous/undefined class case")
(error "can't use anonymous or undefined class as constant:~% ~S"
class))
`(locally
;; KLUDGE: There's a FIND-CLASSOID DEFTRANSFORM for constant
;; class names which creates fast but non-cold-loadable,
;; non-compact code. In this context, we'd rather have compact,
;; cold-loadable code. -- WHN 19990928
(declare (notinline find-classoid))
(find-classoid ',name))))
;;;; basic LAYOUT stuff
;;; Note: This bound is set somewhat less than MOST-POSITIVE-FIXNUM
;;; in order to guarantee that several hash values can be added without
;;; overflowing into a bignum.
(def!constant layout-clos-hash-limit (1+ (ash sb!xc:most-positive-fixnum -3))
#!+sb-doc
"the exclusive upper bound on LAYOUT-CLOS-HASH values")
(def!type layout-clos-hash () '(integer 0 #.layout-clos-hash-limit))
;;; a list of conses, initialized by genesis
;;;
;;; In each cons, the car is the symbol naming the layout, and the
;;; cdr is the layout itself.
(defvar *!initial-layouts*)
;;; a table mapping class names to layouts for classes we have
;;; referenced but not yet loaded. This is initialized from an alist
;;; created by genesis describing the layouts that genesis created at
;;; cold-load time.
(defvar *forward-referenced-layouts*)
(!cold-init-forms
;; Protected by *WORLD-LOCK*
(setq *forward-referenced-layouts* (make-hash-table :test 'equal))
#-sb-xc-host (progn
(/show0 "processing *!INITIAL-LAYOUTS*")
(dolist (x *!initial-layouts*)
(setf (layout-clos-hash (cdr x)) (random-layout-clos-hash))
(setf (gethash (car x) *forward-referenced-layouts*)
(cdr x)))
(/show0 "done processing *!INITIAL-LAYOUTS*")))
;;; The LAYOUT structure is pointed to by the first cell of instance
;;; (or structure) objects. It represents what we need to know for
;;; type checking and garbage collection. Whenever a class is
;;; incompatibly redefined, a new layout is allocated. If two object's
;;; layouts are EQ, then they are exactly the same type.
;;;
;;; *** IMPORTANT ***
;;;
;;; If you change the slots of LAYOUT, you need to alter genesis as
;;; well, since the initialization of layout slots is hardcoded there.
;;;
;;; FIXME: ...it would be better to automate this, of course...
(def!struct (layout
;; KLUDGE: A special hack keeps this from being
;; called when building code for the
;; cross-compiler. See comments at the DEFUN for
;; this. -- WHN 19990914
(:make-load-form-fun #-sb-xc-host ignore-it
;; KLUDGE: DEF!STRUCT at #+SB-XC-HOST
;; time controls both the
;; build-the-cross-compiler behavior
;; and the run-the-cross-compiler
;; behavior. The value below only
;; works for build-the-cross-compiler.
;; There's a special hack in
;; EMIT-MAKE-LOAD-FORM which gives
;; effectively IGNORE-IT behavior for
;; LAYOUT at run-the-cross-compiler
;; time. It would be cleaner to
;; actually have an IGNORE-IT value
;; stored, but it's hard to see how to
;; do that concisely with the current
;; DEF!STRUCT setup. -- WHN 19990930
#+sb-xc-host
make-load-form-for-layout))
;; a pseudo-random hash value for use by CLOS. KLUDGE: The fact
;; that this slot is at offset 1 is known to GENESIS.
(clos-hash (random-layout-clos-hash) :type layout-clos-hash)
;; the class that this is a layout for
(classoid (missing-arg) :type classoid)
;; The value of this slot can be:
;; * :UNINITIALIZED if not initialized yet;
;; * NIL if this is the up-to-date layout for a class; or
;; * T if this layout has been invalidated (by being replaced by
;; a new, more-up-to-date LAYOUT).
;; * something else (probably a list) if the class is a PCL wrapper
;; and PCL has made it invalid and made a note to itself about it
(invalid :uninitialized :type (or cons (member nil t :uninitialized)))
;; the layouts for all classes we inherit. If hierarchical, i.e. if
;; DEPTHOID >= 0, then these are ordered by ORDER-LAYOUT-INHERITS
;; (least to most specific), so that each inherited layout appears
;; at its expected depth, i.e. at its LAYOUT-DEPTHOID value.
;;
;; Remaining elements are filled by the non-hierarchical layouts or,
;; if they would otherwise be empty, by copies of succeeding layouts.
(inherits #() :type simple-vector)
;; If inheritance is not hierarchical, this is -1. If inheritance is
;; hierarchical, this is the inheritance depth, i.e. (LENGTH INHERITS).
;; Note:
;; (1) This turns out to be a handy encoding for arithmetically
;; comparing deepness; it is generally useful to do a bare numeric
;; comparison of these depthoid values, and we hardly ever need to
;; test whether the values are negative or not.
;; (2) This was called INHERITANCE-DEPTH in classic CMU CL. It was
;; renamed because some of us find it confusing to call something
;; a depth when it isn't quite.
(depthoid -1 :type layout-depthoid)
;; the number of top level descriptor cells in each instance
(length 0 :type index)
;; If this layout has some kind of compiler meta-info, then this is
;; it. If a structure, then we store the DEFSTRUCT-DESCRIPTION here.
(info nil)
;; This is true if objects of this class are never modified to
;; contain dynamic pointers in their slots or constant-like
;; substructure (and hence can be copied into read-only space by
;; PURIFY).
;;
;; This slot is known to the C runtime support code.
(pure nil :type (member t nil 0))
;; Number of raw words at the end.
;; This slot is known to the C runtime support code.
(n-untagged-slots 0 :type index)
;; Definition location
(source-location nil)
;; Information about slots in the class to PCL: this provides fast
;; access to slot-definitions and locations by name, etc.
(slot-table #(nil) :type simple-vector)
;; True IFF the layout belongs to a standand-instance or a
;; standard-funcallable-instance -- that is, true only if the layout
;; is really a wrapper.
;;
;; FIXME: If we unify wrappers and layouts this can go away, since
;; it is only used in SB-PCL::EMIT-FETCH-WRAPPERS, which can then
;; use INSTANCE-SLOTS-LAYOUT instead (if there is are no slot
;; layouts, there are no slots for it to pull.)
(for-std-class-p nil :type boolean :read-only t))
(def!method print-object ((layout layout) stream)
(print-unreadable-object (layout stream :type t :identity t)
(format stream
"for ~S~@[, INVALID=~S~]"
(layout-proper-name layout)
(layout-invalid layout))))
(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
(defun layout-proper-name (layout)
(classoid-proper-name (layout-classoid layout))))
;;;; support for the hash values used by CLOS when working with LAYOUTs
;;; a generator for random values suitable for the CLOS-HASH slots of
;;; LAYOUTs. We use our own RANDOM-STATE here because we'd like
;;; pseudo-random values to come the same way in the target even when
;;; we make minor changes to the system, in order to reduce the
;;; mysteriousness of possible CLOS bugs.
(defvar *layout-clos-hash-random-state*)
(defun random-layout-clos-hash ()
;; FIXME: I'm not sure why this expression is (1+ (RANDOM FOO)),
;; returning a strictly positive value. I copied it verbatim from
;; CMU CL INITIALIZE-LAYOUT-HASH, so presumably it works, but I
;; dunno whether the hash values are really supposed to be 1-based.
;; They're declared as INDEX.. Or is this a hack to try to avoid
;; having to use bignum arithmetic? Or what? An explanation would be
;; nice.
;;
;; an explanation is provided in Kiczales and Rodriguez, "Efficient
;; Method Dispatch in PCL", 1990. -- CSR, 2005-11-30
(1+ (random (1- layout-clos-hash-limit)
(if (boundp '*layout-clos-hash-random-state*)
*layout-clos-hash-random-state*
(setf *layout-clos-hash-random-state*
(make-random-state))))))
;;; If we can't find any existing layout, then we create a new one
;;; storing it in *FORWARD-REFERENCED-LAYOUTS*. In classic CMU CL, we
;;; used to immediately check for compatibility, but for
;;; cross-compilability reasons (i.e. convenience of using this
;;; function in a MAKE-LOAD-FORM expression) that functionality has
;;; been split off into INIT-OR-CHECK-LAYOUT.
(declaim (ftype (sfunction (symbol) layout) find-layout))
(defun find-layout (name)
;; This seems to be currently used only from the compiler, but make
;; it thread-safe all the same. We need to lock *F-R-L* before doing
;; FIND-CLASSOID in case (SETF FIND-CLASSOID) happens in parallel.
(let ((table *forward-referenced-layouts*))
(with-world-lock ()
(let ((classoid (find-classoid name nil)))
(or (and classoid (classoid-layout classoid))
(gethash name table)
(setf (gethash name table)
(make-layout :classoid (or classoid (make-undefined-classoid name)))))))))
;;; If LAYOUT is uninitialized, initialize it with CLASSOID, LENGTH,
;;; INHERITS, and DEPTHOID, otherwise require that it be consistent
;;; with CLASSOID, LENGTH, INHERITS, and DEPTHOID.
;;;
;;; UNDEFINED-CLASS values are interpreted specially as "we don't know
;;; anything about the class", so if LAYOUT is initialized, any
;;; preexisting class slot value is OK, and if it's not initialized,
;;; its class slot value is set to an UNDEFINED-CLASS. -- FIXME: This
;;; is no longer true, :UNINITIALIZED used instead.
(declaim (ftype (function (layout classoid index simple-vector layout-depthoid
index)
layout)
%init-or-check-layout))
(defun %init-or-check-layout
(layout classoid length inherits depthoid nuntagged)
(cond ((eq (layout-invalid layout) :uninitialized)
;; There was no layout before, we just created one which
;; we'll now initialize with our information.
(setf (layout-length layout) length
(layout-inherits layout) inherits
(layout-depthoid layout) depthoid
(layout-n-untagged-slots layout) nuntagged
(layout-classoid layout) classoid
(layout-invalid layout) nil))
;; FIXME: Now that LAYOUTs are born :UNINITIALIZED, maybe this
;; clause is not needed?
((not *type-system-initialized*)
(setf (layout-classoid layout) classoid))
(t
;; There was an old layout already initialized with old
;; information, and we'll now check that old information
;; which was known with certainty is consistent with current
;; information which is known with certainty.
(check-layout layout classoid length inherits depthoid nuntagged)))
layout)
;;; In code for the target Lisp, we don't use dump LAYOUTs using the
;;; standard load form mechanism, we use special fops instead, in
;;; order to make cold load come out right. But when we're building
;;; the cross-compiler, we can't do that because we don't have access
;;; to special non-ANSI low-level things like special fops, and we
;;; don't need to do that anyway because our code isn't going to be
;;; cold loaded, so we use the ordinary load form system.
;;;
;;; KLUDGE: A special hack causes this not to be called when we are
;;; building code for the target Lisp. It would be tidier to just not
;;; have it in place when we're building the target Lisp, but it
;;; wasn't clear how to do that without rethinking DEF!STRUCT quite a
;;; bit, so I punted. -- WHN 19990914
#+sb-xc-host
(defun make-load-form-for-layout (layout &optional env)
(declare (type layout layout))
(declare (ignore env))
(when (layout-invalid layout)
(compiler-error "can't dump reference to obsolete class: ~S"
(layout-classoid layout)))
(let ((name (classoid-name (layout-classoid layout))))
(unless name
(compiler-error "can't dump anonymous LAYOUT: ~S" layout))
;; Since LAYOUT refers to a class which refers back to the LAYOUT,
;; we have to do this in two stages, like the TREE-WITH-PARENT
;; example in the MAKE-LOAD-FORM entry in the ANSI spec.
(values
;; "creation" form (which actually doesn't create a new LAYOUT if
;; there's a preexisting one with this name)
`(find-layout ',name)
;; "initialization" form (which actually doesn't initialize
;; preexisting LAYOUTs, just checks that they're consistent).
`(%init-or-check-layout ',layout
',(layout-classoid layout)
',(layout-length layout)
',(layout-inherits layout)
',(layout-depthoid layout)
',(layout-n-untagged-slots layout)))))
;;; If LAYOUT's slot values differ from the specified slot values in
;;; any interesting way, then give a warning and return T.
(declaim (ftype (function (simple-string
layout
simple-string
index
simple-vector
layout-depthoid
index))
redefine-layout-warning))
(defun redefine-layout-warning (old-context old-layout
context length inherits depthoid nuntagged)
(declare (type layout old-layout) (type simple-string old-context context))
(let ((name (layout-proper-name old-layout)))
(or (let ((old-inherits (layout-inherits old-layout)))
(or (when (mismatch old-inherits
inherits
:key #'layout-proper-name)
(warn "change in superclasses of class ~S:~% ~
~A superclasses: ~S~% ~
~A superclasses: ~S"
name
old-context
(map 'list #'layout-proper-name old-inherits)
context
(map 'list #'layout-proper-name inherits))
t)
(let ((diff (mismatch old-inherits inherits)))
(when diff
(warn
"in class ~S:~% ~
~@(~A~) definition of superclass ~S is incompatible with~% ~
~A definition."
name
old-context
(layout-proper-name (svref old-inherits diff))
context)
t))))
(let ((old-length (layout-length old-layout)))
(unless (= old-length length)
(warn "change in instance length of class ~S:~% ~
~A length: ~W~% ~
~A length: ~W"
name
old-context old-length
context length)
t))
(let ((old-nuntagged (layout-n-untagged-slots old-layout)))
(unless (= old-nuntagged nuntagged)
(warn "change in instance layout of class ~S:~% ~
~A untagged slots: ~W~% ~
~A untagged slots: ~W"
name
old-context old-nuntagged
context nuntagged)
t))
(unless (= (layout-depthoid old-layout) depthoid)
(warn "change in the inheritance structure of class ~S~% ~
between the ~A definition and the ~A definition"
name old-context context)
t))))
;;; Require that LAYOUT data be consistent with CLASS, LENGTH,
;;; INHERITS, and DEPTHOID.
(declaim (ftype (function
(layout classoid index simple-vector layout-depthoid index))
check-layout))
(defun check-layout (layout classoid length inherits depthoid nuntagged)
(aver (eq (layout-classoid layout) classoid))
(when (redefine-layout-warning "current" layout
"compile time" length inherits depthoid
nuntagged)
;; Classic CMU CL had more options here. There are several reasons
;; why they might want more options which are less appropriate for
;; us: (1) It's hard to fit the classic CMU CL flexible approach
;; into the ANSI-style MAKE-LOAD-FORM system, and having a
;; non-MAKE-LOAD-FORM-style system is painful when we're trying to
;; make the cross-compiler run under vanilla ANSI Common Lisp. (2)
;; We have CLOS now, and if you want to be able to flexibly
;; redefine classes without restarting the system, it'd make sense
;; to use that, so supporting complexity in order to allow
;; modifying DEFSTRUCTs without restarting the system is a low
;; priority. (3) We now have the ability to rebuild the SBCL
;; system from scratch, so we no longer need this functionality in
;; order to maintain the SBCL system by modifying running images.
(error "The loaded code expects an incompatible layout for class ~S."
(layout-proper-name layout)))
(values))
;;; a common idiom (the same as CMU CL FIND-LAYOUT) rolled up into a
;;; single function call
;;;
;;; Used by the loader to forward-reference layouts for classes whose
;;; definitions may not have been loaded yet. This allows type tests
;;; to be loaded when the type definition hasn't been loaded yet.
(declaim (ftype (function (symbol index simple-vector layout-depthoid index)
layout)
find-and-init-or-check-layout))
(defun find-and-init-or-check-layout (name length inherits depthoid nuntagged)
(with-world-lock ()
(let ((layout (find-layout name)))
(%init-or-check-layout layout
(or (find-classoid name nil)
(layout-classoid layout))
length
inherits
depthoid
nuntagged))))
;;; Record LAYOUT as the layout for its class, adding it as a subtype
;;; of all superclasses. This is the operation that "installs" a
;;; layout for a class in the type system, clobbering any old layout.
;;; However, this does not modify the class namespace; that is a
;;; separate operation (think anonymous classes.)
;;; -- If INVALIDATE, then all the layouts for any old definition
;;; and subclasses are invalidated, and the SUBCLASSES slot is cleared.
;;; -- If DESTRUCT-LAYOUT, then this is some old layout, and is to be
;;; destructively modified to hold the same type information.
(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
(defun register-layout (layout &key (invalidate t) destruct-layout)
(declare (type layout layout) (type (or layout null) destruct-layout))
(with-world-lock ()
(let* ((classoid (layout-classoid layout))
(classoid-layout (classoid-layout classoid))
(subclasses (classoid-subclasses classoid)))
;; Attempting to register ourselves with a temporary undefined
;; class placeholder is almost certainly a programmer error. (I
;; should know, I did it.) -- WHN 19990927
(aver (not (undefined-classoid-p classoid)))
;; This assertion dates from classic CMU CL. The rationale is
;; probably that calling REGISTER-LAYOUT more than once for the
;; same LAYOUT is almost certainly a programmer error.
(aver (not (eq classoid-layout layout)))
;; Figure out what classes are affected by the change, and issue
;; appropriate warnings and invalidations.
(when classoid-layout
(%modify-classoid classoid)
(when subclasses
(dohash ((subclass subclass-layout) subclasses :locked t)
(%modify-classoid subclass)
(when invalidate
(%invalidate-layout subclass-layout))))
(when invalidate
(%invalidate-layout classoid-layout)
(setf (classoid-subclasses classoid) nil)))
(if destruct-layout
(setf (layout-invalid destruct-layout) nil
(layout-inherits destruct-layout) (layout-inherits layout)
(layout-depthoid destruct-layout)(layout-depthoid layout)
(layout-length destruct-layout) (layout-length layout)
(layout-n-untagged-slots destruct-layout) (layout-n-untagged-slots layout)
(layout-info destruct-layout) (layout-info layout)
(classoid-layout classoid) destruct-layout)
(setf (layout-invalid layout) nil
(classoid-layout classoid) layout))
(dovector (super-layout (layout-inherits layout))
(let* ((super (layout-classoid super-layout))
(subclasses (or (classoid-subclasses super)
(setf (classoid-subclasses super)
(make-hash-table :test 'eq
#-sb-xc-host #-sb-xc-host
:synchronized t)))))
(when (and (eq (classoid-state super) :sealed)
(not (gethash classoid subclasses)))
(warn "unsealing sealed class ~S in order to subclass it"
(classoid-name super))
(setf (classoid-state super) :read-only))
(setf (gethash classoid subclasses)
(or destruct-layout layout))))))
(values))
); EVAL-WHEN
;;; Arrange the inherited layouts to appear at their expected depth,
;;; ensuring that hierarchical type tests succeed. Layouts with
;;; DEPTHOID >= 0 (i.e. hierarchical classes) are placed first,
;;; at exactly that index in the INHERITS vector. Then, non-hierarchical
;;; layouts are placed in remaining elements. Then, any still-empty
;;; elements are filled with their successors, ensuring that each
;;; element contains a valid layout.
;;;
;;; This reordering may destroy CPL ordering, so the inherits should
;;; not be read as being in CPL order.
(defun order-layout-inherits (layouts)
(declare (simple-vector layouts))
(let ((length (length layouts))
(max-depth -1))
(dotimes (i length)
(let ((depth (layout-depthoid (svref layouts i))))
(when (> depth max-depth)
(setf max-depth depth))))
(let* ((new-length (max (1+ max-depth) length))
;; KLUDGE: 0 here is the "uninitialized" element. We need
;; to specify it explicitly for portability purposes, as
;; elements can be read before being set [ see below, "(EQL
;; OLD-LAYOUT 0)" ]. -- CSR, 2002-04-20
(inherits (make-array new-length :initial-element 0)))
(dotimes (i length)
(let* ((layout (svref layouts i))
(depth (layout-depthoid layout)))
(unless (eql depth -1)
(let ((old-layout (svref inherits depth)))
(unless (or (eql old-layout 0) (eq old-layout layout))
(error "layout depth conflict: ~S~%" layouts)))
(setf (svref inherits depth) layout))))
(do ((i 0 (1+ i))
(j 0))
((>= i length))
(declare (type index i j))
(let* ((layout (svref layouts i))
(depth (layout-depthoid layout)))
(when (eql depth -1)
(loop (when (eql (svref inherits j) 0)
(return))
(incf j))
(setf (svref inherits j) layout))))
(do ((i (1- new-length) (1- i)))
((< i 0))
(declare (type fixnum i))
(when (eql (svref inherits i) 0)
(setf (svref inherits i) (svref inherits (1+ i)))))
inherits)))
;;;; class precedence lists
;;; Topologically sort the list of objects to meet a set of ordering
;;; constraints given by pairs (A . B) constraining A to precede B.
;;; When there are multiple objects to choose, the tie-breaker
;;; function is called with both the list of object to choose from and
;;; the reverse ordering built so far.
(defun topological-sort (objects constraints tie-breaker)
(declare (list objects constraints)
(function tie-breaker))
(let ((obj-info (make-hash-table :size (length objects)))
(free-objs nil)
(result nil))
(dolist (constraint constraints)
(let ((obj1 (car constraint))
(obj2 (cdr constraint)))
(let ((info2 (gethash obj2 obj-info)))
(if info2
(incf (first info2))
(setf (gethash obj2 obj-info) (list 1))))
(let ((info1 (gethash obj1 obj-info)))
(if info1
(push obj2 (rest info1))
(setf (gethash obj1 obj-info) (list 0 obj2))))))
(dolist (obj objects)
(let ((info (gethash obj obj-info)))
(when (or (not info) (zerop (first info)))
(push obj free-objs))))
(loop
(flet ((next-result (obj)
(push obj result)
(dolist (successor (rest (gethash obj obj-info)))
(let* ((successor-info (gethash successor obj-info))
(count (1- (first successor-info))))
(setf (first successor-info) count)
(when (zerop count)
(push successor free-objs))))))
(cond ((endp free-objs)
(dohash ((obj info) obj-info)
(unless (zerop (first info))
(error "Topological sort failed due to constraint on ~S."
obj)))
(return (nreverse result)))
((endp (rest free-objs))
(next-result (pop free-objs)))
(t
(let ((obj (funcall tie-breaker free-objs result)))
(setf free-objs (remove obj free-objs))
(next-result obj))))))))
;;; standard class precedence list computation
(defun std-compute-class-precedence-list (class)
(let ((classes nil)
(constraints nil))
(labels ((note-class (class)
(unless (member class classes)
(push class classes)
(let ((superclasses (classoid-direct-superclasses class)))
(do ((prev class)
(rest superclasses (rest rest)))
((endp rest))
(let ((next (first rest)))
(push (cons prev next) constraints)
(setf prev next)))
(dolist (class superclasses)
(note-class class)))))
(std-cpl-tie-breaker (free-classes rev-cpl)
(dolist (class rev-cpl (first free-classes))
(let* ((superclasses (classoid-direct-superclasses class))
(intersection (intersection free-classes
superclasses)))
(when intersection
(return (first intersection)))))))
(note-class class)
(topological-sort classes constraints #'std-cpl-tie-breaker))))
;;;; object types to represent classes
;;; An UNDEFINED-CLASSOID is a cookie we make up to stick in forward
;;; referenced layouts. Users should never see them.
(def!struct (undefined-classoid
(:include classoid)
(:constructor make-undefined-classoid (name))))
;;; BUILT-IN-CLASS is used to represent the standard classes that
;;; aren't defined with DEFSTRUCT and other specially implemented
;;; primitive types whose only attribute is their name.
;;;
;;; Some BUILT-IN-CLASSes have a TRANSLATION, which means that they
;;; are effectively DEFTYPE'd to some other type (usually a union of
;;; other classes or a "primitive" type such as NUMBER, ARRAY, etc.)
;;; This translation is done when type specifiers are parsed. Type
;;; system operations (union, subtypep, etc.) should never encounter
;;; translated classes, only their translation.
(def!struct (built-in-classoid (:include classoid)
(:constructor make-built-in-classoid))
;; the type we translate to on parsing. If NIL, then this class
;; stands on its own; or it can be set to :INITIALIZING for a period
;; during cold-load.
(translation nil :type (or ctype (member nil :initializing))))
;;; STRUCTURE-CLASS represents what we need to know about structure
;;; classes. Non-structure "typed" defstructs are a special case, and
;;; don't have a corresponding class.
(def!struct (structure-classoid (:include classoid)
(:constructor make-structure-classoid))
;; If true, a default keyword constructor for this structure.
(constructor nil :type (or function null)))
;;;; classoid namespace
;;; We use an indirection to allow forward referencing of class
;;; definitions with load-time resolution.
(def!struct (classoid-cell
(:constructor make-classoid-cell (name &optional classoid))
(:make-load-form-fun (lambda (c)
`(find-classoid-cell
',(classoid-cell-name c)
:errorp t)))
#-no-ansi-print-object
(:print-object (lambda (s stream)
(print-unreadable-object (s stream :type t)
(prin1 (classoid-cell-name s) stream)))))
;; Name of class we expect to find.
(name nil :type symbol :read-only t)
;; Classoid or NIL if not yet defined.
(classoid nil :type (or classoid null))
;; PCL class, if any
(pcl-class nil))
;;; Protected by the hash-table lock, used only in FIND-CLASSOID-CELL.
(defvar *classoid-cells*)
(!cold-init-forms
(setq *classoid-cells* (make-hash-table :test 'eq)))
(defun find-classoid-cell (name &key create errorp)
(let ((table *classoid-cells*)
(real-name (uncross name)))
(or (with-locked-system-table (table)
(or (gethash real-name table)
(when create
(setf (gethash real-name table) (make-classoid-cell real-name)))))
(when errorp
(error 'simple-type-error
:datum nil
:expected-type 'class
:format-control "Class not yet defined: ~S"
:format-arguments (list name))))))
(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
;; Return the classoid with the specified NAME. If ERRORP is false,
;; then NIL is returned when no such class exists."
(defun find-classoid (name &optional (errorp t))
(declare (type symbol name))
(let ((cell (find-classoid-cell name :errorp errorp)))
(when cell (classoid-cell-classoid cell))))
(defun (setf find-classoid) (new-value name)
#-sb-xc (declare (type (or null classoid) new-value))
(aver new-value)
(let ((table *forward-referenced-layouts*))
(with-world-lock ()
(let ((cell (find-classoid-cell name :create t)))
(ecase (info :type :kind name)
((nil))
(:forthcoming-defclass-type
;; FIXME: Currently, nothing needs to be done in this case.
;; Later, when PCL is integrated tighter into SBCL, this
;; might need more work.
nil)
(:instance
(aver cell)
(let ((old-value (classoid-cell-classoid cell)))
(aver old-value)
;; KLUDGE: The reason these clauses aren't directly
;; parallel is that we need to use the internal
;; CLASSOID structure ourselves, because we don't
;; have CLASSes to work with until PCL is built. In
;; the host, CLASSes have an approximately
;; one-to-one correspondence with the target
;; CLASSOIDs (as well as with the target CLASSes,
;; modulo potential differences with respect to
;; conditions).
#+sb-xc-host
(let ((old (class-of old-value))
(new (class-of new-value)))
(unless (eq old new)
(bug "Trying to change the metaclass of ~S from ~S to ~S in the ~
cross-compiler."
name (class-name old) (class-name new))))
#-sb-xc-host
(let ((old (classoid-of old-value))
(new (classoid-of new-value)))
(unless (eq old new)
(warn "Changing meta-class of ~S from ~S to ~S."
name (classoid-name old) (classoid-name new))))))
(:primitive
(error "Cannot redefine standard type ~S." name))
(:defined
(warn "redefining DEFTYPE type to be a class: ~
~/sb-impl::print-symbol-with-prefix/" name)
(setf (info :type :expander name) nil
(info :type :lambda-list name) nil
(info :type :source-location name) nil)))
(remhash name table)
(%note-type-defined name)
;; we need to handle things like
;; (setf (find-class 'foo) (find-class 'integer))
;; and
;; (setf (find-class 'integer) (find-class 'integer))
(cond ((built-in-classoid-p new-value)
(setf (info :type :kind name)
(or (info :type :kind name) :defined))
(let ((translation (built-in-classoid-translation new-value)))
(when translation
(setf (info :type :translator name)
(lambda (c) (declare (ignore c)) translation)))))
(t
(setf (info :type :kind name) :instance)))
(setf (classoid-cell-classoid cell) new-value)
(unless (eq (info :type :compiler-layout name)
(classoid-layout new-value))
(setf (info :type :compiler-layout name)
(classoid-layout new-value))))))
new-value)
(defun %clear-classoid (name cell)
(ecase (info :type :kind name)
((nil))
(:defined)
(:primitive
(error "Attempt to remove :PRIMITIVE type: ~S" name))
((:forthcoming-defclass-type :instance)
(when cell
;; Note: We cannot remove the classoid cell from the table,
;; since compiled code may refer directly to the cell, and
;; getting a different cell for a classoid with the same name
;; just would not do.
;; Remove the proper name of the classoid.
(setf (classoid-name (classoid-cell-classoid cell)) nil)
;; Clear the cell.
(setf (classoid-cell-classoid cell) nil
(classoid-cell-pcl-class cell) nil))
(setf (info :type :kind name) nil
(info :type :documentation name) nil
(info :type :compiler-layout name) nil)))))
;;; Called when we are about to define NAME as a class meeting some
;;; predicate (such as a meta-class type test.) The first result is
;;; always of the desired class. The second result is any existing
;;; LAYOUT for this name.
;;;
;;; Again, this should be compiler-only, but easier to make this
;;; thread-safe.
(defun insured-find-classoid (name predicate constructor)
(declare (type function predicate constructor))
(let ((table *forward-referenced-layouts*))
(with-locked-system-table (table)
(let* ((old (find-classoid name nil))
(res (if (and old (funcall predicate old))
old
(funcall constructor :name name)))
(found (or (gethash name table)
(when old (classoid-layout old)))))
(when found
(setf (layout-classoid found) res))
(values res found)))))
;;; If the classoid has a proper name, return the name, otherwise return
;;; the classoid.
(defun classoid-proper-name (classoid)
#-sb-xc (declare (type classoid classoid))
(let ((name (classoid-name classoid)))
(if (and name (eq (find-classoid name nil) classoid))
name
classoid)))
;;;; CLASS type operations
(!define-type-class classoid)
;;; We might be passed classoids with invalid layouts; in any pairwise
;;; class comparison, we must ensure that both are valid before
;;; proceeding.
(defun %ensure-classoid-valid (classoid layout)
(aver (eq classoid (layout-classoid layout)))
(when (layout-invalid layout)
(if (typep classoid 'standard-classoid)
(let ((class (classoid-pcl-class classoid)))
(cond
((sb!pcl:class-finalized-p class)
(sb!pcl::%force-cache-flushes class))
((sb!pcl::class-has-a-forward-referenced-superclass-p class)
(error "Invalid, unfinalizeable class ~S (classoid ~S)."
class classoid))
(t
(sb!pcl:finalize-inheritance class))))
(error "Don't know how to ensure validity of ~S (not ~
a STANDARD-CLASSOID)." classoid))))
(defun %ensure-both-classoids-valid (class1 class2)
(do ((layout1 (classoid-layout class1) (classoid-layout class1))
(layout2 (classoid-layout class2) (classoid-layout class2))
(i 0 (+ i 1)))
((and (not (layout-invalid layout1)) (not (layout-invalid layout2))))
(aver (< i 2))
(%ensure-classoid-valid class1 layout1)
(%ensure-classoid-valid class2 layout2)))
(defun update-object-layout-or-invalid (object layout)
(if (typep (classoid-of object) 'standard-classoid)
(sb!pcl::check-wrapper-validity object)
(sb!c::%layout-invalid-error object layout)))
;;; Simple methods for TYPE= and SUBTYPEP should never be called when
;;; the two classes are equal, since there are EQ checks in those
;;; operations.
(!define-type-method (classoid :simple-=) (type1 type2)
(aver (not (eq type1 type2)))
(values nil t))
(!define-type-method (classoid :simple-subtypep) (class1 class2)
(aver (not (eq class1 class2)))
(with-world-lock ()
(%ensure-both-classoids-valid class1 class2)
(let ((subclasses (classoid-subclasses class2)))
(if (and subclasses (gethash class1 subclasses))
(values t t)
(values nil t)))))
;;; When finding the intersection of a sealed class and some other
;;; class (not hierarchically related) the intersection is the union
;;; of the currently shared subclasses.
(defun sealed-class-intersection2 (sealed other)
(declare (type classoid sealed other))
(let ((s-sub (classoid-subclasses sealed))
(o-sub (classoid-subclasses other)))
(if (and s-sub o-sub)
(collect ((res *empty-type* type-union))
(dohash ((subclass layout) s-sub :locked t)
(declare (ignore layout))
(when (gethash subclass o-sub)
(res (specifier-type subclass))))
(res))
*empty-type*)))
(!define-type-method (classoid :simple-intersection2) (class1 class2)
(declare (type classoid class1 class2))
(with-world-lock ()
(%ensure-both-classoids-valid class1 class2)
(cond ((eq class1 class2)
class1)
;; If one is a subclass of the other, then that is the
;; intersection.
((let ((subclasses (classoid-subclasses class2)))
(and subclasses (gethash class1 subclasses)))
class1)
((let ((subclasses (classoid-subclasses class1)))
(and subclasses (gethash class2 subclasses)))
class2)
;; Otherwise, we can't in general be sure that the
;; intersection is empty, since a subclass of both might be
;; defined. But we can eliminate it for some special cases.
((or (structure-classoid-p class1)
(structure-classoid-p class2))
;; No subclass of both can be defined.
*empty-type*)
((eq (classoid-state class1) :sealed)
;; checking whether a subclass of both can be defined:
(sealed-class-intersection2 class1 class2))
((eq (classoid-state class2) :sealed)
;; checking whether a subclass of both can be defined:
(sealed-class-intersection2 class2 class1))
(t
;; uncertain, since a subclass of both might be defined
nil))))
;;; KLUDGE: we need this to deal with the special-case INSTANCE and
;;; FUNCALLABLE-INSTANCE types (which used to be CLASSOIDs until CSR
;;; discovered that this was incompatible with the MOP class
;;; hierarchy). See NAMED :COMPLEX-SUBTYPEP-ARG2
(defvar *non-instance-classoid-types*
'(symbol system-area-pointer weak-pointer code-component
lra fdefn random-class))
;;; KLUDGE: we need this because of the need to represent
;;; intersections of two classes, even when empty at a given time, as
;;; uncanonicalized intersections because of the possibility of later
;;; defining a subclass of both classes. The necessity for changing
;;; the default return value from SUBTYPEP to NIL, T if no alternate
;;; method is present comes about because, unlike the other places we
;;; use INVOKE-COMPLEX-SUBTYPEP-ARG1-METHOD, in HAIRY methods and the
;;; like, classes are in their own hierarchy with no possibility of
;;; mixtures with other type classes.
(!define-type-method (classoid :complex-subtypep-arg2) (type1 class2)
(if (and (intersection-type-p type1)
(> (count-if #'classoid-p (intersection-type-types type1)) 1))
(values nil nil)
(invoke-complex-subtypep-arg1-method type1 class2 nil t)))
(!define-type-method (classoid :negate) (type)
(make-negation-type :type type))
(!define-type-method (classoid :unparse) (type)
(classoid-proper-name type))
;;;; PCL stuff
;;; the CLASSOID that we use to represent type information for
;;; STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS. The type system
;;; side does not need to distinguish between STANDARD-CLASS and
;;; FUNCALLABLE-STANDARD-CLASS.
(def!struct (standard-classoid (:include classoid)
(:constructor make-standard-classoid)))
;;; a metaclass for classes which aren't standardlike but will never
;;; change either.
(def!struct (static-classoid (:include classoid)
(:constructor make-static-classoid)))
;;;; built-in classes
;;; The BUILT-IN-CLASSES list is a data structure which configures the
;;; creation of all the built-in classes. It contains all the info
;;; that we need to maintain the mapping between classes, compile-time
;;; types and run-time type codes. These options are defined:
;;;
;;; :TRANSLATION (default none)
;;; When this class is "parsed" as a type specifier, it is