1 ;;;; This file contains structures and functions for the maintenance of
2 ;;;; basic information about defined types. Different object systems
3 ;;;; can be supported simultaneously.
5 ;;;; This software is part of the SBCL system. See the README file for
8 ;;;; This software is derived from the CMU CL system, which was
9 ;;;; written at Carnegie Mellon University and released into the
10 ;;;; public domain. The software is in the public domain and is
11 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
12 ;;;; files for more information.
14 (in-package "SB!KERNEL")
16 ;;;; DEFSTRUCT-DESCRIPTION
18 ;;; The DEFSTRUCT-DESCRIPTION structure holds compile-time information
19 ;;; about a structure type.
20 ;;; It is defined prior to LAYOUT because a LAYOUT-INFO slot
21 ;;; is declared to hold a DEFSTRUCT-DESCRIPTION.
22 (def!struct
(defstruct-description
25 #-sb-xc-host
(:pure t
)
26 (:constructor make-defstruct-description
(null-lexenv-p name
)))
27 ;; name of the structure
28 (name (missing-arg) :type symbol
:read-only t
)
29 ;; documentation on the structure
30 (doc nil
:type
(or string null
))
31 ;; prefix for slot names. If NIL, none.
32 (conc-name nil
:type
(or string null
))
33 ;; All the :CONSTRUCTOR specs and posssibly an implied constructor,
34 ;; keyword constructors first, then BOA constructors. NIL if none.
35 (constructors () :type list
)
36 ;; True if the DEFSTRUCT appeared in a null lexical environment.
37 (null-lexenv-p nil
:type boolean
:read-only t
) ; the safe default is NIL
38 ;; name of copying function
39 (copier-name nil
:type symbol
)
40 ;; name of type predicate
41 (predicate-name nil
:type symbol
)
42 ;; the arguments to the :INCLUDE option, or NIL if no included
44 (include nil
:type list
)
45 ;; properties used to define structure-like classes with an
46 ;; arbitrary superclass and that may not have STRUCTURE-CLASS as the
47 ;; metaclass. Syntax is:
48 ;; (superclass-name metaclass-name metaclass-constructor)
49 (alternate-metaclass nil
:type list
)
50 ;; a list of DEFSTRUCT-SLOT-DESCRIPTION objects for all slots
51 ;; (including included ones)
53 ;; a list of (NAME . INDEX) pairs for accessors of included structures
54 (inherited-accessor-alist () :type list
)
55 ;; number of elements including the layout itself (minimum=1)
56 (length 0 :type index
)
57 ;; General kind of implementation.
58 (type 'structure
:type
(member structure vector list
59 funcallable-structure
))
61 ;; The next three slots are for :TYPE'd structures (which aren't
62 ;; classes, DD-CLASS-P = NIL)
64 ;; vector element type
66 ;; T if :NAMED was explicitly specified, NIL otherwise
67 (named nil
:type boolean
)
68 ;; any INITIAL-OFFSET option on this direct type
69 (offset nil
:type
(or index null
))
71 ;; which :PRINT-mumble option was given, if either was.
72 (print-option nil
:type
(member nil
:print-function
:print-object
))
73 ;; the argument to the PRINT-FUNCTION or PRINT-OBJECT option.
74 ;; NIL if the option was given with no argument.
75 (printer-fname nil
:type
(or cons symbol
))
77 ;; the value of the :PURE option, used by cheneygc when purifying.
78 ;; This is true if objects of this class are never modified to
79 ;; contain dynamic pointers in their slots or constant-like
80 ;; substructure (and hence can be copied into read-only space by
82 ;; This is only meaningful if DD-CLASS-P = T.
83 (pure nil
:type
(member t nil
)))
84 #!-sb-fluid
(declaim (freeze-type defstruct-description
))
85 (!set-load-form-method defstruct-description
(:host
:xc
:target
))
87 ;;;; basic LAYOUT stuff
89 ;;; Note: This bound is set somewhat less than MOST-POSITIVE-FIXNUM
90 ;;; in order to guarantee that several hash values can be added without
91 ;;; overflowing into a bignum.
92 (defconstant layout-clos-hash-limit
(1+ (ash sb
!xc
:most-positive-fixnum -
3))
93 "the exclusive upper bound on LAYOUT-CLOS-HASH values")
94 ;; This must be DEF!TYPE and not just DEFTYPE because access to slots
95 ;; of a layout occur "before" the structure definition is made in the
96 ;; run-the-xc pass, and the source-transform of a slot accessor
97 ;; wraps (TRULY-THE <type> ...) around %INSTANCE-REF,
98 ;; so <type> had best be defined at that point.
99 (def!type layout-clos-hash
() `(integer 0 ,layout-clos-hash-limit
))
100 (declaim (ftype (sfunction () layout-clos-hash
) random-layout-clos-hash
))
102 ;;; The LAYOUT structure is pointed to by the first cell of instance
103 ;;; (or structure) objects. It represents what we need to know for
104 ;;; type checking and garbage collection. Whenever a class is
105 ;;; incompatibly redefined, a new layout is allocated. If two object's
106 ;;; layouts are EQ, then they are exactly the same type.
108 ;;; *** IMPORTANT ***
110 ;;; If you change the slots of LAYOUT, you need to alter genesis as
111 ;;; well, since the initialization of layout slots is hardcoded there.
113 ;;; FIXME: ...it would be better to automate this, of course...
114 (def!struct
(layout #-sb-xc-host
(:constructor
#!+immobile-space nil
)
116 ;; a pseudo-random hash value for use by CLOS.
117 (clos-hash (random-layout-clos-hash) :type layout-clos-hash
)
118 ;; the class that this is a layout for
119 (classoid (missing-arg) :type classoid
)
120 ;; The value of this slot can be:
121 ;; * :UNINITIALIZED if not initialized yet;
122 ;; * NIL if this is the up-to-date layout for a class; or
123 ;; * T if this layout has been invalidated (by being replaced by
124 ;; a new, more-up-to-date LAYOUT).
125 ;; * something else (probably a list) if the class is a PCL wrapper
126 ;; and PCL has made it invalid and made a note to itself about it
127 (invalid :uninitialized
:type
(or cons
(member nil t
:uninitialized
)))
128 ;; the layouts for all classes we inherit. If hierarchical, i.e. if
129 ;; DEPTHOID >= 0, then these are ordered by ORDER-LAYOUT-INHERITS
130 ;; (least to most specific), so that each inherited layout appears
131 ;; at its expected depth, i.e. at its LAYOUT-DEPTHOID value.
133 ;; Remaining elements are filled by the non-hierarchical layouts or,
134 ;; if they would otherwise be empty, by copies of succeeding layouts.
135 (inherits #() :type simple-vector
)
136 ;; If inheritance is not hierarchical, this is -1. If inheritance is
137 ;; hierarchical, this is the inheritance depth, i.e. (LENGTH INHERITS).
139 ;; (1) This turns out to be a handy encoding for arithmetically
140 ;; comparing deepness; it is generally useful to do a bare numeric
141 ;; comparison of these depthoid values, and we hardly ever need to
142 ;; test whether the values are negative or not.
143 ;; (2) This was called INHERITANCE-DEPTH in classic CMU CL. It was
144 ;; renamed because some of us find it confusing to call something
145 ;; a depth when it isn't quite.
146 (depthoid -
1 :type layout-depthoid
)
147 ;; the number of top level descriptor cells in each instance
148 ;; For [FUNCALLABLE-]STANDARD-OBJECT instances, this is the slot vector
149 ;; length, not the primitive object length.
150 (length 0 :type index
)
151 ;; If this layout has some kind of compiler meta-info, then this is
152 ;; it. If a structure, then we store the DEFSTRUCT-DESCRIPTION here.
153 (info nil
:type
(or null defstruct-description
))
154 ;; Map of raw slot indices.
155 (bitmap +layout-all-tagged
+ :type layout-bitmap
)
156 ;; Per-slot comparator for implementing EQUALP.
157 (equalp-tests #() :type simple-vector
)
158 ;; Definition location
159 (source-location nil
)
160 ;; If this layout is for an object of metatype STANDARD-CLASS,
161 ;; these are the EFFECTIVE-SLOT-DEFINITION metaobjects.
162 (slot-list nil
:type list
)
163 ;; Information about slots in the class to PCL: this provides fast
164 ;; access to slot-definitions and locations by name, etc.
165 ;; See MAKE-SLOT-TABLE in pcl/slots-boot.lisp for further details.
166 (slot-table #(1 nil
) :type simple-vector
)
167 ;; True IFF the layout belongs to a standand-instance or a
168 ;; standard-funcallable-instance.
170 ;; FIXME: If we unify wrappers and layouts this can go away, since
171 ;; it is only used in SB-PCL::EMIT-FETCH-WRAPPERS, which can then
172 ;; use INSTANCE-SLOTS-LAYOUT instead (if there is are no slot
173 ;; layouts, there are no slots for it to pull.)
174 ;; But while that's conceivable, it still seems advantageous to have
175 ;; a single bit that decides whether something is STANDARD-OBJECT.
176 (%for-std-class-b
0 :type bit
:read-only t
))
177 (declaim (freeze-type layout
))
179 #!+(and immobile-space
(host-feature sb-xc
))
180 (macrolet ((def-layout-maker ()
181 (let ((slots (dd-slots (find-defstruct-description 'layout
))))
183 (&key
,@(mapcar (lambda (s) `(,(dsd-name s
) ,(dsd-default s
)))
185 (declare ,@(mapcar (lambda (s) `(type ,(dsd-type s
) ,(dsd-name s
)))
187 ;; After calling into C, registers are trashed,
188 ;; so we pass everything as a single vector,
189 ;; and don't rely on Lisp to write the slots of the layout.
190 (dx-let ((data (vector ,@(mapcar #'dsd-name slots
))))
192 (values (%primitive sb
!vm
::alloc-immobile-layout data
))))))))
195 ;;; The CLASSOID structure is a supertype of all classoid types. A
196 ;;; CLASSOID is also a CTYPE structure as recognized by the type
197 ;;; system. (FIXME: It's also a type specifier, though this might go
198 ;;; away as with the merger of SB-PCL:CLASS and CL:CLASS it's no
199 ;;; longer necessary)
200 (def!struct
(classoid
202 (class-info (type-class-or-lose 'classoid
)))
205 #-no-ansi-print-object
207 (lambda (class stream
)
208 (let ((name (classoid-name class
)))
209 (print-unreadable-object (class stream
211 :identity
(not name
))
213 ;; FIXME: Make sure that this prints
214 ;; reasonably for anonymous classes.
215 "~:[anonymous~;~:*~S~]~@[ (~(~A~))~]"
217 (classoid-state class
))))))
218 #-sb-xc-host
(:pure nil
))
219 ;; the value to be returned by CLASSOID-NAME.
220 (name nil
:type symbol
)
221 ;; the current layout for this class, or NIL if none assigned yet
222 (layout nil
:type
(or layout null
))
223 ;; How sure are we that this class won't be redefined?
224 ;; :READ-ONLY = We are committed to not changing the effective
225 ;; slots or superclasses.
226 ;; :SEALED = We can't even add subclasses.
227 ;; NIL = Anything could happen.
228 (state nil
:type
(member nil
:read-only
:sealed
))
229 ;; direct superclasses of this class. Always NIL for CLOS classes.
230 (direct-superclasses () :type list
)
231 ;; representation of all of the subclasses (direct or indirect) of
232 ;; this class. This is NIL if no subclasses or not initalized yet;
233 ;; otherwise, it's an EQ hash-table mapping CLASSOID objects to the
234 ;; subclass layout that was in effect at the time the subclass was
236 (subclasses nil
:type
(or null hash-table
))
237 ;; the PCL class (= CL:CLASS, but with a view to future flexibility
238 ;; we don't just call it the CLASS slot) object for this class, or
239 ;; NIL if none assigned yet
242 ;;;; object types to represent classes
244 ;;; An UNDEFINED-CLASSOID is a cookie we make up to stick in forward
245 ;;; referenced layouts. Users should never see them.
246 (def!struct
(undefined-classoid
249 (:constructor make-undefined-classoid
(name))))
251 ;;; BUILT-IN-CLASS is used to represent the standard classes that
252 ;;; aren't defined with DEFSTRUCT and other specially implemented
253 ;;; primitive types whose only attribute is their name.
255 ;;; Some BUILT-IN-CLASSes have a TRANSLATION, which means that they
256 ;;; are effectively DEFTYPE'd to some other type (usually a union of
257 ;;; other classes or a "primitive" type such as NUMBER, ARRAY, etc.)
258 ;;; This translation is done when type specifiers are parsed. Type
259 ;;; system operations (union, subtypep, etc.) should never encounter
260 ;;; translated classes, only their translation.
261 (def!struct
(built-in-classoid (:include classoid
)
263 (:constructor make-built-in-classoid
))
264 ;; the type we translate to on parsing. If NIL, then this class
265 ;; stands on its own; or it can be set to :INITIALIZING for a period
267 (translation nil
:type
(or ctype
(member nil
:initializing
))))
269 (def!struct
(condition-classoid (:include classoid
)
271 (:constructor make-condition-classoid
))
272 ;; list of CONDITION-SLOT structures for the direct slots of this
274 (slots nil
:type list
)
275 ;; list of CONDITION-SLOT structures for all of the effective class
276 ;; slots of this class
277 (class-slots nil
:type list
)
278 ;; report function or NIL
279 (report nil
:type
(or function null
))
280 ;; list of specifications of the form
282 ;; (INITARG INITFORM THUNK)
284 ;; where THUNK, when called without arguments, returns the value for
286 (direct-default-initargs () :type list
)
287 ;; class precedence list as a list of CLASS objects, with all
288 ;; non-CONDITION classes removed
290 ;; a list of all the effective instance allocation slots of this
291 ;; class that have a non-constant initform or default-initarg.
292 ;; Values for these slots must be computed in the dynamic
293 ;; environment of MAKE-CONDITION.
294 (hairy-slots nil
:type list
))
296 ;;;; classoid namespace
298 ;;; We use an indirection to allow forward referencing of class
299 ;;; definitions with load-time resolution.
300 (def!struct
(classoid-cell
302 (:constructor make-classoid-cell
(name &optional classoid
))
303 #-no-ansi-print-object
304 (:print-object
(lambda (s stream
)
305 (print-unreadable-object (s stream
:type t
)
306 (prin1 (classoid-cell-name s
) stream
)))))
307 ;; Name of class we expect to find.
308 (name nil
:type symbol
:read-only t
)
309 ;; Classoid or NIL if not yet defined.
310 (classoid nil
:type
(or classoid null
))
313 (declaim (freeze-type classoid-cell
))
314 (!set-load-form-method classoid-cell
(:xc
:target
)
316 (declare (ignore env
))
317 `(find-classoid-cell ',(classoid-cell-name self
) :create t
)))
319 (defun find-classoid-cell (name &key create
)
320 (let ((real-name (uncross name
)))
321 (cond ((info :type
:classoid-cell real-name
))
323 (get-info-value-initializing :type
:classoid-cell real-name
324 (make-classoid-cell real-name
))))))
326 ;;; Return the classoid with the specified NAME. If ERRORP is false,
327 ;;; then NIL is returned when no such class exists.
328 (defun find-classoid (name &optional
(errorp t
))
329 (declare (type symbol name
))
330 (let ((cell (find-classoid-cell name
)))
331 (cond ((and cell
(classoid-cell-classoid cell
)))
333 (error 'simple-type-error
335 :expected-type
'class
336 :format-control
"Class not yet defined: ~S"
337 :format-arguments
(list name
))))))
341 ;;; the CLASSOID that we use to represent type information for
342 ;;; STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS. The type system
343 ;;; side does not need to distinguish between STANDARD-CLASS and
344 ;;; FUNCALLABLE-STANDARD-CLASS.
345 (def!struct
(standard-classoid (:include classoid
)
347 (:constructor make-standard-classoid
)))
348 ;;; a metaclass for classes which aren't standardlike but will never
350 (def!struct
(static-classoid (:include classoid
)
352 (:constructor make-static-classoid
)))
354 (declaim (freeze-type built-in-classoid condition-classoid
355 standard-classoid static-classoid
))
359 ;;; layout for this type being used by the compiler
360 (define-info-type (:type
:compiler-layout
)
361 :type-spec
(or layout null
)
362 :default
(lambda (name)
363 (let ((class (find-classoid name nil
)))
364 (when class
(classoid-layout class
)))))
366 (eval-when (#-sb-xc
:compile-toplevel
:load-toplevel
:execute
)
367 (defun ftype-from-fdefn (name)
368 (declare (ignorable name
))
369 ;; Again [as in (DEFINE-INFO-TYPE (:FUNCTION :TYPE) ...)] it's
370 ;; not clear how to generalize the FBOUNDP expression to the
371 ;; cross-compiler. -- WHN 19990330
373 (specifier-type 'function
)
375 (let* ((fdefn (sb!kernel
::find-fdefn name
))
376 (fun (and fdefn
(fdefn-fun fdefn
))))
378 (handler-bind ((style-warning #'muffle-warning
))
379 (specifier-type (sb!impl
::%fun-type fun
)))
380 (specifier-type 'function
)))))
382 ;;; The type specifier for this function, or a DEFSTRUCT-DESCRIPTION
383 ;;; or the symbol :GENERIC-FUNTION.
384 ;;; If a DD, it must contain a constructor whose name is
385 ;;; the one being sought in globaldb, which is used to derive the type.
386 ;;; If :GENERIC-FUNCTION, the info is recomputed from existing methods
387 ;;; and stored back into globaldb.
388 (define-info-type (:function
:type
)
389 :type-spec
(or ctype defstruct-description
(member :generic-function
))
390 :default
#'ftype-from-fdefn
)
392 ;;; A random place for this :-(
393 #+sb-xc-host
(setq *info-environment
* (make-info-hashtable))