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 (declaim (ftype (function (t t t
) (values t t
&optional
)) info
)
19 (ftype (function (t t t
) (values t
&optional
)) clear-info
)
20 (ftype (function (t t t t
) (values t
&optional
)) (setf info
)))
22 ;;; At run time, we represent the type of a piece of INFO in the globaldb
23 ;;; by a small integer between 1 and 63. [0 is reserved for internal use.]
24 ;;; CLISP, and maybe others, need EVAL-WHEN because without it, the constant
25 ;;; is not seen by the "#." expression a few lines down.
26 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
27 (defconstant info-number-bits
6))
28 (def!type info-number
() `(unsigned-byte ,info-number-bits
))
30 ;;; A map from info-number to its META-INFO object.
31 ;;; The reverse mapping is obtained by reading the META-INFO.
32 (declaim (type (simple-vector #.
(ash 1 info-number-bits
)) *info-types
*))
33 (!defglobal
*info-types
*
34 (make-array (ash 1 info-number-bits
) :initial-element nil
))
38 !make-meta-info
(number category kind type-spec
39 type-checker validate-function default
))
41 ;; a number that uniquely identifies this object
42 (number nil
:type info-number
:read-only t
)
43 ;; 2-part key to this piece of metainfo
44 (category nil
:type keyword
:read-only t
)
45 (kind nil
:type keyword
:read-only t
)
46 ;; a type specifier which info of this type must satisfy
47 (type-spec nil
:type t
:read-only t
)
48 ;; Two functions called by (SETF INFO) before calling SET-INFO-VALUE.
49 ;; 1. A function that type-checks its argument and returns it,
50 ;; or signals an error.
51 ;; Some Lisps trip over their shoelaces trying to assert that
52 ;; a function is (function (t) t). Our code is fine though.
53 (type-checker nil
:type
#+sb-xc-host function
#-sb-xc-host
(sfunction (t) t
)
55 ;; 2. a function of two arguments, a name and new-value, which performs
56 ;; any other checks and/or side-effects including signaling an error.
57 (validate-function nil
:type
(or function null
) :read-only t
)
58 ;; If FUNCTIONP, then a function called when there is no information of
59 ;; this type. If not FUNCTIONP, then any object serving as a default.
62 (declaim (freeze-type meta-info
))
64 (defconstant +info-metainfo-type-num
+ 0)
66 ;; Refer to info-vector.lisp for the meaning of this constant.
67 (defconstant +no-auxilliary-key
+ 0)
69 ;;; SYMBOL-INFO is a primitive object accessor defined in 'objdef.lisp'
70 ;;; But in the host Lisp, there is no such thing as a symbol-info slot.
71 ;;; Instead, symbol-info is kept in the host symbol's plist.
73 (defmacro symbol-info-vector
(symbol) `(get ,symbol
:sb-xc-globaldb-info
))
75 ;; Perform the equivalent of (GET-INFO-VALUE KIND +INFO-METAINFO-TYPE-NUM+)
76 ;; but skipping the defaulting logic.
77 ;; Return zero or more META-INFOs that match on KIND, which is usually
78 ;; - though not always - a unique identifier for the (:TYPE :KIND) pair.
79 ;; Note that bypassing of defaults is critical for bootstrapping,
80 ;; since INFO is used to retrieve its own META-INFO at system-build time.
81 (defmacro !get-meta-infos
(kind)
82 `(let* ((info-vector (symbol-info-vector ,kind
))
83 (index (if info-vector
84 (packed-info-value-index info-vector
+no-auxilliary-key
+
85 +info-metainfo-type-num
+))))
86 (if index
(svref info-vector index
))))
88 ;; (UNSIGNED-BYTE 16) is an arbitrarily generous limit on the number of
89 ;; cells in an info-vector. Most vectors have a fewer than a handful of things,
90 ;; and performance would need to be re-thought if more than about a dozen
91 ;; cells were in use. (It would want to become hash-based probably)
92 (declaim (ftype (function (simple-vector (or (eql 0) symbol
) info-number
)
93 (or null
(unsigned-byte 16)))
94 packed-info-value-index
))
96 ;; Return the META-INFO object for CATEGORY and KIND, signaling an error
97 ;; if not found and ERRORP is non-nil. Note that the two-level logical hierarchy
98 ;; of CATEGORY + KIND is physically grouped by KIND first, then CATEGORY.
99 ;; e.g. Searching for (:SETF :EXPANDER) searches for :EXPANDER and finds
100 ;; (#<:CAS :EXPANDER, 44> #<:SETF :EXPANDER, 43> #<:TYPE :EXPANDER, 25>)
101 ;; from which one is picked. This is slightly faster than searching first by
102 ;; CATEGORY, because in the case of :FUNCTION there would be ~11 things to sift
103 ;; through, whereas typically no more than 3 or 4 items have the same KIND.
105 (defun meta-info (category kind
&optional
(errorp t
))
106 (or (let ((metadata (!get-meta-infos kind
)))
107 (cond ((listp metadata
) ; conveniently handles NIL
108 (dolist (info metadata nil
) ; FIND is slower :-(
109 (when (eq (meta-info-category (truly-the meta-info info
))
112 ((eq (meta-info-category (truly-the meta-info metadata
)) category
)
114 ;; !GET-META-INFOS enforces that KIND is a symbol, therefore
115 ;; if a metaobject was found, CATEGORY was necessarily a symbol too.
116 ;; Otherwise, if the caller wants no error to be signaled on missing info,
117 ;; we must nevertheless enforce that CATEGORY was actually a symbol.
119 (error "(~S ~S) is not a defined info type." category kind
)
120 (progn (the symbol category
) nil
)))) ; THE is for type-safety
122 ;;; Compiler macros for INFO functions.
124 ;;; These are defined ASAP so that when building the cross-compiler, all calls
125 ;;; occurring after compilation of "globaldb" (for known constant meta-info)
126 ;;; are transformed; and when executing the cross-compiler, *all* inlineable
127 ;;; calls for known constant meta-info are transformed;
128 ;;; and when running target code, calls with legal constants for the first two
129 ;;; arguments are transformed.
130 (macrolet ((def (name lambda-list form
)
131 (assert (and (member 'category lambda-list
)
132 (member 'kind lambda-list
)))
133 `(define-compiler-macro ,name
,(append '(&whole .whole.
) lambda-list
)
134 (if (and (keywordp category
) (keywordp kind
))
135 ;; In the target Lisp, it's a STYLE-WARNING if this macro
136 ;; defers to a full call to #'INFO.
137 ;; If the cross-compilation host, if any info-type is
138 ;; defined, then it's an error not to find the meta-info.
139 ;; If no info-types are defined, silently defer.
141 (and #+sb-xc-host
(find-if #'identity
*info-types
*)
142 (meta-info category kind
#-sb-xc-host nil
))))
147 (style-warn "(INFO ~S ~S) will fail at runtime."
152 (def info
(category kind name
)
153 `(truly-the (values ,(meta-info-type-spec meta-info
) boolean
)
154 (get-info-value ,name
,(meta-info-number meta-info
))))
156 (def (setf info
) (new-value category kind name
)
157 (let* (#+sb-xc-host
(sb!xc
:*gensym-counter
* sb
!xc
:*gensym-counter
*)
158 (tin (meta-info-number meta-info
)) ; info-type id number
159 (type-spec (meta-info-type-spec meta-info
))
161 (when (meta-info-validate-function meta-info
)
162 ;; is (or ... null), but non-null at macroexpansion time
163 ;; implies non-null at runtime.
165 (meta-info-validate-function
166 (truly-the meta-info
(svref *info-types
* ,tin
)))))))
167 (with-unique-names (new)
168 `(let ((,new
,new-value
))
169 ;; enforce type-correctness regardless of enclosing policy
170 (let ((,new
(locally (declare (optimize (safety 3)))
171 (the ,type-spec
,new
))))
173 `((funcall ,check
,name
,new
)))
174 (set-info-value ,name
,tin
,new
))))))
176 (def clear-info
(category kind name
)
177 `(clear-info-values ,name
'(,(meta-info-number meta-info
)))))
179 ;; Perform the approximate equivalent operations of retrieving
180 ;; (INFO :CATEGORY :KIND NAME), but if no info is found, invoke CREATION-FORM
181 ;; to produce an object that becomes the value for that piece of info, storing
182 ;; and returning it. The entire sequence behaves atomically but with a proviso:
183 ;; the creation form's result may be discarded, and another object returned
184 ;; instead (presumably) from another thread's execution of the creation form.
185 ;; If constructing the object has either non-trivial cost, or deleterious
186 ;; side-effects from making and discarding its result, do NOT use this macro.
187 ;; A mutex-guarded table would probably be more appropriate in such cases.
189 (defmacro get-info-value-initializing
(category kind name creation-form
)
190 (with-unique-names (info-number proc
)
192 ,(if (and (keywordp category
) (keywordp kind
))
193 (meta-info-number (meta-info category kind
))
194 `(meta-info-number (meta-info ,category
,kind
)))))
195 (dx-flet ((,proc
() ,creation-form
))
196 (%get-info-value-initializing
,name
,info-number
#',proc
)))))