1 ;;;; This file contains functions that hack on the global function
2 ;;;; namespace (primarily concerned with SETF functions here). Also,
3 ;;;; function encapsulation and routines that set and return
4 ;;;; definitions disregarding whether they might be encapsulated.
6 ;;;; This software is part of the SBCL system. See the README file for
9 ;;;; This software is derived from the CMU CL system, which was
10 ;;;; written at Carnegie Mellon University and released into the
11 ;;;; public domain. The software is in the public domain and is
12 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
13 ;;;; files for more information.
15 (in-package "SB-IMPL")
18 ;;;; fdefinition (fdefn) objects
20 (defun make-fdefn (name)
21 #-
(and x86-64 immobile-space
) (make-fdefn name
)
22 #+(and x86-64 immobile-space
)
23 (let ((fdefn (truly-the (values fdefn
&optional
)
24 (sb-vm::alloc-immobile-fdefn
))))
25 (%primitive sb-vm
::set-slot fdefn name
'make-fdefn
26 sb-vm
:fdefn-name-slot sb-vm
:other-pointer-lowtag
)
27 (fdefn-makunbound fdefn
)
30 (defun undo-static-linkage (fdefn) (declare (ignore fdefn
)))
32 (defun (setf fdefn-fun
) (fun fdefn
)
33 (declare (type function fun
)
35 (undo-static-linkage fdefn
)
36 (sb-c::when-vop-existsp
(:named sb-vm
::set-fdefn-fun
)
37 (%primitive sb-vm
::set-fdefn-fun fun fdefn
))
38 (sb-c::unless-vop-existsp
(:named sb-vm
::set-fdefn-fun
)
39 (sb-vm::set-fdefn-fun fun fdefn
))
42 ;;; Return the FDEFN object for NAME, or NIL if there is no fdefn.
43 ;;; Signal an error if name isn't valid.
44 ;;; Assume that exists-p implies LEGAL-FUN-NAME-P.
45 (declaim (ftype (sfunction ((or symbol list
)) (or fdefn null
)) find-fdefn
))
46 (defun find-fdefn (name)
47 (declare (explicit-check))
48 (when (symbolp name
) ; Don't need LEGAL-FUN-NAME-P check
49 (let ((fdefn (sb-vm::%symbol-fdefn name
))) ; slot default is 0, not NIL
50 (return-from find-fdefn
(if (eql fdefn
0) nil fdefn
))))
51 ;; Technically the ALLOW-ATOM argument of NIL isn't needed, but
52 ;; the compiler isn't figuring out not to test SYMBOLP twice in a row.
53 (with-globaldb-name (key1 key2 nil
) name
55 (awhen (get-fancily-named-fdefn name nil
)
56 (return-from find-fdefn it
))
59 (awhen (symbol-dbinfo key1
)
60 (multiple-value-bind (data-idx descriptor-idx field-idx
)
61 (info-find-aux-key/packed it key2
)
62 (declare (type index descriptor-idx
)
63 (type (integer 0 #.
+infos-per-word
+) field-idx
))
64 ;; Secondary names must have at least one info, so if a descriptor
65 ;; exists, there's no need to extract the n-infos field.
67 (when (eql (incf field-idx
) +infos-per-word
+)
68 (setq field-idx
0 descriptor-idx
(1+ descriptor-idx
)))
69 (when (eql (packed-info-field it descriptor-idx field-idx
)
71 (return-from find-fdefn
72 (%info-ref it
(1- (the index data-idx
))))))))
73 (when (eq key1
'setf
) ; bypass the legality test
74 (return-from find-fdefn nil
))))
75 (legal-fun-name-or-type-error name
))
77 ;;; Return T if FUNCTION is the error-signaling trampoline for a macro or a
78 ;;; special operator. Test for this by seeing whether FUNCTION is the same
79 ;;; closure as for a known macro.
80 (declaim (inline macro
/special-guard-fun-p
))
81 (defun macro/special-guard-fun-p
(function)
82 ;; When inlined, this is a few instructions shorter than CLOSUREP
83 ;; if we already know that FUNCTION is a function.
84 ;; It will signal a type error if not, which is the right thing to do anyway.
85 ;; (this isn't quite a true predicate)
86 (and (= (%fun-pointer-widetag function
) sb-vm
:closure-widetag
)
87 ;; This test needs to reference the name of any macro, but in order for
88 ;; cold-init to work, the macro has to be defined first.
89 ;; So pick DX-LET, as it's in primordial-extensions.
90 ;; Prior to cold-init fixing up the load-time-value, this compares
91 ;; %closure-fun to 0, which is ok - it returns NIL.
92 (eq (load-time-value (%closure-fun
(symbol-function 'dx-let
)) t
)
93 (%closure-fun function
))))
95 ;;; This is the implementation of (COERCE s 'function) when S is of type symbol
96 ;;; used by either the full call or the compile-time transform for that pattern.
97 (defun coerce-symbol-to-fun (symbol)
98 (let ((def (%symbol-function symbol
)))
99 (cond ((not def
) (error 'undefined-function
:name symbol
))
100 ((macro/special-guard-fun-p def
)
101 (error (ecase (car (%fun-name def
))
102 (:macro
"~S names a macro.")
103 (:special
"~S names a special operator."))
107 (define-load-time-global *fdefn-of-nil
* (make-fdefn nil
))
108 (declaim (ftype (sfunction (t) fdefn
) find-or-create-fdefn
))
109 (defun find-or-create-fdefn (name)
112 (let ((fdefn (sb-vm::%symbol-fdefn name
)))
113 (cond ((and fdefn
(neq fdefn
0)) fdefn
)
114 ((null name
) *fdefn-of-nil
*)
115 (t (let* ((new (make-fdefn name
))
116 (actual (sb-vm::cas-symbol-fdefn name
0 new
)))
117 (if (eql actual
0) new
(the fdefn actual
)))))))
120 ;; We won't reach here if the name was not legal
122 (dx-flet ((new (name)
125 (let ((fdefn (with-globaldb-name (key1 key2
) name
126 :simple
(get-info-value-initializing
127 :function
:definition name
(new name
))
128 :hairy
(get-fancily-named-fdefn name
#'new
))))
129 ;; Slot accessors spring into existence as soon as a reference
130 ;; is made to the respective fdefn, but we can't do this in
131 ;; (flet NEW) because ENSURE-ACCESSOR calls (SETF FDEFINITION)
132 ;; which would recurse, as the fdefn would not have been
135 (typep name
'(cons (eql sb-pcl
::slot-accessor
))))
136 (sb-pcl::ensure-accessor name
))
139 ;;; Remove NAME's FTYPE information unless it was explicitly PROCLAIMED.
140 ;;; The NEW-FUNCTION argument is presently unused, but could be used
141 ;;; for checking compatibility of the NEW-FUNCTION against a proclamation.
142 ;;; (We could issue a warning and/or remove the type if incompatible.)
143 (defun maybe-clobber-ftype (name new-function
)
144 (declare (ignore new-function
))
145 ;; Ignore PCL-internal function names.
146 (unless (pcl-methodfn-name-p name
)
147 (unless (eq :declared
(info :function
:where-from name
))
148 (clear-info :function
:type name
))))
150 ;;; Return the fdefn-fun of NAME's fdefinition including any
151 ;;; encapsulations. This is the core of the implementation of the standard
152 ;;; FDEFINITION function, but as we've defined FDEFINITION, that
153 ;;; strips encapsulations.
154 (defun %coerce-name-to-fun
(name)
156 ((and symbol
(not null
))
157 (let ((fun (%symbol-function name
)))
158 (when (and fun
(not (macro/special-guard-fun-p fun
)))
159 (return-from %coerce-name-to-fun fun
))))
161 (binding* ((fdefn (find-fdefn name
) :exit-if-null
)
162 (fun (fdefn-fun fdefn
) :exit-if-null
))
163 (return-from %coerce-name-to-fun fun
))))
164 ;; We explicitly allow any function name when retrying,
165 ;; even if the erring caller was SYMBOL-FUNCTION. It is consistent
166 ;; that both #'(SETF MYNEWFUN) and '(SETF MYNEWFUN) are permitted
167 ;; as the object to use in the USE-VALUE restart.
168 (setq name
(restart-case (if (legal-fun-name-p name
)
169 (error 'undefined-function
:name name
)
170 (legal-fun-name-or-type-error name
))
172 :report
(lambda (stream)
173 (format stream
"Retry using ~s." name
))
176 :report
(lambda (stream)
177 (format stream
"Use specified function"))
178 :interactive read-evaluated-form
179 (if (functionp value
)
180 (return-from %coerce-name-to-fun value
)
182 (%coerce-name-to-fun name
))
184 ;; Coerce CALLABLE (a function-designator) to a FUNCTION.
185 ;; The compiler emits this when someone tries to FUNCALL something.
186 ;; Extended-function-designators are not accepted,
187 ;; This function declares EXPLICIT-CHECK, and we avoid calling
188 ;; SYMBOL-FUNCTION because that would do another check.
189 ;; It would be great if this could change its error message
190 ;; depending on the input to either:
191 ;; "foo is not a function designator" if not a CALLABLE
192 ;; "foo does not designate a currently defined function"
193 ;; if a symbol does not satisfy FBOUNDP.
194 (defun %coerce-callable-to-fun
(callable)
195 (declare (explicit-check))
198 (return-from %coerce-callable-to-fun callable
))
199 ((and symbol
(not null
)) ; NIL can't be fboundp. Quicker test this way.
200 (let ((fun (%symbol-function callable
)))
201 (when (and fun
(not (macro/special-guard-fun-p fun
)))
202 (return-from %coerce-callable-to-fun fun
))))
203 ;; If NIL, it's not technically a type-error, so instead hit the error
204 ;; in %coerce-name-to-fun which has a restart.
206 (t (error 'type-error
:expected-type
'(or symbol function
) :datum callable
)))
207 (%coerce-name-to-fun callable
))
209 ;;; Behaves just like %COERCE-CALLABLE-TO-FUN but has an ir2-convert optimizer.
210 (setf (symbol-function '%coerce-callable-for-call
) (symbol-function '%coerce-callable-to-fun
))
213 ;;;; definition encapsulation
215 (defstruct (encapsulation-info (:constructor make-encapsulation-info
218 (type nil
:type symbol
)
219 ;; the underlying definition prior to getting wrapped in a closure
220 (definition nil
:type function
))
221 (declaim (freeze-type encapsulation-info
))
223 ;;; Find the encapsulation info that has been closed over.
224 (defun encapsulation-info (fun)
225 (truly-the (or encapsulation-info null
)
227 (find-if-in-closure #'encapsulation-info-p fun
))))
229 (flet ((name->fun
(name)
231 (symbol (%symbol-function name
))
232 (t (binding* ((fdefn (find-fdefn name
) :exit-if-null
))
233 (fdefn-fun fdefn
)))))
234 (has-encap (fun type
&aux predecessor
)
235 (do ((info (encapsulation-info fun
)
236 (encapsulation-info (encapsulation-info-definition info
))))
237 ((null info
) (values nil nil
))
238 (if (eq (encapsulation-info-type info
) type
)
239 (return (values info predecessor
))
240 (setq predecessor info
)))))
242 ;;; Does NAME have an encapsulation of the given TYPE?
243 (defun encapsulated-p (name type
)
244 (declare (symbol type
))
245 (let ((fun (name->fun name
)))
246 (if (typep fun
'generic-function
)
247 (encapsulated-generic-function-p fun type
)
248 (values (has-encap fun type
)))))
250 ;;; Replace the definition of NAME with a function that calls FUNCTION
251 ;;; with the original function and its arguments.
252 ;;; TYPE is whatever you would like to associate with this
253 ;;; encapsulation for identification in case you need multiple
254 ;;; encapsulations of the same function name.
255 ;;; For non-generic functions only: if encapsulation TYPE already exists,
256 ;;; it will be replaced by a new encapsulation in an order-preserving manner,
257 ;;; otherwise the new encapsulation goes to the front of the chain.
258 (defun encapsulate (name type function
)
259 (let ((underlying-fun (name->fun name
)))
260 (when (macro/special-guard-fun-p underlying-fun
)
261 (error "~S can not be encapsulated" name
))
262 (when (typep underlying-fun
'generic-function
)
263 (return-from encapsulate
264 (encapsulate-generic-function underlying-fun type function
)))
265 (multiple-value-bind (existing predecessor
) (has-encap underlying-fun type
)
266 ;; If TYPE existed, the new DEFINITION comes from the existing
268 (setf underlying-fun
(encapsulation-info-definition existing
)))
269 (let* ((info (make-encapsulation-info type underlying-fun
))
270 (closure (named-lambda encapsulation
(&rest args
)
271 (apply function
(encapsulation-info-definition info
)
274 ;; Become the successor of the existing predecessor
275 (setf (encapsulation-info-definition predecessor
) closure
)
276 ;; Was first in chain or didn't exist
277 (setf (fdefn-fun (find-fdefn name
)) closure
))))))
279 (defun unencapsulate (name type
)
280 "Removes NAME's encapsulation of the specified TYPE if such exists."
281 (let ((fun (name->fun name
)))
282 (if (typep fun
'generic-function
)
283 (unencapsulate-generic-function fun type
)
284 (multiple-value-bind (existing predecessor
) (has-encap fun type
)
286 (let ((next (encapsulation-info-definition existing
)))
288 (setf (encapsulation-info-definition predecessor
) next
)
289 ;; It's the first one, so change the fdefn object.
290 (setf (fdefn-fun (find-fdefn name
)) next
)))))))))
295 ;;; KLUDGE: Er, it looks as though this means that
296 ;;; (FUNCALL (FDEFINITION 'FOO))
297 ;;; doesn't do the same thing as
299 ;;; and (SYMBOL-FUNCTION 'FOO) isn't in general the same thing
300 ;;; as (FDEFINITION 'FOO). That doesn't look like ANSI behavior to me.
301 ;;; Look e.g. at the ANSI definition of TRACE: "Whenever a traced
302 ;;; function is invoked, information about the call, ..". Try this:
303 ;;; (DEFUN FOO () (PRINT "foo"))
306 ;;; (FUNCALL (FDEFINITION 'FOO))
307 ;;; What to do? ANSI says TRACE "Might change the definitions of the
308 ;;; functions named by function-names." Might it be OK to just get
309 ;;; punt all this encapsulation stuff and go back to a simple but
310 ;;; correct implementation of TRACE? We'd lose the ability to redefine
311 ;;; a TRACEd function and keep the trace in place, but that seems
312 ;;; tolerable to me. (Is the wrapper stuff needed for anything else
315 ;;; The only problem I can see with not having a wrapper: If tracing
316 ;;; EQ, EQL, EQUAL, or EQUALP causes its function address to change,
317 ;;; it will mess up the MAKE-HASH-TABLE logic which uses EQ tests
318 ;;; on those function values. But given the ANSI statement about
319 ;;; TRACE causing things to change, that doesn't seem too unreasonable;
320 ;;; and we might even be able to forbid tracing these functions.
321 ;;; -- WHN 2001-11-02
322 (defun fdefinition (name)
323 "Return name's global function definition taking care to respect any
324 encapsulations and to return the innermost encapsulated definition.
326 (declare (explicit-check))
327 ;; %COERCE-NAME-TO-FUN signals an error for macros and special operators,
328 ;; but FDEFINITION should not, so pick off symbols using %SYMBOL-FUNCTION.
329 (strip-encapsulation (or (and (symbolp name
) (%symbol-function name
))
330 (%coerce-name-to-fun name
))))
331 (defun strip-encapsulation (fun)
333 (let ((encap-info (encapsulation-info fun
)))
335 (setf fun
(encapsulation-info-definition encap-info
))
338 (define-load-time-global *setf-fdefinition-hook
* nil
339 "A list of functions that (SETF FDEFINITION) invokes before storing the
340 new value. The functions take the function name and the new value.")
342 ;; Reject any "object of implementation-dependent nature" that
343 ;; so happens to be a function in SBCL, but which must not be
344 ;; bound to a function-name by way of (SETF FEDFINITION).
345 (defun err-if-unacceptable-function (object setter
)
346 (when (macro/special-guard-fun-p object
)
347 (error 'simple-reference-error
348 :references
'((:ansi-cl
:function fdefinition
))
349 :format-control
"~S is not acceptable to ~S."
350 :format-arguments
(list object setter
))))
352 (defun (setf fdefinition
) (new-value name
)
353 "Set NAME's global function definition."
354 (declare (type function new-value
) (optimize (safety 1)))
355 (declare (explicit-check))
356 (err-if-unacceptable-function new-value
'(setf fdefinition
))
357 (setq new-value
(strip-encapsulation new-value
))
358 (with-single-package-locked-error (:symbol name
"setting fdefinition of ~A")
359 (maybe-clobber-ftype name new-value
)
361 ;; Check for hash-table stuff. Woe onto him that mixes encapsulation
364 (let ((old (%symbol-function name
)))
365 (dolist (spec *user-hash-table-tests
*)
366 (cond ((eq old
(second spec
))
368 (setf (second spec
) new-value
))
369 ((eq old
(third spec
))
371 (setf (third spec
) new-value
))))))
373 (let ((fdefn (find-or-create-fdefn name
)))
374 (dolist (f *setf-fdefinition-hook
*)
375 (declare (type function f
))
376 (funcall f name new-value
))
377 (let ((encap-info (encapsulation-info (fdefn-fun fdefn
))))
382 (encapsulation-info-definition encap-info
))))
384 (setf encap-info more-info
)
385 (return (setf (encapsulation-info-definition encap-info
)
388 (setf (fdefn-fun fdefn
) new-value
)))))))
390 ;;;; FBOUNDP and FMAKUNBOUND
392 (defun fboundp (name)
393 "Return true if name has a global function definition."
394 (declare (explicit-check))
395 (awhen (find-fdefn name
) (fdefn-fun it
)))
397 (defun fmakunbound (name)
398 "Make NAME have no global function definition."
399 (declare (explicit-check))
400 (with-single-package-locked-error
401 (:symbol name
"removing the function or macro definition of ~A")
402 (let ((fdefn (find-fdefn name
)))
404 (undo-static-linkage fdefn
)
405 (fdefn-makunbound fdefn
)))
406 (undefine-fun-name name
)
409 ;;; A simple open-addressing hashset.
410 (define-load-time-global *fdefns
*
411 (cons (make-array 128 :initial-element
0) 0))
412 (define-load-time-global *fdefns-lock
* (sb-thread:make-mutex
:name
"fdefns"))
414 ;;; Fancily named fdefns are not attached to symbols, but instead in a custom
415 ;;; data structure which we probe in the manner of a quadratic probing hash-table.
416 ;;; A max load factor ensures that probing terminates.
417 ;;; https://fgiesen.wordpress.com/2015/02/22/triangular-numbers-mod-2n/
418 ;;; contains a proof that triangular numbers mod 2^N visit every cell.
420 ;;; The intent here - which may be impossible to realize - was to allow garbage-collection
421 ;;; of FDEFNs whose name is not reachable. I couldn't get it to do the right thing.
422 ;;; e.g. (defmethod foo (x (y cons)) ...) creates mappings:
423 ;;; (SB-PCL::FAST-METHOD FOO (T CONS)) -> #<SB-KERNEL:FDEFN (SB-PCL::FAST-METHOD FOO (T CONS))>
424 ;;; (SB-PCL::SLOW-METHOD FOO (T CONS)) -> #<SB-KERNEL:FDEFN (SB-PCL::SLOW-METHOD FOO (T CONS))>
425 ;;; where it seems like (unintern 'FOO) should allow both of those to get GCd.
426 ;;; I suspect that it will require hanging those fancily named fdefns off the symbol
427 ;;; FOO rather than having a global table. Alternatively, that can be simulated by
428 ;;; having GC preserve liveness of any element whenever the second item in the list
429 ;;; comprising fdefn-name is an a-priori live symbol. That will be more efficient than
430 ;;; having a hash-table hanging off every symbol that names a method.
431 ;;; e.g. both of the preceding names would be hanging off of FOO, as would others
432 ;;; such as (FAST-METHOD FOO :AROUND (LIST INTEGER)) and a myriad of others.
433 ;;; I suspect that any approach of hanging off the symbols will be space-inefficient
434 ;;; and difficult to implement.
436 ;;; At any rate, we can make use of the key-in-value nature of fdefns to halve
437 ;;; the number of words required to store the name -> object mapping.
438 (defun get-fancily-named-fdefn (name constructor
&aux
(hash (globaldb-sxhashoid name
)))
439 (declare (type (or function null
) constructor
))
440 (labels ((lookup (vector &aux
(mask (1- (length vector
)))
441 (index (logand hash mask
))
444 ;; Because rehash is forced well before the table becomes 100% full,
445 ;; it should not be possible to loop infinitely here.
446 (loop (let ((fdefn (svref vector index
)))
447 (cond ((eql fdefn
0) ; not found
448 (return-from lookup
(or empty-cell index
)))
449 #+nil
((eql fdefn nil
) ; smashed by GC
450 (unless empty-cell
(setq empty-cell index
)))
451 ((equal (fdefn-name fdefn
) name
)
452 (return-from lookup fdefn
))))
453 (setq index
(logand (+ index
(incf step
)) mask
))))
454 (insert (hash item vector mask
&aux
(index (logand hash mask
))
457 (loop (case (svref vector index
)
459 (return (setf (svref vector
(or empty-cell index
)) item
)))
460 #+nil
((nil) ; smashed by GC
461 (unless empty-cell
(setq empty-cell index
))))
462 (setq index
(logand (+ index
(incf step
)) mask
)))))
463 (or (let ((result (lookup (car *fdefns
*))))
464 (when (fdefn-p result
) result
))
465 (when constructor
; double-check w/lock before inserting
466 (with-system-mutex (*fdefns-lock
*)
467 (let* ((fdefns *fdefns
*)
468 (vector (car fdefns
))
469 (result (lookup vector
)))
472 (let ((new-fdefn (funcall constructor name
)))
473 (if (<= (incf (cdr fdefns
)) (ash (length vector
) -
1)) ; under 50% full
474 ;; It might even be less full than that due to GC.
475 (setf (svref vector result
) new-fdefn
)
476 ;; The actual count is unknown without re-counting.
477 (let* ((count (count-if #'fdefn-p vector
))
478 (new-size (power-of-two-ceiling
479 (ceiling (* count
2))))
480 (new-vect (make-array new-size
:initial-element
0))
481 (new-mask (1- new-size
)))
482 (dovector (item vector
)
484 (insert (globaldb-sxhashoid (fdefn-name item
)) item
486 (insert hash new-fdefn new-vect new-mask
)
487 (setf *fdefns
* (cons new-vect
(1+ count
)))))