(list components (length components) :named nil)))
(defmethod inspected-parts ((object function))
- (let* ((type (sb-kernel:widetag-of object))
- (object (if (= type sb-vm:closure-header-widetag)
- (sb-kernel:%closure-fun object)
- object))
- (components (list (cons "arglist"
- (sb-kernel:%simple-fun-arglist object)))))
+ (let ((components (list (cons "arglist" (sb-kernel:%fun-lambda-list object)))))
(list components (length components) :named nil)))
(defmethod inspected-parts ((object vector))
;; from the table if available.
(let* ((simple-fun (get-simple-fun value))
(xrefs (when simple-fun
- (sb-vm::%simple-fun-xrefs simple-fun)))
+ (sb-kernel:%simple-fun-xrefs simple-fun)))
(array (when xrefs
(aref xrefs kind-index))))
;; Loop through the name/path xref entries in the table
"%CHECK-BOUND"
"%CHECK-GENERIC-SEQUENCE-BOUNDS"
"%CHECK-VECTOR-SEQUENCE-BOUNDS"
- "%CLOSURE-FUN" "%CLOSURE-INDEX-REF"
"%COMPARE-AND-SWAP-CAR"
"%COMPARE-AND-SWAP-CDR"
"%COMPARE-AND-SWAP-INSTANCE-REF"
"%FIND-POSITION-VECTOR-MACRO" "%FIND-POSITION-IF"
"%FIND-POSITION-IF-VECTOR-MACRO" "%FIND-POSITION-IF-NOT"
"%FIND-POSITION-IF-NOT-VECTOR-MACRO"
- "%FUN-DOC"
- "%FUN-FUN"
- "%FUN-NAME"
"%HYPOT" "%LDB" "%LOG" "%LOGB" "%LOG10"
"%LAST0"
"%LAST1"
"UB64-BASH-COPY" "SYSTEM-AREA-UB64-COPY"
"COPY-UB64-TO-SYSTEM-AREA" "COPY-UB64-FROM-SYSTEM-AREA"
+ ;; SIMPLE-FUN type and accessors
+ "SIMPLE-FUN"
+ "SIMPLE-FUN-P"
+ "%SIMPLE-FUN-ARGLIST"
+ "%SIMPLE-FUN-NAME"
+ "%SIMPLE-FUN-NEXT"
+ "%SIMPLE-FUN-SELF"
+ "%SIMPLE-FUN-TYPE"
+ "%SIMPLE-FUN-XREFS"
+
+ ;; CLOSURE type and accessors
+ "CLOSURE"
+ "CLOSUREP"
+ "DO-CLOSURE-VALUES"
+ "%CLOSURE-FUN"
+ "%CLOSURE-INDEX-REF"
+ "%CLOSURE-VALUES"
+
+ ;; Abstract function accessors
+ "%FUN-DOC"
+ "%FUN-FUN"
+ "%FUN-LAMBDA-LIST"
+ "%FUN-NAME"
+
"FDEFN" "MAKE-FDEFN" "FDEFN-P" "FDEFN-NAME" "FDEFN-FUN"
"FDEFN-MAKUNBOUND" "OUTER-FDEFN"
"%COERCE-CALLABLE-TO-FUN" "FUN-SUBTYPE"
"DD-RAW-LENGTH" "NOTE-NAME-DEFINED" "%CODE-CODE-SIZE"
"DD-SLOTS" "DD-INCLUDE" "SLOT-SETTER-LAMBDA-FORM"
"%IMAGPART" "DSD-ACCESSOR-NAME" "%CODE-DEBUG-INFO"
- "LAYOUT-CLASSOID" "LAYOUT-INVALID" "%SIMPLE-FUN-NAME"
+ "LAYOUT-CLASSOID" "LAYOUT-INVALID"
"DSD-TYPE" "%INSTANCEP" "DEFSTRUCT-SLOT-DESCRIPTION"
- "%SIMPLE-FUN-ARGLIST" "%SIMPLE-FUN-NEXT"
"DD-PREDICATE-NAME"
"CLASSOID-PROPER-NAME" "%NOTE-TYPE-DEFINED" "LAYOUT-INFO"
"%SET-INSTANCE-LAYOUT" "DD-DEFAULT-CONSTRUCTOR"
- "LAYOUT-OF" "%SIMPLE-FUN-SELF" "%REALPART"
+ "LAYOUT-OF" "%REALPART"
"STRUCTURE-CLASSOID-P" "DSD-INDEX" "STRUCTURE-CLASSOID"
- "%INSTANCE-LAYOUT" "LAYOUT-CLOS-HASH" "%SIMPLE-FUN-TYPE"
+ "%INSTANCE-LAYOUT" "LAYOUT-CLOS-HASH"
"PROCLAIM-AS-FUN-NAME" "BECOME-DEFINED-FUN-NAME"
"%NUMERATOR" "CLASSOID-TYPEP" "DSD-READ-ONLY"
"DSD-DEFAULT" "LAYOUT-INHERITS" "DD-LENGTH"
- "%CODE-ENTRY-POINTS" "%DENOMINATOR" "%SIMPLE-FUN-XREFS"
+ "%CODE-ENTRY-POINTS" "%DENOMINATOR"
"%OTHER-POINTER-P"
"STANDARD-CLASSOID" "CLASSOID-OF"
:export ("INTERPRETED-FUNCTION"
"INTERPRETED-FUNCTION-P"
"INTERPRETED-FUNCTION-NAME"
+ "INTERPRETED-FUNCTION-DEBUG-NAME"
"INTERPRETED-FUNCTION-LAMBDA-LIST"
+ "INTERPRETED-FUNCTION-DEBUG-LAMBDA-LIST"
"INTERPRETED-FUNCTION-DOCUMENTATION"
"INTERPRETED-FUNCTION-BODY"
"INTERPRETED-FUNCTION-SOURCE-LOCATION"
;;; Return a DEBUG-FUN that represents debug information for FUN.
(defun fun-debug-fun (fun)
(declare (type function fun))
- (ecase (widetag-of fun)
- (#.sb!vm:closure-header-widetag
- (fun-debug-fun (%closure-fun fun)))
- (#.sb!vm:funcallable-instance-header-widetag
- (fun-debug-fun (funcallable-instance-fun fun)))
- (#.sb!vm:simple-fun-header-widetag
- (let* ((name (%simple-fun-name fun))
- (component (fun-code-header fun))
- (res (find-if
- (lambda (x)
- (and (sb!c::compiled-debug-fun-p x)
- (eq (sb!c::compiled-debug-fun-name x) name)
- (eq (sb!c::compiled-debug-fun-kind x) nil)))
- (sb!c::compiled-debug-info-fun-map
- (%code-debug-info component)))))
- (if res
- (make-compiled-debug-fun res component)
- ;; KLUDGE: comment from CMU CL:
- ;; This used to be the non-interpreted branch, but
- ;; William wrote it to return the debug-fun of fun's XEP
- ;; instead of fun's debug-fun. The above code does this
- ;; more correctly, but it doesn't get or eliminate all
- ;; appropriate cases. It mostly works, and probably
- ;; works for all named functions anyway.
- ;; -- WHN 20000120
- (debug-fun-from-pc component
- (* (- (fun-word-offset fun)
- (get-header-data component))
- sb!vm:n-word-bytes)))))))
+ (let ((simple-fun (%fun-fun fun)))
+ (let* ((name (%simple-fun-name simple-fun))
+ (component (fun-code-header simple-fun))
+ (res (find-if
+ (lambda (x)
+ (and (sb!c::compiled-debug-fun-p x)
+ (eq (sb!c::compiled-debug-fun-name x) name)
+ (eq (sb!c::compiled-debug-fun-kind x) nil)))
+ (sb!c::compiled-debug-info-fun-map
+ (%code-debug-info component)))))
+ (if res
+ (make-compiled-debug-fun res component)
+ ;; KLUDGE: comment from CMU CL:
+ ;; This used to be the non-interpreted branch, but
+ ;; William wrote it to return the debug-fun of fun's XEP
+ ;; instead of fun's debug-fun. The above code does this
+ ;; more correctly, but it doesn't get or eliminate all
+ ;; appropriate cases. It mostly works, and probably
+ ;; works for all named functions anyway.
+ ;; -- WHN 20000120
+ (debug-fun-from-pc component
+ (* (- (fun-word-offset simple-fun)
+ (get-header-data component))
+ sb!vm:n-word-bytes))))))
;;; Return the kind of the function, which is one of :OPTIONAL,
;;; :EXTERNAL, :TOPLEVEL, :CLEANUP, or NIL.
(sb!c::note-name-defined name :function)
- ;; FIXME: I want to do this here (and fix bug 137), but until the
- ;; breathtaking CMU CL function name architecture is converted into
- ;; something sane, (1) doing so doesn't really fix the bug, and
- ;; (2) doing probably isn't even really safe.
- #+nil (setf (%fun-name def) name)
-
(when doc
(setf (fdocumentation name 'function) doc)
#!+sb-eval
(setf (sb!xc:macro-function name) definition
(fdocumentation name 'function) doc)
,(when set-p
- `(case (widetag-of definition)
- (#.sb!vm:closure-header-widetag
- (setf (%simple-fun-arglist (%closure-fun definition))
- lambda-list
- (%simple-fun-name (%closure-fun definition))
- debug-name))
- (#.sb!vm:simple-fun-header-widetag
- (setf (%simple-fun-arglist definition) lambda-list
- (%simple-fun-name definition) debug-name))))
+ `(setf (%fun-lambda-list definition) lambda-list
+ (%fun-name definition) debug-name))
name))))
(progn
(def (:load-toplevel :execute) #-sb-xc-host t #+sb-xc-host nil)
(format s "~@:_~@<Its associated name (as in ~S) is ~2I~_~S.~:>"
'function-lambda-expression
(nth-value 2 (function-lambda-expression x)))
- (case (widetag-of x)
- (#.sb-vm:closure-header-widetag
+ (typecase x
+ (closure
(%describe-fun-compiled (%closure-fun x) s kind name)
(format s "~&Its closure environment is:")
- (loop for value in (%closure-values x)
- for i = 0 then (1+ i)
- do (format s "~& ~S: ~S" i value)))
- (#.sb-vm:simple-fun-header-widetag
+ (let ((i -1))
+ (do-closure-values (value x)
+ (format s "~& ~S: ~S" (incf i) value))))
+ (simple-fun
(%describe-fun-compiled x s kind name))
- (#.sb-vm:funcallable-instance-header-widetag
+ (funcallable-instance
;; Only STANDARD-GENERIC-FUNCTION would be handled here, but
;; since it has its own DESCRIBE-OBJECT method, it should've been
;; picked off before getting here. So hopefully we never get here.
'function-lambda-expression
(nth-value 2 (function-lambda-expression x)))
(format s "~&It is an interpreted function.~%")
- (let ((args (sb-eval:interpreted-function-lambda-list x)))
- (cond ((not args)
- (write-string "There are no arguments." s))
- (t
- (format s "~&~@(The ~@[~A's ~]arguments are:~@:_~)" kind)
- (write-string " " s)
- (let ((*print-pretty* t)
- (*print-escape* t)
- (*print-base* 10)
- (*print-radix* nil))
- (pprint-logical-block (s nil)
- (pprint-indent :current 2)
- (format s "~A" args)))))
- (format s "~&It was defined as: ")
+ (let ((args (sb-eval:interpreted-function-debug-lambda-list x)))
+ (format s "Its lambda-list is: ")
+ (let ((*print-pretty* t)
+ (*print-escape* t)
+ (*print-base* 10)
+ (*print-radix* nil))
+ (pprint-logical-block (s nil)
+ (pprint-indent :current 2)
+ (format s "~A" args)))
+ (format s "~&It was defined as:~% ")
(let ((*print-pretty* t)
(*print-escape* t)
(*print-base* 10)
(*print-radix* nil))
(pprint-logical-block (s nil)
(pprint-indent :current 2)
- (format s "~A" (function-lambda-expression x))))))
+ (format s "~S" (function-lambda-expression x))))))
(terpri s))
(defmethod describe-object ((x function) s)
;; compiler/main and code/deftypes-for-target.
(sb!kernel::!defstruct-with-alternate-metaclass
interpreted-function
- :slot-names (name lambda-list env declarations documentation body source-location)
+ ;; DEBUG-NAME and DEBUG-LAMBDA-LIST are initially a copies of the proper
+ ;; ones, but is analogous to SIMPLE-FUN-NAME and ARGLIST in the sense that it
+ ;; is they are there only for debugging, and do not affect behaviour of the
+ ;; function -- so DEFMACRO can set them to more informative values.
+ :slot-names (name debug-name lambda-list debug-lambda-list env
+ declarations documentation body source-location)
:boa-constructor %make-interpreted-function
:superclass-name function
:metaclass-name static-classoid
(defun make-interpreted-function
(&key name lambda-list env declarations documentation body source-location)
(let ((function (%make-interpreted-function
- name lambda-list env declarations documentation body
- source-location)))
+ name name lambda-list lambda-list env
+ declarations documentation body source-location)))
(setf (sb!kernel:funcallable-instance-fun function)
#'(lambda (&rest args)
(interpreted-apply function args)))
;;; This is like FIND-IF, except that we do it on a compiled closure's
;;; environment.
-(defun find-if-in-closure (test fun)
- (declare (type function test))
- (dotimes (index (1- (get-closure-length fun)))
- (let ((elt (%closure-index-ref fun index)))
- (when (funcall test elt)
- (return elt)))))
+(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)
- (= (widetag-of fun) sb!vm:closure-header-widetag)
- (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
(defun set-header-data (x val)
(set-header-data x val))
-;;; the length of the closure X, i.e. one more than the
-;;; number of variables closed over
+;;; Return the 24 bits of data in the header of object X, which must
+;;; be a fun-pointer object.
+;;;
+;;; FIXME: Should this not be called GET-FUN-LENGTH instead? Or even better
+;;; yet, if GET-HEADER-DATA masked the lowtag instead of substracting it, we
+;;; could just use it instead -- or at least this could just be a function on
+;;; top of the same VOP.
(defun get-closure-length (x)
(get-closure-length x))
(defun (setf fun-subtype) (type function)
(setf (fun-subtype function) type))
+;;;; SIMPLE-FUN and accessors
+
+(declaim (inline simple-fun-p))
+(defun simple-fun-p (object)
+ (= sb!vm:simple-fun-header-widetag (widetag-of object)))
+
+(deftype simple-fun ()
+ '(satisfies simple-fun-p))
+
;;; Extract the arglist from the function header FUNC.
(defun %simple-fun-arglist (func)
(%simple-fun-arglist func))
(defun %simple-fun-self (simple-fun)
(%simple-fun-self simple-fun))
+;;;; CLOSURE type and accessors
+
+(declaim (inline closurep))
+(defun closurep (object)
+ (= sb!vm:closure-header-widetag (widetag-of object)))
+
+(deftype closure ()
+ '(satisfies closurep))
+
+(defmacro do-closure-values ((value closure) &body body)
+ (with-unique-names (i nclosure)
+ `(let ((,nclosure ,closure))
+ (declare (closure ,nclosure))
+ (dotimes (,i (- (1+ (get-closure-length ,nclosure)) sb!vm:closure-info-offset))
+ (let ((,value (%closure-index-ref ,nclosure ,i)))
+ ,@body)))))
+
+(defun %closure-values (closure)
+ (declare (closure closure))
+ (let (values)
+ (do-closure-values (elt closure)
+ (push elt closure))
+ (nreverse values)))
+
;;; Extract the function from CLOSURE.
(defun %closure-fun (closure)
(%closure-fun closure))
+;;; Extract the INDEXth slot from CLOSURE.
+(defun %closure-index-ref (closure index)
+ (%closure-index-ref closure index))
+
;;; Return the length of VECTOR. There is no reason to use this in
;;; ordinary code, 'cause length (the vector foo)) is the same.
(defun sb!c::vector-length (vector)
(sb!c::vector-length vector))
-;;; Extract the INDEXth slot from CLOSURE.
-(defun %closure-index-ref (closure index)
- (%closure-index-ref closure index))
-
;;; Allocate a unboxed, simple vector with type code TYPE, length LENGTH, and
;;; WORDS words long. Note: it is your responsibility to ensure that the
;;; relation between LENGTH and WORDS is correct.
(setf (sb!xc:compiler-macro-function name) definition)
(setf (fdocumentation name 'compiler-macro) doc)
,(when set-p
- `(case (widetag-of definition)
- (#.sb!vm:closure-header-widetag
- (setf (%simple-fun-arglist (%closure-fun definition))
- lambda-list
- (%simple-fun-name (%closure-fun definition))
- debug-name))
- (#.sb!vm:simple-fun-header-widetag
- (setf (%simple-fun-arglist definition) lambda-list
- (%simple-fun-name definition) debug-name))))
+ `(setf (%fun-lambda-list definition) lambda-list
+ (%fun-name definition) debug-name))
name))))
(progn
(def (:load-toplevel :execute) #-sb-xc-host t #+sb-xc-host nil)
(values (fdefinition x) t))))
(function x)
(t (values (fdefinition x) t)))
- (case (sb-kernel:widetag-of res)
- (#.sb-vm:closure-header-widetag
+ (typecase res
+ (closure
(values (sb-kernel:%closure-fun res)
named-p
:compiled-closure))
- (#.sb-vm:funcallable-instance-header-widetag
+ (funcallable-instance
(values res named-p :funcallable-instance))
- (t (values res named-p :compiled)))))
+ ;; FIXME: What about SB!EVAL:INTERPRETED-FUNCTION -- it gets picked off
+ ;; by the FIN above, is that right?
+ (t
+ (values res named-p :compiled)))))
;;; When a function name is redefined, and we were tracing that name,
;;; then untrace the old definition and trace the new one.
(defun %make-funcallable-instance (len)
(%make-funcallable-instance len))
-(defun funcallable-instance-p (x) (funcallable-instance-p x))
+(defun funcallable-instance-p (x)
+ (funcallable-instance-p x))
+
+(deftype funcallable-instance ()
+ `(satisfies funcallable-instance-p))
(defun %funcallable-instance-info (fin i)
(%funcallable-instance-info fin i))
(values nil t name))))
(values nil t name))))))
-(defun closurep (object)
- (= sb!vm:closure-header-widetag (widetag-of object)))
+;;;; Generalizing over SIMPLE-FUN, CLOSURE, and FUNCALLABLE-INSTANCEs
+;;; Underlying SIMPLE-FUN
(defun %fun-fun (function)
(declare (function function))
- (case (widetag-of function)
- (#.sb!vm:simple-fun-header-widetag
+ (typecase function
+ (simple-fun
function)
- (#.sb!vm:closure-header-widetag
+ (closure
(%closure-fun function))
- (#.sb!vm:funcallable-instance-header-widetag
+ (funcallable-instance
(%fun-fun (funcallable-instance-fun function)))))
-(defun %closure-values (object)
- (declare (function object))
- (loop for index from 0
- below (- (get-closure-length object) (1- sb!vm:closure-info-offset))
- collect (%closure-index-ref object index)))
+(defun %fun-lambda-list (function)
+ (typecase function
+ #!+sb-eval
+ (sb!eval:interpreted-function
+ (sb!eval:interpreted-function-debug-lambda-list function))
+ (t
+ (%simple-fun-arglist (%fun-fun function)))))
-(defun %fun-lambda-list (object)
- (%simple-fun-arglist (%fun-fun object)))
+(defun (setf %fun-lambda-list) (new-value function)
+ (typecase function
+ #!+sb-eval
+ (sb!eval:interpreted-function
+ (setf (sb!eval:interpreted-function-debug-lambda-list function) new-value))
+ ;; FIXME: Eliding general funcallable-instances for now.
+ ((or simple-fun closure)
+ (setf (%simple-fun-arglist (%fun-fun function)) new-value)))
+ new-value)
+
+(defun %fun-type (function)
+ (%simple-fun-type (%fun-fun function)))
;;; a SETFable function to return the associated debug name for FUN
;;; (i.e., the third value returned from CL:FUNCTION-LAMBDA-EXPRESSION),
;;; or NIL if there's none
(defun %fun-name (function)
- (%simple-fun-name (%fun-fun function)))
-
-(defun %fun-type (function)
- (%simple-fun-type (%fun-fun function)))
+ (typecase function
+ #!+sb-eval
+ (sb!eval:interpreted-function
+ (sb!eval:interpreted-function-debug-name function))
+ (t
+ (%simple-fun-name (%fun-fun function)))))
-(defun (setf %fun-name) (new-name fun)
- (aver nil) ; since this is unsafe 'til bug 137 is fixed
- (let ((widetag (widetag-of fun)))
- (case widetag
- (#.sb!vm:simple-fun-header-widetag
- ;; KLUDGE: The pun that %SIMPLE-FUN-NAME is used for closure
- ;; functions is left over from CMU CL (modulo various renaming
- ;; that's gone on since the fork).
- (setf (%simple-fun-name fun) new-name))
- (#.sb!vm:closure-header-widetag
- ;; FIXME: It'd be nice to be able to set %FUN-NAME here on
- ;; per-closure basis. Instead, we are still using the CMU CL
- ;; approach of closures being named after their closure
- ;; function, which doesn't work right e.g. for structure
- ;; accessors, and might not be quite right for DEFUN
- ;; in a non-null lexical environment either.
- ;; When/if weak hash tables become supported
- ;; again, it'll become easy to fix this, but for now there
- ;; seems to be no easy way (short of the ugly way of adding a
- ;; slot to every single closure header), so we don't.
- ;;
- ;; Meanwhile, users might encounter this problem by doing DEFUN
- ;; in a non-null lexical environment, so we try to give a
- ;; reasonably meaningful user-level "error" message (but only
- ;; as a warning because this is optional debugging
- ;; functionality anyway, not some hard ANSI requirement).
- (warn "can't set name for closure, leaving name unchanged"))
- (t
- ;; The other function subtype names are also un-settable
- ;; but this problem seems less likely to be tickled by
- ;; user-level code, so we can give a implementor-level
- ;; "error" (warning) message.
- (warn "can't set function name ((~S function)=~S), leaving it unchanged"
- 'widetag-of widetag))))
- new-name)
+(defun (setf %fun-name) (new-value function)
+ (typecase function
+ #!+sb-eval
+ (sb!eval:interpreted-function
+ (setf (sb!eval:interpreted-function-debug-name function) new-value))
+ ;; FIXME: Eliding general funcallable-instances for now.
+ ((or simple-fun closure)
+ (setf (%simple-fun-name (%fun-fun function)) new-value)))
+ new-value)
(defun %fun-doc (x)
;; FIXME: This business of going through %FUN-NAME and then globaldb
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.29.21"
+"1.0.29.23"
projects / sbcl.git / commitdiff