Fix bug reported by Cyrus Harmon (sbcl-devel 2005-08-30)
... %FUN-FUN should call itself recursively when given a
FUNCALLABLE-INSTANCE
... while I'm at it, fix some bugs / inconsistencies in the
general area:
* make slot 0 of FUNCALLABLE-INSTANCEs hold the layout,
like other instances;
* remove the dedicated LAYOUT slot from the objdef for
FUNCALLABLE-INSTANCE;
* make the clos-slots of PCL-FUNCALLABLE-INSTANCE slot
1, as it always should have been.
(The fundamental problem of associating names with functions is
not yet fixed, but at least we no longer get something silly
like #<FUNCTION #<FUNCTION #<FUNCTION ...>>>)
Faré Rideau)
* bug fix: GET-INTERNAL-REAL-TIME now works even for processes that
have been running for over 50 days. (reported by Gilbert Baumann)
Faré Rideau)
* bug fix: GET-INTERNAL-REAL-TIME now works even for processes that
have been running for over 50 days. (reported by Gilbert Baumann)
+ * bug fix: the logic for getting names of functions gets less
+ confused when confronded with alternate-metaclass
+ funcallable-instances. (reported by Cyrus Harmon)
* threads
** bug fix: parent thread now can be gc'ed even with a live
child thread
* threads
** bug fix: parent thread now can be gc'ed even with a live
child thread
"BUILT-IN-CLASSOID-TRANSLATION" "RANDOM-LAYOUT-CLOS-HASH"
"CLASSOID-PCL-CLASS" "FUNCALLABLE-STRUCTURE"
"FUNCALLABLE-INSTANCE-FUN" "%FUNCALLABLE-INSTANCE-LAYOUT"
"BUILT-IN-CLASSOID-TRANSLATION" "RANDOM-LAYOUT-CLOS-HASH"
"CLASSOID-PCL-CLASS" "FUNCALLABLE-STRUCTURE"
"FUNCALLABLE-INSTANCE-FUN" "%FUNCALLABLE-INSTANCE-LAYOUT"
+ "%SET-FUNCALLABLE-INSTANCE-LAYOUT"
"BASIC-STRUCTURE-CLASSOID" "CLASSOID-CELL-CLASSOID"
"FUNCALLABLE-STRUCTURE-CLASSOID-P" "REGISTER-LAYOUT"
"FUNCALLABLE-INSTANCE" "RANDOM-FIXNUM-MAX"
"BASIC-STRUCTURE-CLASSOID" "CLASSOID-CELL-CLASSOID"
"FUNCALLABLE-STRUCTURE-CLASSOID-P" "REGISTER-LAYOUT"
"FUNCALLABLE-INSTANCE" "RANDOM-FIXNUM-MAX"
(defsetf %instance-layout %set-instance-layout)
(defsetf %funcallable-instance-info %set-funcallable-instance-info)
(defsetf %instance-layout %set-instance-layout)
(defsetf %funcallable-instance-info %set-funcallable-instance-info)
+(defsetf %funcallable-instance-layout %set-funcallable-instance-layout)
;;; from early-setf.lisp
(in-package "SB!IMPL")
;;; from early-setf.lisp
(in-package "SB!IMPL")
(let* ((dd (make-defstruct-description class-name))
(conc-name (concatenate 'string (symbol-name class-name) "-"))
(dd-slots (let ((reversed-result nil)
(let* ((dd (make-defstruct-description class-name))
(conc-name (concatenate 'string (symbol-name class-name) "-"))
(dd-slots (let ((reversed-result nil)
- ;; The index starts at 1 for ordinary
- ;; named slots because slot 0 is
- ;; magical, used for LAYOUT in
- ;; CONDITIONs or for something (?) in
- ;; funcallable instances.
+ ;; The index starts at 1 for ordinary named
+ ;; slots because slot 0 is magical, used for
+ ;; the LAYOUT in CONDITIONs and
+ ;; FUNCALLABLE-INSTANCEs. (This is the same
+ ;; in ordinary structures too: see (INCF
+ ;; DD-LENGTH) in
+ ;; PARSE-DEFSTRUCT-NAME-AND-OPTIONS).
(index 1))
(dolist (slot-name slot-names)
(push (make-defstruct-slot-description
(index 1))
(dolist (slot-name slot-names)
(push (make-defstruct-slot-description
,object-gensym)
'%instance-ref))
(funcallable-structure
,object-gensym)
'%instance-ref))
(funcallable-structure
- (values `(%make-funcallable-instance ,dd-length
- ,delayed-layout-form)
+ (values `(let ((,object-gensym
+ (%make-funcallable-instance ,dd-length)))
+ (setf (%funcallable-instance-layout ,object-gensym)
+ ,delayed-layout-form)
+ ,object-gensym)
'%funcallable-instance-info)))
`(progn
'%funcallable-instance-info)))
`(progn
(defun %set-instance-layout (instance new-value)
(%set-instance-layout instance new-value))
(defun %set-instance-layout (instance new-value)
(%set-instance-layout instance new-value))
-(defun %make-funcallable-instance (len layout)
- (%make-funcallable-instance len layout))
+(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))
(defun funcallable-instance-fun (fin)
(%funcallable-instance-lexenv fin))
(defun funcallable-instance-fun (fin)
(%funcallable-instance-lexenv fin))
-;;; The heart of the magic of funcallable instances ("FINs"). The
-;;; function for a FIN must be a magical INSTANCE-LAMBDA form. When
+;;; The heart of the magic of funcallable instances ("FINs"). When
;;; called (as with any other function), we grab the code pointer, and
;;; call it, leaving the original function object in LEXENV (in case
;;; called (as with any other function), we grab the code pointer, and
;;; call it, leaving the original function object in LEXENV (in case
-;;; it was a closure). If it is actually a FIN, then we need to do an
+;;; it was a closure). If it is actually a FIN, then we need to do an
;;; extra indirection with funcallable-instance-lexenv to get at any
;;; extra indirection with funcallable-instance-lexenv to get at any
-;;; closure environment. This extra indirection is set up when
+;;; closure environment. This extra indirection is set up when
;;; accessing the closure environment of an INSTANCE-LAMBDA. Note that
;;; the original FIN pointer is lost, so if the called function wants
;;; to get at the original object to do some slot accesses, it must
;;; accessing the closure environment of an INSTANCE-LAMBDA. Note that
;;; the original FIN pointer is lost, so if the called function wants
;;; to get at the original object to do some slot accesses, it must
;;;
;;; If we set the FIN function to be a FIN, we directly copy across
;;; both the code pointer and the lexenv, since that code pointer (for
;;;
;;; If we set the FIN function to be a FIN, we directly copy across
;;; both the code pointer and the lexenv, since that code pointer (for
-;;; an instance-lambda) is expecting that lexenv to be accessed. This
+;;; an instance-lambda) is expecting that lexenv to be accessed. This
;;; effectively pre-flattens what would otherwise be a chain of
;;; effectively pre-flattens what would otherwise be a chain of
-;;; indirections. (That used to happen when PCL dispatch functions
+;;; indirections. (That used to happen when PCL dispatch functions
;;; were byte-compiled; now that the byte compiler is gone, I can't
;;; think of another example offhand. -- WHN 2001-10-06)
;;;
;;; The only loss is that if someone accesses the
;;; were byte-compiled; now that the byte compiler is gone, I can't
;;; think of another example offhand. -- WHN 2001-10-06)
;;;
;;; The only loss is that if someone accesses the
-;;; FUNCALLABLE-INSTANCE-FUN, then won't get a FIN back. This probably
-;;; doesn't matter, since PCL only sets the FIN function.
+;;; FUNCALLABLE-INSTANCE-FUN, then won't get a FIN back. This
+;;; probably doesn't matter, since PCL only sets the FIN function.
(defun (setf funcallable-instance-fun) (new-value fin)
(setf (%funcallable-instance-fun fin)
(%closure-fun new-value))
(defun (setf funcallable-instance-fun) (new-value fin)
(setf (%funcallable-instance-fun fin)
(%closure-fun new-value))
(#.sb!vm:closure-header-widetag
(%closure-fun function))
(#.sb!vm:funcallable-instance-header-widetag
(#.sb!vm:closure-header-widetag
(%closure-fun function))
(#.sb!vm:funcallable-instance-header-widetag
- (funcallable-instance-fun function))))
+ (%fun-fun (funcallable-instance-fun function)))))
(defun %closure-values (object)
(declare (function object))
(defun %closure-values (object)
(declare (function object))
)
(lexenv :ref-known (flushable) :ref-trans %funcallable-instance-lexenv
:set-known (unsafe) :set-trans (setf %funcallable-instance-lexenv))
)
(lexenv :ref-known (flushable) :ref-trans %funcallable-instance-lexenv
:set-known (unsafe) :set-trans (setf %funcallable-instance-lexenv))
- (layout :init :arg
- :ref-known (flushable) :ref-trans %funcallable-instance-layout
- :set-known (unsafe) :set-trans (setf %funcallable-instance-layout))
(info :rest-p t))
(define-primitive-object (value-cell :lowtag other-pointer-lowtag
(info :rest-p t))
(define-primitive-object (value-cell :lowtag other-pointer-lowtag
(defknown %closure-index-ref (function index) t
(flushable))
(defknown %closure-index-ref (function index) t
(flushable))
-(defknown %make-funcallable-instance (index layout) function
+(defknown %make-funcallable-instance (index) function
(unsafe))
(defknown %funcallable-instance-info (function index) t (flushable))
(unsafe))
(defknown %funcallable-instance-info (function index) t (flushable))
`(truly-the layout (%instance-ref ,x 0)))
(define-source-transform %set-instance-layout (x val)
`(%instance-set ,x 0 (the layout ,val)))
`(truly-the layout (%instance-ref ,x 0)))
(define-source-transform %set-instance-layout (x val)
`(%instance-set ,x 0 (the layout ,val)))
+(define-source-transform %funcallable-instance-layout (x)
+ `(truly-the layout (%funcallable-instance-info ,x 0)))
+(define-source-transform %set-funcallable-instance-layout (x val)
+ `(setf (%funcallable-instance-info ,x 0) (the layout ,val)))
\f
;;;; character support
\f
;;;; character support
(declare (type function new-value))
(aver (funcallable-instance-p fin))
(setf (funcallable-instance-fun fin) new-value))
(declare (type function new-value))
(aver (funcallable-instance-p fin))
(setf (funcallable-instance-fun fin) new-value))
+;;; FIXME: these macros should just go away. It's not clear whether
+;;; the inline functions defined by
+;;; !DEFSTRUCT-WITH-ALTERNATE-METACLASS are as efficient as they could
+;;; be; ordinary defstruct accessors are defined as source transforms.
(defmacro fsc-instance-p (fin)
`(funcallable-instance-p ,fin))
(defmacro fsc-instance-wrapper (fin)
`(%funcallable-instance-layout ,fin))
(defmacro fsc-instance-p (fin)
`(funcallable-instance-p ,fin))
(defmacro fsc-instance-wrapper (fin)
`(%funcallable-instance-layout ,fin))
-;;; FIXME: This seems to bear no relation at all to the CLOS-SLOTS
-;;; slot in the FUNCALLABLE-INSTANCE structure, above, which
-;;; (bizarrely) seems to be set to the NAME of the
-;;; FUNCALLABLE-INSTANCE. At least, the index 1 seems to return the
-;;; NAME, and the index 2 NIL. Weird. -- CSR, 2002-11-07
(defmacro fsc-instance-slots (fin)
(defmacro fsc-instance-slots (fin)
- `(%funcallable-instance-info ,fin 0))
+ `(%funcallable-instance-info ,fin 1))
(defmacro fsc-instance-hash (fin)
`(%funcallable-instance-info ,fin 3))
\f
(defmacro fsc-instance-hash (fin)
`(%funcallable-instance-info ,fin 3))
\f
(if (if (eq *boot-state* 'complete)
(typep fun 'generic-function)
(eq (class-of fun) *the-class-standard-generic-function*))
(if (if (eq *boot-state* 'complete)
(typep fun 'generic-function)
(eq (class-of fun) *the-class-standard-generic-function*))
- (setf (%funcallable-instance-info fun 1) new-name)
+ (setf (%funcallable-instance-info fun 2) new-name)
(bug "unanticipated function type")))
;; Fixup name-to-function mappings in cases where the function
;; hasn't been defined by DEFUN. (FIXME: is this right? This logic
(bug "unanticipated function type")))
;; Fixup name-to-function mappings in cases where the function
;; hasn't been defined by DEFUN. (FIXME: is this right? This logic
;;; 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".)
;;; 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".)