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
24 #-sb-xc-host
(:pure t
)
25 (:constructor make-defstruct-description
(null-lexenv-p name
)))
26 ;; name of the structure
27 (name (missing-arg) :type symbol
:read-only t
)
28 ;; documentation on the structure
29 (doc nil
:type
(or string null
))
30 ;; prefix for slot names. If NIL, none.
31 (conc-name nil
:type
(or string null
))
32 ;; All the :CONSTRUCTOR specs and posssibly an implied constructor,
33 ;; keyword constructors first, then BOA constructors. NIL if none.
34 (constructors () :type list
)
35 ;; True if the DEFSTRUCT appeared in a null lexical environment.
36 (null-lexenv-p nil
:type boolean
:read-only t
) ; the safe default is NIL
37 ;; name of copying function
38 (copier-name nil
:type symbol
)
39 ;; name of type predicate
40 (predicate-name nil
:type symbol
)
41 ;; the arguments to the :INCLUDE option, or NIL if no included
43 (include nil
:type list
)
44 ;; properties used to define structure-like classes with an
45 ;; arbitrary superclass and that may not have STRUCTURE-CLASS as the
46 ;; metaclass. Syntax is:
47 ;; (superclass-name metaclass-name metaclass-constructor)
48 (alternate-metaclass nil
:type list
)
49 ;; a list of DEFSTRUCT-SLOT-DESCRIPTION objects for all slots
50 ;; (including included ones)
52 ;; a list of (NAME . INDEX) pairs for accessors of included structures
53 (inherited-accessor-alist () :type list
)
54 ;; number of elements including the layout itself (minimum=1)
55 (length 0 :type index
)
56 ;; General kind of implementation.
57 (type 'structure
:type
(member structure vector list
58 funcallable-structure
))
60 ;; The next three slots are for :TYPE'd structures (which aren't
61 ;; classes, DD-CLASS-P = NIL)
63 ;; vector element type
65 ;; T if :NAMED was explicitly specified, NIL otherwise
66 (named nil
:type boolean
)
67 ;; any INITIAL-OFFSET option on this direct type
68 (offset nil
:type
(or index null
))
70 ;; which :PRINT-mumble option was given, if either was.
71 (print-option nil
:type
(member nil
:print-function
:print-object
))
72 ;; the argument to the PRINT-FUNCTION or PRINT-OBJECT option.
73 ;; NIL if the option was given with no argument.
74 (printer-fname nil
:type
(or cons symbol
))
76 ;; the value of the :PURE option, or :UNSPECIFIED. This is only
77 ;; meaningful if DD-CLASS-P = T.
78 (pure :unspecified
:type
(member t nil
:unspecified
)))
79 #!-sb-fluid
(declaim (freeze-type defstruct-description
))
80 (!set-load-form-method defstruct-description
(:host
:xc
:target
))
82 ;;;; basic LAYOUT stuff
84 ;;; Note: This bound is set somewhat less than MOST-POSITIVE-FIXNUM
85 ;;; in order to guarantee that several hash values can be added without
86 ;;; overflowing into a bignum.
87 (defconstant layout-clos-hash-limit
(1+ (ash sb
!xc
:most-positive-fixnum -
3))
88 "the exclusive upper bound on LAYOUT-CLOS-HASH values")
89 ;; This must be DEF!TYPE and not just DEFTYPE because access to slots
90 ;; of a layout occur "before" the structure definition is made in the
91 ;; run-the-xc pass, and the source-transform of a slot accessor
92 ;; wraps (TRULY-THE <type> ...) around %INSTANCE-REF,
93 ;; so <type> had best be defined at that point.
94 (def!type layout-clos-hash
() `(integer 0 ,layout-clos-hash-limit
))
95 (declaim (ftype (sfunction () layout-clos-hash
) random-layout-clos-hash
))
97 ;;; The LAYOUT structure is pointed to by the first cell of instance
98 ;;; (or structure) objects. It represents what we need to know for
99 ;;; type checking and garbage collection. Whenever a class is
100 ;;; incompatibly redefined, a new layout is allocated. If two object's
101 ;;; layouts are EQ, then they are exactly the same type.
103 ;;; *** IMPORTANT ***
105 ;;; If you change the slots of LAYOUT, you need to alter genesis as
106 ;;; well, since the initialization of layout slots is hardcoded there.
108 ;;; FIXME: ...it would be better to automate this, of course...
109 (def!struct
(layout #-sb-xc-host
(:constructor
#!+immobile-space nil
))
110 ;; a pseudo-random hash value for use by CLOS.
111 (clos-hash (random-layout-clos-hash) :type layout-clos-hash
)
112 ;; the class that this is a layout for
113 (classoid (missing-arg) :type classoid
)
114 ;; The value of this slot can be:
115 ;; * :UNINITIALIZED if not initialized yet;
116 ;; * NIL if this is the up-to-date layout for a class; or
117 ;; * T if this layout has been invalidated (by being replaced by
118 ;; a new, more-up-to-date LAYOUT).
119 ;; * something else (probably a list) if the class is a PCL wrapper
120 ;; and PCL has made it invalid and made a note to itself about it
121 (invalid :uninitialized
:type
(or cons
(member nil t
:uninitialized
)))
122 ;; the layouts for all classes we inherit. If hierarchical, i.e. if
123 ;; DEPTHOID >= 0, then these are ordered by ORDER-LAYOUT-INHERITS
124 ;; (least to most specific), so that each inherited layout appears
125 ;; at its expected depth, i.e. at its LAYOUT-DEPTHOID value.
127 ;; Remaining elements are filled by the non-hierarchical layouts or,
128 ;; if they would otherwise be empty, by copies of succeeding layouts.
129 (inherits #() :type simple-vector
)
130 ;; If inheritance is not hierarchical, this is -1. If inheritance is
131 ;; hierarchical, this is the inheritance depth, i.e. (LENGTH INHERITS).
133 ;; (1) This turns out to be a handy encoding for arithmetically
134 ;; comparing deepness; it is generally useful to do a bare numeric
135 ;; comparison of these depthoid values, and we hardly ever need to
136 ;; test whether the values are negative or not.
137 ;; (2) This was called INHERITANCE-DEPTH in classic CMU CL. It was
138 ;; renamed because some of us find it confusing to call something
139 ;; a depth when it isn't quite.
140 (depthoid -
1 :type layout-depthoid
)
141 ;; the number of top level descriptor cells in each instance
142 ;; For [FUNCALLABLE-]STANDARD-OBJECT instances, this is the slot vector
143 ;; length, not the primitive object length.
144 (length 0 :type index
)
145 ;; If this layout has some kind of compiler meta-info, then this is
146 ;; it. If a structure, then we store the DEFSTRUCT-DESCRIPTION here.
147 (info nil
:type
(or null defstruct-description
))
148 ;; This is true if objects of this class are never modified to
149 ;; contain dynamic pointers in their slots or constant-like
150 ;; substructure (and hence can be copied into read-only space by
153 ;; This slot is known to the C runtime support code.
154 (pure nil
:type
(member t nil
0))
155 ;; Map of raw slot indices.
156 (bitmap +layout-all-tagged
+ :type layout-bitmap
)
157 ;; Per-slot comparator for implementing EQUALP.
158 (equalp-tests #() :type simple-vector
)
159 ;; Definition location
160 (source-location nil
)
161 ;; If this layout is for an object of metatype STANDARD-CLASS,
162 ;; these are the EFFECTIVE-SLOT-DEFINITION metaobjects.
163 (slot-list nil
:type list
)
164 ;; Information about slots in the class to PCL: this provides fast
165 ;; access to slot-definitions and locations by name, etc.
166 ;; See MAKE-SLOT-TABLE in pcl/slots-boot.lisp for further details.
167 (slot-table #(1 nil
) :type simple-vector
)
168 ;; True IFF the layout belongs to a standand-instance or a
169 ;; standard-funcallable-instance.
171 ;; FIXME: If we unify wrappers and layouts this can go away, since
172 ;; it is only used in SB-PCL::EMIT-FETCH-WRAPPERS, which can then
173 ;; use INSTANCE-SLOTS-LAYOUT instead (if there is are no slot
174 ;; layouts, there are no slots for it to pull.)
175 ;; But while that's conceivable, it still seems advantageous to have
176 ;; a single bit that decides whether something is STANDARD-OBJECT.
177 (%for-std-class-b
0 :type bit
:read-only t
))
178 (declaim (freeze-type layout
))
180 #!+(and immobile-space
(host-feature sb-xc
))
181 (macrolet ((def-layout-maker ()
182 (let ((slots (dd-slots (find-defstruct-description 'layout
))))
184 (&key
,@(mapcar (lambda (s) `(,(dsd-name s
) ,(dsd-default s
)))
186 (declare ,@(mapcar (lambda (s) `(type ,(dsd-type s
) ,(dsd-name s
)))
188 ;; After calling into C, registers are trashed,
189 ;; so we pass everything as a single vector,
190 ;; and don't rely on Lisp to write the slots of the layout.
191 (dx-let ((data (vector ,@(mapcar #'dsd-name slots
))))
193 (values (%primitive sb
!vm
::alloc-immobile-layout data
))))))))
196 ;;; The CLASSOID structure is a supertype of all classoid types. A
197 ;;; CLASSOID is also a CTYPE structure as recognized by the type
198 ;;; system. (FIXME: It's also a type specifier, though this might go
199 ;;; away as with the merger of SB-PCL:CLASS and CL:CLASS it's no
200 ;;; longer necessary)
201 (def!struct
(classoid
203 (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
248 (:constructor make-undefined-classoid
(name))))
250 ;;; BUILT-IN-CLASS is used to represent the standard classes that
251 ;;; aren't defined with DEFSTRUCT and other specially implemented
252 ;;; primitive types whose only attribute is their name.
254 ;;; Some BUILT-IN-CLASSes have a TRANSLATION, which means that they
255 ;;; are effectively DEFTYPE'd to some other type (usually a union of
256 ;;; other classes or a "primitive" type such as NUMBER, ARRAY, etc.)
257 ;;; This translation is done when type specifiers are parsed. Type
258 ;;; system operations (union, subtypep, etc.) should never encounter
259 ;;; translated classes, only their translation.
260 (def!struct
(built-in-classoid (:include classoid
)
261 (:constructor make-built-in-classoid
))
262 ;; the type we translate to on parsing. If NIL, then this class
263 ;; stands on its own; or it can be set to :INITIALIZING for a period
265 (translation nil
:type
(or ctype
(member nil
:initializing
))))
267 (def!struct
(condition-classoid (:include classoid
)
268 (:constructor make-condition-classoid
))
269 ;; list of CONDITION-SLOT structures for the direct slots of this
271 (slots nil
:type list
)
272 ;; list of CONDITION-SLOT structures for all of the effective class
273 ;; slots of this class
274 (class-slots nil
:type list
)
275 ;; report function or NIL
276 (report nil
:type
(or function null
))
277 ;; list of specifications of the form
279 ;; (INITARG INITFORM THUNK)
281 ;; where THUNK, when called without arguments, returns the value for
283 (direct-default-initargs () :type list
)
284 ;; class precedence list as a list of CLASS objects, with all
285 ;; non-CONDITION classes removed
287 ;; a list of all the effective instance allocation slots of this
288 ;; class that have a non-constant initform or default-initarg.
289 ;; Values for these slots must be computed in the dynamic
290 ;; environment of MAKE-CONDITION.
291 (hairy-slots nil
:type list
))
293 ;;;; classoid namespace
295 ;;; We use an indirection to allow forward referencing of class
296 ;;; definitions with load-time resolution.
297 (def!struct
(classoid-cell
298 (:constructor make-classoid-cell
(name &optional classoid
))
299 #-no-ansi-print-object
300 (:print-object
(lambda (s stream
)
301 (print-unreadable-object (s stream
:type t
)
302 (prin1 (classoid-cell-name s
) stream
)))))
303 ;; Name of class we expect to find.
304 (name nil
:type symbol
:read-only t
)
305 ;; Classoid or NIL if not yet defined.
306 (classoid nil
:type
(or classoid null
))
309 (declaim (freeze-type classoid-cell
))
310 (!set-load-form-method classoid-cell
(:xc
:target
)
312 (declare (ignore env
))
313 `(find-classoid-cell ',(classoid-cell-name self
) :create t
)))
315 (defun find-classoid-cell (name &key create
)
316 (let ((real-name (uncross name
)))
317 (cond ((info :type
:classoid-cell real-name
))
319 (get-info-value-initializing :type
:classoid-cell real-name
320 (make-classoid-cell real-name
))))))
322 ;;; Return the classoid with the specified NAME. If ERRORP is false,
323 ;;; then NIL is returned when no such class exists.
324 (defun find-classoid (name &optional
(errorp t
))
325 (declare (type symbol name
))
326 (let ((cell (find-classoid-cell name
)))
327 (cond ((and cell
(classoid-cell-classoid cell
)))
329 (error 'simple-type-error
331 :expected-type
'class
332 :format-control
"Class not yet defined: ~S"
333 :format-arguments
(list name
))))))
337 ;;; the CLASSOID that we use to represent type information for
338 ;;; STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS. The type system
339 ;;; side does not need to distinguish between STANDARD-CLASS and
340 ;;; FUNCALLABLE-STANDARD-CLASS.
341 (def!struct
(standard-classoid (:include classoid
)
342 (:constructor make-standard-classoid
)))
343 ;;; a metaclass for classes which aren't standardlike but will never
345 (def!struct
(static-classoid (:include classoid
)
346 (:constructor make-static-classoid
)))
348 (declaim (freeze-type built-in-classoid condition-classoid
349 standard-classoid static-classoid
))
353 ;;; layout for this type being used by the compiler
354 (define-info-type (:type
:compiler-layout
)
355 :type-spec
(or layout null
)
356 :default
(lambda (name)
357 (let ((class (find-classoid name nil
)))
358 (when class
(classoid-layout class
)))))
360 (eval-when (#-sb-xc
:compile-toplevel
:load-toplevel
:execute
)
361 (defun ftype-from-fdefn (name)
362 (declare (ignorable name
))
363 ;; Again [as in (DEFINE-INFO-TYPE (:FUNCTION :TYPE) ...)] it's
364 ;; not clear how to generalize the FBOUNDP expression to the
365 ;; cross-compiler. -- WHN 19990330
367 (specifier-type 'function
)
369 (let* ((fdefn (sb!kernel
::find-fdefn name
))
370 (fun (and fdefn
(fdefn-fun fdefn
))))
372 (handler-bind ((style-warning #'muffle-warning
))
373 (specifier-type (sb!impl
::%fun-type fun
)))
374 (specifier-type 'function
)))))
376 ;;; The type specifier for this function, or a DEFSTRUCT-DESCRIPTION
377 ;;; or the symbol :GENERIC-FUNTION.
378 ;;; If a DD, it must contain a constructor whose name is
379 ;;; the one being sought in globaldb, which is used to derive the type.
380 ;;; If :GENERIC-FUNCTION, the info is recomputed from existing methods
381 ;;; and stored back into globaldb.
382 (define-info-type (:function
:type
)
383 :type-spec
(or ctype defstruct-description
(member :generic-function
))
384 :default
#'ftype-from-fdefn
)
386 ;;; A random place for this :-(
387 #+sb-xc-host
(setq *info-environment
* (make-info-hashtable))