X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffdefinition.lisp;h=a23c0e4886c31617482cc14f363e528f103733a1;hb=82cd148d729c241e79c8df04b700beec1b7c55de;hp=5be99307059ac0e6dee9b1a8074c8bd239fdd399;hpb=467a8e5dba8bfa2598ca8e22c1204dc173ce556f;p=sbcl.git diff --git a/src/code/fdefinition.lisp b/src/code/fdefinition.lisp index 5be9930..a23c0e4 100644 --- a/src/code/fdefinition.lisp +++ b/src/code/fdefinition.lisp @@ -25,16 +25,16 @@ (declare (type fdefn fdefn)) (fdefn-name fdefn)) -(defun fdefn-function (fdefn) +(defun fdefn-fun (fdefn) (declare (type fdefn fdefn) - (values (or function null))) - (fdefn-function fdefn)) + (values (or function null))) + (fdefn-fun fdefn)) -(defun (setf fdefn-function) (fun fdefn) +(defun (setf fdefn-fun) (fun fdefn) (declare (type function fun) - (type fdefn fdefn) - (values function)) - (setf (fdefn-function fdefn) fun)) + (type fdefn fdefn) + (values function)) + (setf (fdefn-fun fdefn) fun)) (defun fdefn-makunbound (fdefn) (declare (type fdefn fdefn)) @@ -50,129 +50,45 @@ (dolist (fdefn *!initial-fdefn-objects*) (setf (info :function :definition (fdefn-name fdefn)) fdefn))) +;;; Return the fdefn object for NAME. If it doesn't already exist and +;;; CREATE is non-NIL, create a new (unbound) one. (defun fdefinition-object (name create) - #!+sb-doc - "Return the fdefn object for NAME. If it doesn't already exist and CREATE - is non-NIL, create a new (unbound) one." (declare (values (or fdefn null))) - (unless (legal-function-name-p name) - (error 'simple-type-error - :datum name - :expected-type '(or symbol list) - :format-control "invalid function name: ~S" - :format-arguments (list name))) + (legal-fun-name-or-type-error name) (let ((fdefn (info :function :definition name))) (if (and (null fdefn) create) - (setf (info :function :definition name) (make-fdefn name)) - fdefn))) + (setf (info :function :definition name) (make-fdefn name)) + fdefn))) -;;; FIXME: If the fundamental operation performed when -;;; funcalling a symbol is %COERCE-NAME-TO-FUNCTION, which expands into -;;; FDEFINITION-OBJECT, which does (INFO :FUNCTION :DEFINITION NAME), -;;; that's a horrendously heavyweight way to implement SYMBOL-FUNCTION. -;;; What compelling reason is there for all this hairiness? The only -;;; thing I can think of is that it does give a place to store -;;; SETF functions, but I don't think that's a good enough reason. -;;; It might even be that the FDEFINITION arrangement saves a little -;;; space, if the proportion of function-less symbols is high enough, -;;; but I don't think that's a good enough reason, either. -;;; I'd really like to wipe out FDEFN stuff root and branch, and -;;; just store SETF functions in the symbol property list. -;;; -;;; One problem with just doing the simple thing: What happens when -;;; people call symbols which have no function definitions? -;;; 1. Just hit "undefined function" error -- with no clue as to -;;; what undefined function it was. (This might actually not be -;;; too horrible, since the compiler warns you about undefined -;;; functions and the debugger aims, with incomplete success, -;;; to show you what form caused an error.) -;;; 2. various solutions involving closures in the function slot, -;;; all of which have the drawback of extra memory use and extra -;;; difficulty in detecting when functions are undefined -;;; 2a. Have every single symbol have an undefined function closure -;;; which points back to it to tell you which undefined symbol it -;;; was. (4 extra words per undefined symbol) -;;; 2b. Play tricks with FDEFINITION, where the default SYMBOL-FUNCTION -;;; for any function is an anonymous "undefined function" error -;;; which doesn't tell you what the problem was, but if FDEFINITION -;;; is ever called on an undefined symbol, it helpfully changes the -;;; function definition to point to a closure which knows which -;;; symbol caused the problem. -;;; 4. Just don't sweat it except when DEBUG>SPEED, where the calling -;;; convention gets tweaked to test for the undefined-function -;;; function at call time and bail out with helpful information -;;; if it's there. -;;; 5. Require that the function calling convention be stereotyped -;;; along the lines of -;;; mov %ebx, local_immediate_3 ; Point to symbol. -;;; mov %eax, symbol_function_offset(%eax) ; Point to function. -;;; call *function_code_pointer(%eax) ; Go. -;;; That way, it's guaranteed that on entry to a function, %EBX points -;;; back to the symbol which was used to indirect into the function, -;;; so the undefined function handler can base its complaint on that. -;;; -;;; Another problem with doing the simple thing: people will want to -;;; indirect through something in order to get to SETF functions, in -;;; order to be able to redefine them. What will they indirect -;;; through? This could be done with a hack, making an anonymous -;;; symbol and linking it to the main symbol's SB!KERNEL:SETF-FUNCTION -;;; property. The anonymous symbol could even point back to the symbol -;;; it's the SETF function for, so that if the SETF function was -;;; undefined at the time a call was made, the debugger could say -;;; which function caused the problem. It'd probably be cleaner, -;;; though, to use a new type of primitive object (SYMBOLOID?) -;;; instead. It could probably be like symbol except that its name -;;; could be any object and its value points back to the symbol which -;;; owns it. Then the setf functions for FOO could be on the list (GET -;;; FOO 'SB!KERNEL:SYMBOLOIDS) -;;; -;;; FIXME: Oh, my. Now that I've started thinking about it, I -;;; appreciate more fully how weird and twisted FDEFNs might be. Look -;;; at the calling sequence for full calls. It goes and reads the -;;; address of a function object from its own table of immediate -;;; values, then jumps into that. Consider how weird that is. Not only -;;; is it not doing indirection through a symbol (which I'd already -;;; realized) but it's not doing indirection through +(defun maybe-clobber-ftype (name) + (unless (eq :declared (info :function :where-from name)) + (clear-info :function :type name))) -;;; The compiler emits calls to this when someone tries to funcall a symbol. -(defun %coerce-name-to-function (name) - #!+sb-doc - "Returns the definition for name, including any encapsulations. Settable - with SETF." +;;; Return the fdefinition of NAME, including any encapsulations. +;;; The compiler emits calls to this when someone tries to FUNCALL +;;; something. SETFable. +#!-sb-fluid (declaim (inline %coerce-name-to-fun)) +(defun %coerce-name-to-fun (name) (let ((fdefn (fdefinition-object name nil))) - (or (and fdefn (fdefn-function fdefn)) - (error 'undefined-function :name name)))) + (or (and fdefn (fdefn-fun fdefn)) + (error 'undefined-function :name name)))) +(defun (setf %coerce-name-to-fun) (function name) + (maybe-clobber-ftype name) + (let ((fdefn (fdefinition-object name t))) + (setf (fdefn-fun fdefn) function))) -(defun %coerce-callable-to-function (callable) +(defun %coerce-callable-to-fun (callable) (if (functionp callable) callable - (%coerce-name-to-function callable))) - -;;; This is just another name for %COERCE-NAME-TO-FUNCTION. -#!-sb-fluid (declaim (inline raw-definition)) -(defun raw-definition (name) - ;; We know that we are calling %COERCE-NAME-TO-FUNCTION, so don't remind us. - (declare (optimize (inhibit-warnings 3))) - (%coerce-name-to-function name)) -(defun (setf raw-definition) (function name) - (let ((fdefn (fdefinition-object name t))) - (setf (fdefn-function fdefn) function))) - -;;; FIXME: There seems to be no good reason to have both -;;; %COERCE-NAME-TO-FUNCTION and RAW-DEFINITION names for the same -;;; thing. And despite what the doc string of %COERCE-NAME-TO-FUNCTION -;;; says, it's doesn't look settable. Perhaps we could collapse -;;; %COERCE-TO-FUNCTION, RAW-DEFINITION, and (SETF RAW-DEFINITION) -;;; into RAW-FDEFINITION and (SETF RAW-FDEFINITION), or -;;; OUTER-FDEFINITION and (SETF OUTER-FDEFINITION). + (%coerce-name-to-fun callable))) ;;;; definition encapsulation (defstruct (encapsulation-info (:constructor make-encapsulation-info - (type definition)) - (:copier nil)) + (type definition)) + (:copier nil)) ;; This is definition's encapsulation type. The encapsulated - ;; definition is in the previous encapsulation-info element or + ;; definition is in the previous ENCAPSULATION-INFO element or ;; installed as the global definition of some function name. type ;; the previous, encapsulated definition. This used to be installed @@ -180,42 +96,49 @@ ;; replaced by an encapsulation of type TYPE. (definition nil :type function)) -;;; We must bind and close over info. Consider the case where we -;;; encapsulate (the second) an encapsulated (the first) definition, -;;; and later someone unencapsulates the encapsulated (first) -;;; definition. We don't want our encapsulation (second) to bind -;;; basic-definition to the encapsulated (first) definition when it no -;;; longer exists. When unencapsulating, we make sure to clobber the -;;; appropriate info structure to allow basic-definition to be bound -;;; to the next definition instead of an encapsulation that no longer -;;; exists. +;;; Replace the definition of NAME with a function that binds NAME's +;;; arguments to a variable named ARG-LIST, binds name's definition +;;; to a variable named BASIC-DEFINITION, and evaluates BODY in that +;;; context. TYPE is whatever you would like to associate with this +;;; encapsulation for identification in case you need multiple +;;; encapsulations of the same name. (defun encapsulate (name type body) - #!+sb-doc - "Replaces the definition of NAME with a function that binds name's arguments - a variable named argument-list, binds name's definition to a variable named - basic-definition, and evaluates BODY in that context. TYPE is - whatever you would like to associate with this encapsulation for - identification in case you need multiple encapsuations of the same name." (let ((fdefn (fdefinition-object name nil))) - (unless (and fdefn (fdefn-function fdefn)) + (unless (and fdefn (fdefn-fun fdefn)) (error 'undefined-function :name name)) - (let ((info (make-encapsulation-info type (fdefn-function fdefn)))) - (setf (fdefn-function fdefn) - #'(lambda (&rest argument-list) - (declare (special argument-list)) - (let ((basic-definition (encapsulation-info-definition info))) - (declare (special basic-definition)) - (eval body))))))) + ;; We must bind and close over INFO. Consider the case where we + ;; encapsulate (the second) an encapsulated (the first) + ;; definition, and later someone unencapsulates the encapsulated + ;; (first) definition. We don't want our encapsulation (second) to + ;; bind basic-definition to the encapsulated (first) definition + ;; when it no longer exists. When unencapsulating, we make sure to + ;; clobber the appropriate INFO structure to allow + ;; basic-definition to be bound to the next definition instead of + ;; an encapsulation that no longer exists. + (let ((info (make-encapsulation-info type (fdefn-fun fdefn)))) + (setf (fdefn-fun fdefn) + (named-lambda encapsulation (&rest arg-list) + (declare (special arg-list)) + (let ((basic-definition (encapsulation-info-definition info))) + (declare (special basic-definition)) + (eval body))))))) -;;; Finds the encapsulation info that has been closed over. +;;; This is like FIND-IF, except that we do it on a compiled closure's +;;; environment. +(defun find-if-in-closure (test closure) + (declare (closure closure)) + (do-closure-values (value closure) + (when (funcall test value) + (return value)))) + +;;; Find the encapsulation info that has been closed over. (defun encapsulation-info (fun) - (and (functionp fun) - (= (get-type fun) sb!vm:closure-header-type) - (find-if-in-closure #'encapsulation-info-p fun))) + (when (closurep fun) + (find-if-in-closure #'encapsulation-info-p fun))) ;;; When removing an encapsulation, we must remember that ;;; encapsulating definitions close over a reference to the -;;; encapsulation-info that describes the encapsulating definition. +;;; ENCAPSULATION-INFO that describes the encapsulating definition. ;;; When you find an info with the target type, the previous info in ;;; the chain has the ensulating definition of that type. We take the ;;; encapsulated definition from the info with the target type, and we @@ -228,108 +151,132 @@ #!+sb-doc "Removes NAME's most recent encapsulation of the specified TYPE." (let* ((fdefn (fdefinition-object name nil)) - (encap-info (encapsulation-info (fdefn-function fdefn)))) + (encap-info (encapsulation-info (fdefn-fun fdefn)))) (declare (type (or encapsulation-info null) encap-info)) (cond ((not encap-info) - ;; It disappeared on us, so don't worry about it. - ) - ((eq (encapsulation-info-type encap-info) type) - ;; It's the first one, so change the fdefn object. - (setf (fdefn-function fdefn) - (encapsulation-info-definition encap-info))) - (t - ;; It must be an interior one, so find it. - (loop - (let ((next-info (encapsulation-info - (encapsulation-info-definition encap-info)))) - (unless next-info - ;; Not there, so don't worry about it. - (return)) - (when (eq (encapsulation-info-type next-info) type) - ;; This is it, so unlink us. - (setf (encapsulation-info-definition encap-info) - (encapsulation-info-definition next-info)) - (return)) - (setf encap-info next-info)))))) + ;; It disappeared on us, so don't worry about it. + ) + ((eq (encapsulation-info-type encap-info) type) + ;; It's the first one, so change the fdefn object. + (setf (fdefn-fun fdefn) + (encapsulation-info-definition encap-info))) + (t + ;; It must be an interior one, so find it. + (loop + (let ((next-info (encapsulation-info + (encapsulation-info-definition encap-info)))) + (unless next-info + ;; Not there, so don't worry about it. + (return)) + (when (eq (encapsulation-info-type next-info) type) + ;; This is it, so unlink us. + (setf (encapsulation-info-definition encap-info) + (encapsulation-info-definition next-info)) + (return)) + (setf encap-info next-info)))))) t) +;;; Does NAME have an encapsulation of the given TYPE? (defun encapsulated-p (name type) - #!+sb-doc - "Returns t if name has an encapsulation of the given type, otherwise nil." (let ((fdefn (fdefinition-object name nil))) - (do ((encap-info (encapsulation-info (fdefn-function fdefn)) - (encapsulation-info - (encapsulation-info-definition encap-info)))) - ((null encap-info) nil) + (do ((encap-info (encapsulation-info (fdefn-fun fdefn)) + (encapsulation-info + (encapsulation-info-definition encap-info)))) + ((null encap-info) nil) (declare (type (or encapsulation-info null) encap-info)) (when (eq (encapsulation-info-type encap-info) type) - (return t))))) + (return t))))) ;;;; FDEFINITION ;;; KLUDGE: Er, it looks as though this means that ;;; (FUNCALL (FDEFINITION 'FOO)) ;;; doesn't do the same thing as -;;; (FUNCALL 'FOO). -;;; That doesn't look like ANSI behavior to me. Look e.g. at the -;;; ANSI definition of TRACE: "Whenever a traced function is invoked, -;;; information about the call, ..". Try this: +;;; (FUNCALL 'FOO), +;;; and (SYMBOL-FUNCTION 'FOO) isn't in general the same thing +;;; as (FDEFINITION 'FOO). That doesn't look like ANSI behavior to me. +;;; Look e.g. at the ANSI definition of TRACE: "Whenever a traced +;;; function is invoked, information about the call, ..". Try this: ;;; (DEFUN FOO () (PRINT "foo")) ;;; (TRACE FOO) ;;; (FUNCALL 'FOO) ;;; (FUNCALL (FDEFINITION 'FOO)) -;;; What to do? ANSI says TRACE "Might change the definitions of the functions -;;; named by function-names." Might it be OK to just get punt all this -;;; encapsulation stuff and go back to a simple but correct implementation of -;;; TRACE? We'd lose the ability to redefine a TRACEd function and keep the -;;; trace in place, but that seems tolerable to me. (Is the wrapper stuff -;;; needed for anything else besides TRACE?) +;;; What to do? ANSI says TRACE "Might change the definitions of the +;;; functions named by function-names." Might it be OK to just get +;;; punt all this encapsulation stuff and go back to a simple but +;;; correct implementation of TRACE? We'd lose the ability to redefine +;;; a TRACEd function and keep the trace in place, but that seems +;;; tolerable to me. (Is the wrapper stuff needed for anything else +;;; besides TRACE?) ;;; ;;; The only problem I can see with not having a wrapper: If tracing ;;; EQ, EQL, EQUAL, or EQUALP causes its function address to change, ;;; it will mess up the MAKE-HASH-TABLE logic which uses EQ tests -;;; on those function values. -- WHN 19990906 +;;; on those function values. But given the ANSI statement about +;;; TRACE causing things to change, that doesn't seem too unreasonable; +;;; and we might even be able to forbid tracing these functions. +;;; -- WHN 2001-11-02 (defun fdefinition (name) #!+sb-doc "Return name's global function definition taking care to respect any encapsulations and to return the innermost encapsulated definition. This is SETF'able." - (let ((fun (raw-definition name))) + (let ((fun (%coerce-name-to-fun name))) (loop - (let ((encap-info (encapsulation-info fun))) - (if encap-info - (setf fun (encapsulation-info-definition encap-info)) - (return fun)))))) + (let ((encap-info (encapsulation-info fun))) + (if encap-info + (setf fun (encapsulation-info-definition encap-info)) + (return fun)))))) (defvar *setf-fdefinition-hook* nil #!+sb-doc - "This holds functions that (SETF FDEFINITION) invokes before storing the - new value. These functions take the function name and the new value.") + "A list of functions that (SETF FDEFINITION) invokes before storing the + new value. The functions take the function name and the new value.") (defun %set-fdefinition (name new-value) #!+sb-doc "Set NAME's global function definition." (declare (type function new-value) (optimize (safety 1))) - (let ((fdefn (fdefinition-object name t))) - ;; *SETF-FDEFINITION-HOOK* won't be bound when initially running top-level - ;; forms in the kernel core startup. - (when (boundp '*setf-fdefinition-hook*) - (dolist (f *setf-fdefinition-hook*) - (funcall f name new-value))) + (with-single-package-locked-error (:symbol name "setting fdefinition of ~A") + (maybe-clobber-ftype name) + + ;; Check for hash-table stuff. Woe onto him that mixes encapsulation + ;; with this. + (when (and (symbolp name) (fboundp name) + (boundp '*user-hash-table-tests*)) + (let ((old (symbol-function name))) + (declare (special *user-hash-table-tests*)) + (dolist (spec *user-hash-table-tests*) + (cond ((eq old (second spec)) + ;; test-function + (setf (second spec) new-value)) + ((eq old (third spec)) + ;; hash-function + (setf (third spec) new-value)))))) - (let ((encap-info (encapsulation-info (fdefn-function fdefn)))) - (cond (encap-info - (loop - (let ((more-info - (encapsulation-info - (encapsulation-info-definition encap-info)))) - (if more-info - (setf encap-info more-info) - (return - (setf (encapsulation-info-definition encap-info) - new-value)))))) - (t - (setf (fdefn-function fdefn) new-value)))))) + ;; FIXME: This is a good hook to have, but we should probably + ;; reserve it for users. + (let ((fdefn (fdefinition-object name t))) + ;; *SETF-FDEFINITION-HOOK* won't be bound when initially running + ;; top level forms in the kernel core startup. + (when (boundp '*setf-fdefinition-hook*) + (dolist (f *setf-fdefinition-hook*) + (declare (type function f)) + (funcall f name new-value))) + + (let ((encap-info (encapsulation-info (fdefn-fun fdefn)))) + (cond (encap-info + (loop + (let ((more-info + (encapsulation-info + (encapsulation-info-definition encap-info)))) + (if more-info + (setf encap-info more-info) + (return + (setf (encapsulation-info-definition encap-info) + new-value)))))) + (t + (setf (fdefn-fun fdefn) new-value))))))) ;;;; FBOUNDP and FMAKUNBOUND @@ -337,12 +284,15 @@ #!+sb-doc "Return true if name has a global function definition." (let ((fdefn (fdefinition-object name nil))) - (and fdefn (fdefn-function fdefn) t))) + (and fdefn (fdefn-fun fdefn) t))) (defun fmakunbound (name) #!+sb-doc - "Make Name have no global function definition." - (let ((fdefn (fdefinition-object name nil))) - (when fdefn - (fdefn-makunbound fdefn))) - name) + "Make NAME have no global function definition." + (with-single-package-locked-error + (:symbol name "removing the function or macro definition of ~A") + (let ((fdefn (fdefinition-object name nil))) + (when fdefn + (fdefn-makunbound fdefn))) + (sb!kernel:undefine-fun-name name) + name))