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 (defconstant +structure-layout-flag
+ #b001
)
103 (defconstant +pcl-object-layout-flag
+ #b010
)
104 (defconstant +condition-layout-flag
+ #b100
)
106 ;;; The LAYOUT structure is pointed to by the first cell of instance
107 ;;; (or structure) objects. It represents what we need to know for
108 ;;; type checking and garbage collection. Whenever a class is
109 ;;; incompatibly redefined, a new layout is allocated. If two object's
110 ;;; layouts are EQ, then they are exactly the same type.
112 ;;; *** IMPORTANT ***
114 ;;; If you change the slots of LAYOUT, you need to alter genesis as
115 ;;; well, since the initialization of layout slots is hardcoded there.
117 ;;; FIXME: ...it would be better to automate this, of course...
118 (def!struct
(layout #-sb-xc-host
(:constructor
#!+immobile-space nil
)
120 ;; one +something-LAYOUT-FLAG+ bit or none of them
121 (%flags
0 :type fixnum
:read-only nil
)
122 ;; a pseudo-random hash value for use by CLOS.
123 (clos-hash (random-layout-clos-hash) :type layout-clos-hash
)
124 ;; the class that this is a layout for
125 (classoid (missing-arg) :type classoid
)
126 ;; The value of this slot can be:
127 ;; * :UNINITIALIZED if not initialized yet;
128 ;; * NIL if this is the up-to-date layout for a class; or
129 ;; * T if this layout has been invalidated (by being replaced by
130 ;; a new, more-up-to-date LAYOUT).
131 ;; * something else (probably a list) if the class is a PCL wrapper
132 ;; and PCL has made it invalid and made a note to itself about it
133 (invalid :uninitialized
:type
(or cons
(member nil t
:uninitialized
)))
134 ;; the layouts for all classes we inherit. If hierarchical, i.e. if
135 ;; DEPTHOID >= 0, then these are ordered by ORDER-LAYOUT-INHERITS
136 ;; (least to most specific), so that each inherited layout appears
137 ;; at its expected depth, i.e. at its LAYOUT-DEPTHOID value.
139 ;; Remaining elements are filled by the non-hierarchical layouts or,
140 ;; if they would otherwise be empty, by copies of succeeding layouts.
141 (inherits #() :type simple-vector
)
142 ;; If inheritance is not hierarchical, this is -1. If inheritance is
143 ;; hierarchical, this is the inheritance depth, i.e. (LENGTH INHERITS).
145 ;; (1) This turns out to be a handy encoding for arithmetically
146 ;; comparing deepness; it is generally useful to do a bare numeric
147 ;; comparison of these depthoid values, and we hardly ever need to
148 ;; test whether the values are negative or not.
149 ;; (2) This was called INHERITANCE-DEPTH in classic CMU CL. It was
150 ;; renamed because some of us find it confusing to call something
151 ;; a depth when it isn't quite.
152 (depthoid -
1 :type layout-depthoid
)
153 ;; the number of top level descriptor cells in each instance
154 ;; For [FUNCALLABLE-]STANDARD-OBJECT instances, this is the slot vector
155 ;; length, not the primitive object length.
156 (length 0 :type index
)
157 ;; If this layout has some kind of compiler meta-info, then this is
158 ;; it. If a structure, then we store the DEFSTRUCT-DESCRIPTION here.
159 (info nil
:type
(or null defstruct-description
))
160 ;; Map of raw slot indices.
161 (bitmap +layout-all-tagged
+ :type layout-bitmap
)
162 ;; Per-slot comparator for implementing EQUALP.
163 (equalp-tests #() :type simple-vector
)
164 ;; Definition location
165 (source-location nil
)
166 ;; If this layout is for an object of metatype STANDARD-CLASS,
167 ;; these are the EFFECTIVE-SLOT-DEFINITION metaobjects.
168 (slot-list nil
:type list
)
169 ;; Information about slots in the class to PCL: this provides fast
170 ;; access to slot-definitions and locations by name, etc.
171 ;; See MAKE-SLOT-TABLE in pcl/slots-boot.lisp for further details.
172 (slot-table #(1 nil
) :type simple-vector
))
173 (declaim (freeze-type layout
))
175 #!+(and immobile-space
(host-feature sb-xc
))
176 (macrolet ((def-layout-maker ()
177 (let ((slots (dd-slots (find-defstruct-description 'layout
))))
179 (&key
,@(mapcar (lambda (s) `(,(dsd-name s
) ,(dsd-default s
)))
181 (declare ,@(mapcar (lambda (s) `(type ,(dsd-type s
) ,(dsd-name s
)))
183 ;; After calling into C, registers are trashed,
184 ;; so we pass everything as a single vector,
185 ;; and don't rely on Lisp to write the slots of the layout.
186 (dx-let ((data (vector ,@(mapcar #'dsd-name slots
))))
188 (values (%primitive sb
!vm
::alloc-immobile-layout data
))))))))
191 ;;; The CLASSOID structure is a supertype of all classoid types. A
192 ;;; CLASSOID is also a CTYPE structure as recognized by the type
193 ;;; system. (FIXME: It's also a type specifier, though this might go
194 ;;; away as with the merger of SB-PCL:CLASS and CL:CLASS it's no
195 ;;; longer necessary)
196 (def!struct
(classoid
198 (class-info (type-class-or-lose 'classoid
)))
201 #-no-ansi-print-object
203 (lambda (class stream
)
204 (let ((name (classoid-name class
)))
205 (print-unreadable-object (class stream
207 :identity
(not name
))
209 ;; FIXME: Make sure that this prints
210 ;; reasonably for anonymous classes.
211 "~:[anonymous~;~:*~S~]~@[ (~(~A~))~]"
213 (classoid-state class
))))))
214 #-sb-xc-host
(:pure nil
))
215 ;; the value to be returned by CLASSOID-NAME.
216 (name nil
:type symbol
)
217 ;; the current layout for this class, or NIL if none assigned yet
218 (layout nil
:type
(or layout null
))
219 ;; How sure are we that this class won't be redefined?
220 ;; :READ-ONLY = We are committed to not changing the effective
221 ;; slots or superclasses.
222 ;; :SEALED = We can't even add subclasses.
223 ;; NIL = Anything could happen.
224 (state nil
:type
(member nil
:read-only
:sealed
))
225 ;; direct superclasses of this class. Always NIL for CLOS classes.
226 (direct-superclasses () :type list
)
227 ;; representation of all of the subclasses (direct or indirect) of
228 ;; this class. This is NIL if no subclasses or not initalized yet;
229 ;; otherwise, it's an EQ hash-table mapping CLASSOID objects to the
230 ;; subclass layout that was in effect at the time the subclass was
232 (subclasses nil
:type
(or null hash-table
))
233 ;; the PCL class (= CL:CLASS, but with a view to future flexibility
234 ;; we don't just call it the CLASS slot) object for this class, or
235 ;; NIL if none assigned yet
238 ;;;; object types to represent classes
240 ;;; An UNDEFINED-CLASSOID is a cookie we make up to stick in forward
241 ;;; referenced layouts. Users should never see them.
242 (def!struct
(undefined-classoid
245 (:constructor make-undefined-classoid
(name))))
247 ;;; BUILT-IN-CLASS is used to represent the standard classes that
248 ;;; aren't defined with DEFSTRUCT and other specially implemented
249 ;;; primitive types whose only attribute is their name.
251 ;;; Some BUILT-IN-CLASSes have a TRANSLATION, which means that they
252 ;;; are effectively DEFTYPE'd to some other type (usually a union of
253 ;;; other classes or a "primitive" type such as NUMBER, ARRAY, etc.)
254 ;;; This translation is done when type specifiers are parsed. Type
255 ;;; system operations (union, subtypep, etc.) should never encounter
256 ;;; translated classes, only their translation.
257 (def!struct
(built-in-classoid (:include classoid
)
259 (:constructor make-built-in-classoid
))
260 ;; the type we translate to on parsing. If NIL, then this class
261 ;; stands on its own; or it can be set to :INITIALIZING for a period
263 (translation nil
:type
(or ctype
(member nil
:initializing
))))
265 (def!struct
(condition-classoid (:include classoid
)
267 (:constructor make-condition-classoid
))
268 ;; list of CONDITION-SLOT structures for the direct slots of this
270 (slots nil
:type list
)
271 ;; list of CONDITION-SLOT structures for all of the effective class
272 ;; slots of this class
273 (class-slots nil
:type list
)
274 ;; report function or NIL
275 (report nil
:type
(or function null
))
276 ;; list of specifications of the form
278 ;; (INITARG INITFORM THUNK)
280 ;; where THUNK, when called without arguments, returns the value for
282 (direct-default-initargs () :type list
)
283 ;; class precedence list as a list of CLASS objects, with all
284 ;; non-CONDITION classes removed
286 ;; a list of all the effective instance allocation slots of this
287 ;; class that have a non-constant initform or default-initarg.
288 ;; Values for these slots must be computed in the dynamic
289 ;; environment of MAKE-CONDITION.
290 (hairy-slots nil
:type list
))
292 ;;;; classoid namespace
294 ;;; We use an indirection to allow forward referencing of class
295 ;;; definitions with load-time resolution.
296 (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
)
343 (:constructor make-standard-classoid
)))
344 ;;; a metaclass for classes which aren't standardlike but will never
346 (def!struct
(static-classoid (:include classoid
)
348 (:constructor make-static-classoid
)))
350 (declaim (freeze-type built-in-classoid condition-classoid
351 standard-classoid static-classoid
))
355 ;;; layout for this type being used by the compiler
356 (define-info-type (:type
:compiler-layout
)
357 :type-spec
(or layout null
)
358 :default
(lambda (name)
359 (awhen (find-classoid name nil
) (classoid-layout it
))))
361 (eval-when (#-sb-xc
:compile-toplevel
:load-toplevel
:execute
)
362 (defun ftype-from-fdefn (name)
363 (declare (ignorable name
))
364 ;; Again [as in (DEFINE-INFO-TYPE (:FUNCTION :TYPE) ...)] it's
365 ;; not clear how to generalize the FBOUNDP expression to the
366 ;; cross-compiler. -- WHN 19990330
368 (specifier-type 'function
)
370 (let* ((fdefn (sb!kernel
::find-fdefn name
))
371 (fun (and fdefn
(fdefn-fun fdefn
))))
373 (handler-bind ((style-warning #'muffle-warning
))
374 (specifier-type (sb!impl
::%fun-type fun
)))
375 (specifier-type 'function
)))))
377 ;;; The type specifier for this function, or a DEFSTRUCT-DESCRIPTION
378 ;;; or the symbol :GENERIC-FUNTION.
379 ;;; If a DD, it must contain a constructor whose name is
380 ;;; the one being sought in globaldb, which is used to derive the type.
381 ;;; If :GENERIC-FUNCTION, the info is recomputed from existing methods
382 ;;; and stored back into globaldb.
383 (define-info-type (:function
:type
)
384 :type-spec
(or ctype defstruct-description
(member :generic-function
))
385 :default
#'ftype-from-fdefn
)
387 ;;; A random place for this :-(
388 #+sb-xc-host
(setq *info-environment
* (make-info-hashtable))