primarily intending to integrate Colin Walter's O(N) map code and
[sbcl.git] / src / code / fdefinition.lisp
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.
5
6 ;;;; This software is part of the SBCL system. See the README file for
7 ;;;; more information.
8 ;;;;
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.
14
15 (in-package "SB!IMPL")
16
17 (file-comment
18   "$Header$")
19
20 (sb!int::/show0 "fdefinition.lisp 22")
21 \f
22 ;;;; fdefinition (fdefn) objects
23
24 (defun make-fdefn (name)
25   (make-fdefn name))
26
27 (defun fdefn-name (fdefn)
28   (declare (type fdefn fdefn))
29   (fdefn-name fdefn))
30
31 (defun fdefn-function (fdefn)
32   (declare (type fdefn fdefn)
33            (values (or function null)))
34   (fdefn-function fdefn))
35
36 (defun (setf fdefn-function) (fun fdefn)
37   (declare (type function fun)
38            (type fdefn fdefn)
39            (values function))
40   (setf (fdefn-function fdefn) fun))
41
42 (defun fdefn-makunbound (fdefn)
43   (declare (type fdefn fdefn))
44   (fdefn-makunbound fdefn))
45
46 ;;; This function is called by !COLD-INIT after the globaldb has been
47 ;;; initialized, but before anything else. We need to install these
48 ;;; fdefn objects into the globaldb before any top level forms run, or
49 ;;; we will end up with two different fdefn objects being used for the
50 ;;; same function name. *!INITIAL-FDEFN-OBJECTS* is set up by GENESIS.
51 (defvar *!initial-fdefn-objects*)
52 (defun !fdefn-cold-init ()
53   (dolist (fdefn *!initial-fdefn-objects*)
54     (setf (info :function :definition (fdefn-name fdefn)) fdefn)))
55
56 (defun fdefinition-object (name create)
57   #!+sb-doc
58   "Return the fdefn object for NAME. If it doesn't already exist and CREATE
59    is non-NIL, create a new (unbound) one."
60   (declare (values (or fdefn null)))
61   (unless (or (symbolp name)
62               (and (consp name)
63                    (eq (car name) 'setf)
64                    (let ((cdr (cdr name)))
65                      (and (consp cdr)
66                           (symbolp (car cdr))
67                           (null (cdr cdr))))))
68     (error 'simple-type-error
69            :datum name
70            :expected-type '(or symbol list)
71            :format-control "invalid function name: ~S"
72            :format-arguments (list name)))
73   (let ((fdefn (info :function :definition name)))
74     (if (and (null fdefn) create)
75         (setf (info :function :definition name) (make-fdefn name))
76         fdefn)))
77
78 ;;; FIXME: If the fundamental operation performed when
79 ;;; funcalling a symbol is %COERCE-NAME-TO-FUNCTION, which expands into
80 ;;; FDEFINITION-OBJECT, which does (INFO :FUNCTION :DEFINITION NAME),
81 ;;; that's a horrendously heavyweight way to implement SYMBOL-FUNCTION.
82 ;;; What compelling reason is there for all this hairiness? The only
83 ;;; thing I can think of is that it does give a place to store
84 ;;; SETF functions, but I don't think that's a good enough reason.
85 ;;; It might even be that the FDEFINITION arrangement saves a little
86 ;;; space, if the proportion of function-less symbols is high enough,
87 ;;; but I don't think that's a good enough reason, either.
88 ;;; I'd really like to wipe out FDEFN stuff root and branch, and
89 ;;; just store SETF functions in the symbol property list.
90 ;;;
91 ;;; One problem with just doing the simple thing: What happens when
92 ;;; people call symbols which have no function definitions?
93 ;;;   1. Just hit "undefined function" error -- with no clue as to
94 ;;;      what undefined function it was. (This might actually not be
95 ;;;      too horrible, since the compiler warns you about undefined
96 ;;;      functions and the debugger aims, with incomplete success,
97 ;;;      to show you what form caused an error.)
98 ;;;   2. various solutions involving closures in the function slot,
99 ;;;      all of which have the drawback of extra memory use and extra
100 ;;;      difficulty in detecting when functions are undefined
101 ;;;   2a. Have every single symbol have an undefined function closure
102 ;;;       which points back to it to tell you which undefined symbol it
103 ;;;       was. (4 extra words per undefined symbol)
104 ;;;   2b. Play tricks with FDEFINITION, where the default SYMBOL-FUNCTION
105 ;;;       for any function is an anonymous "undefined function" error
106 ;;;       which doesn't tell you what the problem was, but if FDEFINITION
107 ;;;       is ever called on an undefined symbol, it helpfully changes the
108 ;;;       function definition to point to a closure which knows which
109 ;;;       symbol caused the problem.
110 ;;;   4. Just don't sweat it except when DEBUG>SPEED, where the calling
111 ;;;      convention gets tweaked to test for the undefined-function
112 ;;;      function at call time and bail out with helpful information
113 ;;;      if it's there.
114 ;;;   5. Require that the function calling convention be stereotyped
115 ;;;      along the lines of
116 ;;;             mov %ebx, local_immediate_3         ; Point to symbol.
117 ;;;             mov %eax, symbol_function_offset(%eax) ; Point to function.
118 ;;;             call *function_code_pointer(%eax)      ; Go.
119 ;;;      That way, it's guaranteed that on entry to a function, %EBX points
120 ;;;      back to the symbol which was used to indirect into the function,
121 ;;;      so the undefined function handler can base its complaint on that.
122 ;;;
123 ;;; Another problem with doing the simple thing: people will want to
124 ;;; indirect through something in order to get to SETF functions, in
125 ;;; order to be able to redefine them. What will they indirect
126 ;;; through? This could be done with a hack, making an anonymous
127 ;;; symbol and linking it to the main symbol's SB!KERNEL:SETF-FUNCTION
128 ;;; property. The anonymous symbol could even point back to the symbol
129 ;;; it's the SETF function for, so that if the SETF function was
130 ;;; undefined at the time a call was made, the debugger could say
131 ;;; which function caused the problem. It'd probably be cleaner,
132 ;;; though, to use a new type of primitive object (SYMBOLOID?)
133 ;;; instead. It could probably be like symbol except that its name
134 ;;; could be any object and its value points back to the symbol which
135 ;;; owns it. Then the setf functions for FOO could be on the list (GET
136 ;;; FOO 'SB!KERNEL:SYMBOLOIDS)
137 ;;;
138 ;;; FIXME: Oh, my. Now that I've started thinking about it, I
139 ;;; appreciate more fully how weird and twisted FDEFNs might be. Look
140 ;;; at the calling sequence for full calls. It goes and reads the
141 ;;; address of a function object from its own table of immediate
142 ;;; values, then jumps into that. Consider how weird that is. Not only
143 ;;; is it not doing indirection through a symbol (which I'd already
144 ;;; realized) but it's not doing indirection through
145
146 ;;; The compiler emits calls to this when someone tries to funcall a symbol.
147 (defun %coerce-name-to-function (name)
148   #!+sb-doc
149   "Returns the definition for name, including any encapsulations. Settable
150    with SETF."
151   (let ((fdefn (fdefinition-object name nil)))
152     (or (and fdefn (fdefn-function fdefn))
153         (error 'undefined-function :name name))))
154
155 (defun %coerce-callable-to-function (callable)
156   (if (functionp callable)
157       callable
158       (%coerce-name-to-function callable)))
159
160 ;;; This is just another name for %COERCE-NAME-TO-FUNCTION.
161 #!-sb-fluid (declaim (inline raw-definition))
162 (defun raw-definition (name)
163   ;; We know that we are calling %COERCE-NAME-TO-FUNCTION, so don't remind us.
164   (declare (optimize (inhibit-warnings 3)))
165   (%coerce-name-to-function name))
166 (defun (setf raw-definition) (function name)
167   (let ((fdefn (fdefinition-object name t)))
168     (setf (fdefn-function fdefn) function)))
169
170 ;;; FIXME: There seems to be no good reason to have both
171 ;;; %COERCE-NAME-TO-FUNCTION and RAW-DEFINITION names for the same
172 ;;; thing. And despite what the doc string of %COERCE-NAME-TO-FUNCTION
173 ;;; says, it's doesn't look settable. Perhaps we could collapse
174 ;;; %COERCE-TO-FUNCTION, RAW-DEFINITION, and (SETF RAW-DEFINITION)
175 ;;; into RAW-FDEFINITION and (SETF RAW-FDEFINITION), or
176 ;;; OUTER-FDEFINITION and (SETF OUTER-FDEFINITION).
177 \f
178 ;;;; definition encapsulation
179
180 (defstruct (encapsulation-info (:constructor make-encapsulation-info
181                                              (type definition)))
182   ;; This is definition's encapsulation type. The encapsulated
183   ;; definition is in the previous encapsulation-info element or
184   ;; installed as the global definition of some function name.
185   type
186   ;; the previous, encapsulated definition. This used to be installed
187   ;; as a global definition for some function name, but it was
188   ;; replaced by an encapsulation of type TYPE.
189   (definition nil :type function))
190
191 ;;; We must bind and close over info. Consider the case where we
192 ;;; encapsulate (the second) an encapsulated (the first) definition,
193 ;;; and later someone unencapsulates the encapsulated (first)
194 ;;; definition. We don't want our encapsulation (second) to bind
195 ;;; basic-definition to the encapsulated (first) definition when it no
196 ;;; longer exists. When unencapsulating, we make sure to clobber the
197 ;;; appropriate info structure to allow basic-definition to be bound
198 ;;; to the next definition instead of an encapsulation that no longer
199 ;;; exists.
200 (defun encapsulate (name type body)
201   #!+sb-doc
202   "Replaces the definition of NAME with a function that binds name's arguments
203    a variable named argument-list, binds name's definition to a variable named
204    basic-definition, and evaluates BODY in that context. TYPE is
205    whatever you would like to associate with this encapsulation for
206    identification in case you need multiple encapsuations of the same name."
207   (let ((fdefn (fdefinition-object name nil)))
208     (unless (and fdefn (fdefn-function fdefn))
209       (error 'undefined-function :name name))
210     (let ((info (make-encapsulation-info type (fdefn-function fdefn))))
211       (setf (fdefn-function fdefn)
212             #'(lambda (&rest argument-list)
213                 (declare (special argument-list))
214                 (let ((basic-definition (encapsulation-info-definition info)))
215                   (declare (special basic-definition))
216                   (eval body)))))))
217
218 ;;; Finds the encapsulation info that has been closed over.
219 (defun encapsulation-info (fun)
220   (and (functionp fun)
221        (= (get-type fun) sb!vm:closure-header-type)
222        (find-if-in-closure #'encapsulation-info-p fun)))
223
224 ;;; When removing an encapsulation, we must remember that
225 ;;; encapsulating definitions close over a reference to the
226 ;;; encapsulation-info that describes the encapsulating definition.
227 ;;; When you find an info with the target type, the previous info in
228 ;;; the chain has the ensulating definition of that type. We take the
229 ;;; encapsulated definition from the info with the target type, and we
230 ;;; store it in the previous info structure whose encapsulating
231 ;;; definition it describes looks to this previous info structure for
232 ;;; a definition to bind (see ENCAPSULATE). When removing the first
233 ;;; info structure, we do something conceptually equal, but
234 ;;; mechanically it is different.
235 (defun unencapsulate (name type)
236   #!+sb-doc
237   "Removes NAME's most recent encapsulation of the specified TYPE."
238   (let* ((fdefn (fdefinition-object name nil))
239          (encap-info (encapsulation-info (fdefn-function fdefn))))
240     (declare (type (or encapsulation-info null) encap-info))
241     (cond ((not encap-info)
242            ;; It disappeared on us, so don't worry about it.
243            )
244           ((eq (encapsulation-info-type encap-info) type)
245            ;; It's the first one, so change the fdefn object.
246            (setf (fdefn-function fdefn)
247                  (encapsulation-info-definition encap-info)))
248           (t
249            ;; It must be an interior one, so find it.
250            (loop
251              (let ((next-info (encapsulation-info
252                                (encapsulation-info-definition encap-info))))
253                (unless next-info
254                  ;; Not there, so don't worry about it.
255                  (return))
256                (when (eq (encapsulation-info-type next-info) type)
257                  ;; This is it, so unlink us.
258                  (setf (encapsulation-info-definition encap-info)
259                        (encapsulation-info-definition next-info))
260                  (return))
261                (setf encap-info next-info))))))
262   t)
263
264 (defun encapsulated-p (name type)
265   #!+sb-doc
266   "Returns t if name has an encapsulation of the given type, otherwise nil."
267   (let ((fdefn (fdefinition-object name nil)))
268     (do ((encap-info (encapsulation-info (fdefn-function fdefn))
269                      (encapsulation-info
270                       (encapsulation-info-definition encap-info))))
271         ((null encap-info) nil)
272       (declare (type (or encapsulation-info null) encap-info))
273       (when (eq (encapsulation-info-type encap-info) type)
274         (return t)))))
275 \f
276 ;;;; FDEFINITION
277
278 ;;; KLUDGE: Er, it looks as though this means that
279 ;;;    (FUNCALL (FDEFINITION 'FOO))
280 ;;; doesn't do the same thing as
281 ;;;    (FUNCALL 'FOO).
282 ;;; That doesn't look like ANSI behavior to me. Look e.g. at the
283 ;;; ANSI definition of TRACE: "Whenever a traced function is invoked,
284 ;;; information about the call, ..". Try this:
285 ;;;   (DEFUN FOO () (PRINT "foo"))
286 ;;;   (TRACE FOO)
287 ;;;   (FUNCALL 'FOO)
288 ;;;   (FUNCALL (FDEFINITION 'FOO))
289 ;;; What to do? ANSI says TRACE "Might change the definitions of the functions
290 ;;; named by function-names." Might it be OK to just get punt all this
291 ;;; encapsulation stuff and go back to a simple but correct implementation of
292 ;;; TRACE? We'd lose the ability to redefine a TRACEd function and keep the
293 ;;; trace in place, but that seems tolerable to me. (Is the wrapper stuff
294 ;;; needed for anything else besides TRACE?)
295 ;;;
296 ;;; The only problem I can see with not having a wrapper: If tracing
297 ;;; EQ, EQL, EQUAL, or EQUALP causes its function address to change,
298 ;;; it will mess up the MAKE-HASH-TABLE logic which uses EQ tests
299 ;;; on those function values. -- WHN 19990906
300 (defun fdefinition (name)
301   #!+sb-doc
302   "Return name's global function definition taking care to respect any
303    encapsulations and to return the innermost encapsulated definition.
304    This is SETF'able."
305   (let ((fun (raw-definition name)))
306     (loop
307       (let ((encap-info (encapsulation-info fun)))
308         (if encap-info
309             (setf fun (encapsulation-info-definition encap-info))
310             (return fun))))))
311
312 (defvar *setf-fdefinition-hook* nil
313   #!+sb-doc
314   "This holds functions that (SETF FDEFINITION) invokes before storing the
315    new value. These functions take the function name and the new value.")
316
317 (defun %set-fdefinition (name new-value)
318   #!+sb-doc
319   "Set NAME's global function definition."
320   (declare (type function new-value) (optimize (safety 1)))
321   (let ((fdefn (fdefinition-object name t)))
322     ;; *SETF-FDEFINITION-HOOK* won't be bound when initially running top-level
323     ;; forms in the kernel core startup.
324     (when (boundp '*setf-fdefinition-hook*)
325       (dolist (f *setf-fdefinition-hook*)
326         (funcall f name new-value)))
327
328     (let ((encap-info (encapsulation-info (fdefn-function fdefn))))
329       (cond (encap-info
330              (loop
331                (let ((more-info
332                       (encapsulation-info
333                        (encapsulation-info-definition encap-info))))
334                  (if more-info
335                      (setf encap-info more-info)
336                      (return
337                       (setf (encapsulation-info-definition encap-info)
338                             new-value))))))
339             (t
340              (setf (fdefn-function fdefn) new-value))))))
341 \f
342 ;;;; FBOUNDP and FMAKUNBOUND
343
344 (defun fboundp (name)
345   #!+sb-doc
346   "Return true if name has a global function definition."
347   (let ((fdefn (fdefinition-object name nil)))
348     (and fdefn (fdefn-function fdefn) t)))
349
350 (defun fmakunbound (name)
351   #!+sb-doc
352   "Make Name have no global function definition."
353   (let ((fdefn (fdefinition-object name nil)))
354     (when fdefn
355       (fdefn-makunbound fdefn)))
356   name)