1 ;;;; This file contains stuff that was split out from 'globaldb.lisp'
2 ;;;; to satisfy build-order constraints.
4 ;;;; This software is part of the SBCL system. See the README file for
7 ;;;; This software is derived from the CMU CL system, which was
8 ;;;; written at Carnegie Mellon University and released into the
9 ;;;; public domain. The software is in the public domain and is
10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
11 ;;;; files for more information.
13 ;;; Given the presence of docstrings and source locations,
14 ;;; this logic arguably belongs to the runtime kernel, not the compiler,
15 ;;; but such nuance isn't hugely important.
18 ;;; Similar to FUNCTION, but the result type is "exactly" specified:
19 ;;; if it is an object type, then the function returns exactly one
20 ;;; value, if it is a short form of VALUES, then this short form
21 ;;; specifies the exact number of values.
22 (def!type sfunction
(args &optional result
)
23 (let ((result (cond ((eq result
'*) '*)
25 (not (eq (car result
) 'values
)))
26 `(values ,result
&optional
))
27 ((intersection (cdr result
) sb
!xc
:lambda-list-keywords
)
29 (t `(values ,@(cdr result
) &optional
)))))
30 `(function ,args
,result
)))
32 (declaim (ftype (sfunction (t t t
) (values t t
)) info
)
33 (ftype (sfunction (t t t
) t
) clear-info
)
34 (ftype (sfunction (t t t t
) t
) (setf info
)))
36 ;;; (:FUNCTION :TYPE) information is extracted through a wrapper.
37 ;;; The globaldb representation is not necessarily literally a CTYPE.
39 (declaim (ftype (sfunction (t) (values ctype boolean
)) proclaimed-ftype
))
41 ;;; At run time, we represent the type of a piece of INFO in the globaldb
42 ;;; by a small integer between 1 and 63. [0 is reserved for internal use.]
43 ;;; CLISP, and maybe others, need EVAL-WHEN because without it, the constant
44 ;;; is not seen by the "#." expression a few lines down.
45 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
46 (defconstant info-number-bits
6))
47 (def!type info-number
() `(unsigned-byte ,info-number-bits
))
49 ;;; A map from info-number to its META-INFO object.
50 ;;; The reverse mapping is obtained by reading the META-INFO.
51 (declaim (type (simple-vector #.
(ash 1 info-number-bits
)) *info-types
*))
52 (!defglobal
*info-types
*
53 (make-array (ash 1 info-number-bits
) :initial-element nil
))
57 !make-meta-info
(number category kind type-spec
58 type-checker validate-function default
))
60 ;; a number that uniquely identifies this object
61 (number nil
:type info-number
:read-only t
)
62 ;; 2-part key to this piece of metainfo
63 (category nil
:type keyword
:read-only t
)
64 (kind nil
:type keyword
:read-only t
)
65 ;; a type specifier which info of this type must satisfy
66 (type-spec nil
:type t
:read-only t
)
67 ;; Two functions called by (SETF INFO) before calling SET-INFO-VALUE.
68 ;; 1. A function that type-checks its argument and returns it,
69 ;; or signals an error.
70 ;; Some Lisps trip over their shoelaces trying to assert that
71 ;; a function is (function (t) t). Our code is fine though.
72 (type-checker nil
:type
#+sb-xc-host function
#-sb-xc-host
(sfunction (t) t
)
74 ;; 2. a function of two arguments, a name and new-value, which performs
75 ;; any other checks and/or side-effects including signaling an error.
76 (validate-function nil
:type
(or function null
) :read-only t
)
77 ;; If FUNCTIONP, then a function called when there is no information of
78 ;; this type. If not FUNCTIONP, then any object serving as a default.
79 (default nil
:read-only t
))
81 (declaim (freeze-type meta-info
))
83 (defconstant +info-metainfo-type-num
+ 0)
85 ;; Refer to info-vector.lisp for the meaning of this constant.
86 (defconstant +no-auxilliary-key
+ 0)
88 ;;; SYMBOL-INFO is a primitive object accessor defined in 'objdef.lisp'
89 ;;; But in the host Lisp, there is no such thing as a symbol-info slot.
90 ;;; Instead, symbol-info is kept in the host symbol's plist.
92 (defmacro symbol-info-vector
(symbol) `(get ,symbol
:sb-xc-globaldb-info
))
94 ;; Perform the equivalent of (GET-INFO-VALUE KIND +INFO-METAINFO-TYPE-NUM+)
95 ;; but skipping the defaulting logic.
96 ;; Return zero or more META-INFOs that match on KIND, which is usually
97 ;; - though not always - a unique identifier for the (:TYPE :KIND) pair.
98 ;; Note that bypassing of defaults is critical for bootstrapping,
99 ;; since INFO is used to retrieve its own META-INFO at system-build time.
100 (defmacro !get-meta-infos
(kind)
101 `(let* ((info-vector (symbol-info-vector ,kind
))
102 (index (if info-vector
103 (packed-info-value-index info-vector
+no-auxilliary-key
+
104 +info-metainfo-type-num
+))))
105 (if index
(svref info-vector index
))))
107 ;; (UNSIGNED-BYTE 16) is an arbitrarily generous limit on the number of
108 ;; cells in an info-vector. Most vectors have a fewer than a handful of things,
109 ;; and performance would need to be re-thought if more than about a dozen
110 ;; cells were in use. (It would want to become hash-based probably)
111 (declaim (ftype (function (simple-vector (or (eql 0) symbol
) info-number
)
112 (or null
(unsigned-byte 16)))
113 packed-info-value-index
))
115 ;; Return the META-INFO object for CATEGORY and KIND, signaling an error
116 ;; if not found and ERRORP is non-nil. Note that the two-level logical hierarchy
117 ;; of CATEGORY + KIND is physically grouped by KIND first, then CATEGORY.
118 ;; e.g. Searching for (:SETF :EXPANDER) searches for :EXPANDER and finds
119 ;; (#<:CAS :EXPANDER, 44> #<:SETF :EXPANDER, 43> #<:TYPE :EXPANDER, 25>)
120 ;; from which one is picked. This is slightly faster than searching first by
121 ;; CATEGORY, because in the case of :FUNCTION there would be ~11 things to sift
122 ;; through, whereas typically no more than 3 or 4 items have the same KIND.
124 (defun meta-info (category kind
&optional
(errorp t
))
125 (or (let ((metadata (!get-meta-infos kind
)))
126 (cond ((listp metadata
) ; conveniently handles NIL
127 (dolist (info metadata nil
) ; FIND is slower :-(
128 (when (eq (meta-info-category (truly-the meta-info info
))
131 ((eq (meta-info-category (truly-the meta-info metadata
)) category
)
133 ;; !GET-META-INFOS enforces that KIND is a symbol, therefore
134 ;; if a metaobject was found, CATEGORY was necessarily a symbol too.
135 ;; Otherwise, if the caller wants no error to be signaled on missing info,
136 ;; we must nevertheless enforce that CATEGORY was actually a symbol.
138 (error "(~S ~S) is not a defined info type." category kind
)
139 (progn (the symbol category
) nil
)))) ; THE is for type-safety
141 ;;; Compiler macros for INFO functions.
143 ;;; These are defined ASAP so that when building the cross-compiler, all calls
144 ;;; occurring after compilation of "globaldb" (for known constant meta-info)
145 ;;; are transformed; and when executing the cross-compiler, *all* inlineable
146 ;;; calls for known constant meta-info are transformed;
147 ;;; and when running target code, calls with legal constants for the first two
148 ;;; arguments are transformed.
149 (macrolet ((def (name lambda-list form
)
150 (assert (and (member 'category lambda-list
)
151 (member 'kind lambda-list
)))
152 `(define-compiler-macro ,name
,(append '(&whole .whole.
) lambda-list
)
153 (if (and (keywordp category
) (keywordp kind
))
154 ;; In the target Lisp, it's a STYLE-WARNING if this macro
155 ;; defers to a full call to #'INFO.
156 ;; If the cross-compilation host, if any info-type is
157 ;; defined, then it's an error not to find the meta-info.
158 ;; If no info-types are defined, silently defer.
160 (and #+sb-xc-host
(find-if #'identity
*info-types
*)
161 (meta-info category kind
#-sb-xc-host nil
))))
166 (style-warn "(~S ~S) is not a defined info type."
171 (def info
(category kind name
)
172 `(truly-the (values ,(meta-info-type-spec meta-info
) boolean
)
173 (get-info-value ,name
,(meta-info-number meta-info
))))
175 (def (setf info
) (new-value category kind name
)
176 (let* (#+sb-xc-host
(sb!xc
:*gensym-counter
* sb
!xc
:*gensym-counter
*)
177 (tin (meta-info-number meta-info
)) ; info-type id number
178 (type-spec (meta-info-type-spec meta-info
))
179 (new (make-symbol "NEW"))
181 (when (meta-info-validate-function meta-info
)
182 ;; is (or ... null), but non-null at macroexpansion time
183 ;; implies non-null at runtime.
185 (meta-info-validate-function
186 (truly-the meta-info
(svref *info-types
* ,tin
)))))))
187 `(let ((,new
,new-value
))
188 ;; enforce type-correctness regardless of enclosing policy
189 (let ((,new
(locally (declare (optimize (safety 3)))
190 (the ,type-spec
,new
))))
192 `((funcall ,check
,name
,new
)))
193 (set-info-value ,name
,tin
,new
)))))
195 (def clear-info
(category kind name
)
196 `(clear-info-values ,name
'(,(meta-info-number meta-info
)))))
198 ;; interface to %ATOMIC-SET-INFO-VALUE
199 ;; GET-INFO-VALUE-INITIALIZING is a restricted case of this,
200 ;; and perhaps could be implemented as such.
201 ;; Atomic update will be important for making the fasloader threadsafe
202 ;; using a predominantly lock-free design, and other nice things.
203 (defmacro atomic-set-info-value
(category kind name lambda
)
204 (with-unique-names (info-number proc
)
206 ,(if (and (keywordp category
) (keywordp kind
))
207 (meta-info-number (meta-info category kind
))
208 `(meta-info-number (meta-info ,category
,kind
)))))
209 ,(if (and (listp lambda
) (eq (car lambda
) 'lambda
))
210 ;; rewrite as FLET because the compiler is unable to dxify
211 ;; (DX-LET ((x (LAMBDA <whatever>))) (F x))
212 (destructuring-bind (lambda-list . body
) (cdr lambda
)
213 `(dx-flet ((,proc
,lambda-list
,@body
))
214 (%atomic-set-info-value
,name
,info-number
#',proc
)))
215 `(%atomic-set-info-value
,name
,info-number
,lambda
)))))
217 ;; Perform the approximate equivalent operations of retrieving
218 ;; (INFO :CATEGORY :KIND NAME), but if no info is found, invoke CREATION-FORM
219 ;; to produce an object that becomes the value for that piece of info, storing
220 ;; and returning it. The entire sequence behaves atomically but with a proviso:
221 ;; the creation form's result may be discarded, and another object returned
222 ;; instead (presumably) from another thread's execution of the creation form.
223 ;; If constructing the object has either non-trivial cost, or deleterious
224 ;; side-effects from making and discarding its result, do NOT use this macro.
225 ;; A mutex-guarded table would probably be more appropriate in such cases.
227 (defmacro get-info-value-initializing
(category kind name creation-form
)
228 (let ((proc (make-symbol "THUNK")))
229 `(dx-flet ((,proc
() ,creation-form
))
230 (%get-info-value-initializing
231 ,(if (and (keywordp category
) (keywordp kind
))
232 (meta-info-number (meta-info category kind
))
233 `(meta-info-number (meta-info ,category
,kind
)))
236 ;;;; boolean attribute utilities
238 ;;;; We need to maintain various sets of boolean attributes for known
239 ;;;; functions and VOPs. To save space and allow for quick set
240 ;;;; operations, we represent the attributes as bits in a fixnum.
242 (deftype attributes
() 'fixnum
)
244 ;;; Given a list of attribute names and an alist that translates them
245 ;;; to masks, return the OR of the masks.
246 (defun encode-attribute-mask (names universe
)
247 (loop for name in names
248 for pos
= (position name universe
)
249 sum
(if pos
(ash 1 pos
) (error "unknown attribute name: ~S" name
))))
251 (defun decode-attribute-mask (bits universe
)
252 (loop for name across universe
253 for mask
= 1 then
(ash mask
1)
254 when
(logtest mask bits
) collect name
))
256 ;;; Define a new class of boolean attributes, with the attributes
257 ;;; having the specified ATTRIBUTE-NAMES. NAME is the name of the
258 ;;; class, which is used to generate some macros to manipulate sets of
261 ;;; NAME-attributep attributes attribute-name*
262 ;;; Return true if one of the named attributes is present, false
263 ;;; otherwise. When set with SETF, updates the place Attributes
264 ;;; setting or clearing the specified attributes.
266 ;;; NAME-attributes attribute-name*
267 ;;; Return a set of the named attributes.
268 (defmacro !def-boolean-attribute
(name &rest attribute-names
)
269 (let ((vector (coerce attribute-names
'vector
))
270 (constructor (symbolicate name
"-ATTRIBUTES"))
271 (test-name (symbolicate name
"-ATTRIBUTEP")))
273 (defmacro ,constructor
(&rest attribute-names
)
275 "Automagically generated boolean attribute creation function.
276 See !DEF-BOOLEAN-ATTRIBUTE."
277 (encode-attribute-mask attribute-names
,vector
))
278 (defun ,(symbolicate "DECODE-" name
"-ATTRIBUTES") (attributes)
279 (decode-attribute-mask attributes
,vector
))
280 (defmacro ,test-name
(attributes &rest attribute-names
)
282 "Automagically generated boolean attribute test function.
283 See !DEF-BOOLEAN-ATTRIBUTE."
284 `(logtest (the attributes
,attributes
)
285 (,',constructor
,@attribute-names
)))
286 (define-setf-expander ,test-name
(place &rest attributes
289 "Automagically generated boolean attribute setter. See
290 !DEF-BOOLEAN-ATTRIBUTE."
291 (multiple-value-bind (temps values stores setter getter
)
292 (#+sb-xc-host get-setf-expansion
293 #-sb-xc-host sb
!xc
:get-setf-expansion place env
)
295 (error "multiple store variables for ~S" place
))
296 (let ((newval (sb!xc
:gensym
))
297 (n-place (sb!xc
:gensym
))
298 (mask (encode-attribute-mask attributes
,vector
)))
299 (values `(,@temps
,n-place
)
302 `(let ((,(first stores
)
304 (logior ,n-place
,mask
)
305 (logandc2 ,n-place
,mask
))))
308 `(,',test-name
,n-place
,@attributes
))))))))
310 ;;; And now for some gratuitous pseudo-abstraction...
313 ;;; Return the union of all the sets of boolean attributes which are its
315 ;;; ATTRIBUTES-INTERSECTION
316 ;;; Return the intersection of all the sets of boolean attributes which
317 ;;; are its arguments.
319 ;;; True if the attributes present in ATTR1 are identical to
321 (defmacro attributes-union
(&rest attributes
)
323 (logior ,@(mapcar (lambda (x) `(the attributes
,x
)) attributes
))))
324 (defmacro attributes-intersection
(&rest attributes
)
326 (logand ,@(mapcar (lambda (x) `(the attributes
,x
)) attributes
))))
327 (declaim (ftype (function (attributes attributes
) boolean
) attributes
=))
328 #!-sb-fluid
(declaim (inline attributes
=))
329 (defun attributes= (attr1 attr2
)