returns T (reported by Anton Kazennikov)
* bug fix: the STORE-VALUE restart of CHECK-TYPE works correctly
with non-variable places
+ * bug fix: remove a race condition in the setting of
+ funcallable-instance functions, this should make threaded CLOS
+ code more stable against memory faults.
* improvement: the debugger will now also display local variables that
are only used once, for code compiled with a DEBUG optimization quality
of 2 or higher.
"DEF-SETTER"
"FIXED-ALLOC"
"MAKE-UNBOUND-MARKER"
+ "MAKE-FUNCALLABLE-INSTANCE-TRAMP"
"RETURN-SINGLE"
"NOTE-NEXT-INSTRUCTION"
"SET-SLOT"
"BLOCK-NUMBER"
"BACKEND"
"IR2-BLOCK-BLOCK"
- "FUNCALLABLE-INSTANCE-LEXENV"
"VOP-BLOCK"
"*ASSEMBLY-OPTIMIZE*"
"LARGE-ALLOC"
"%RAW-INSTANCE-SET/COMPLEX-SINGLE"
"%RAW-INSTANCE-REF/COMPLEX-DOUBLE"
"%RAW-INSTANCE-SET/COMPLEX-DOUBLE"
- "%SET-ARRAY-DIMENSION" "%SET-FUNCALLABLE-INSTANCE-FUN"
- "%SET-FUNCALLABLE-INSTANCE-INFO"
+ "%SET-ARRAY-DIMENSION" "%SET-FUNCALLABLE-INSTANCE-INFO"
"%SET-RAW-BITS" "%SET-VECTOR-RAW-BITS"
"%SET-SAP-REF-16" "%SET-SAP-REF-32" "%SET-SAP-REF-64"
"%SET-SAP-REF-WORD" "%SET-SAP-REF-8" "%SET-SAP-REF-DOUBLE"
"REGISTER-LAYOUT"
"FUNCALLABLE-INSTANCE" "RANDOM-FIXNUM-MAX"
"MAKE-STATIC-CLASSOID" "INSTANCE-LAMBDA"
- "%FUNCALLABLE-INSTANCE-LEXENV" "%MAKE-SYMBOL"
- "%FUNCALLABLE-INSTANCE-FUN" "SYMBOL-HASH"
+ "%MAKE-SYMBOL"
+ "%FUNCALLABLE-INSTANCE-FUNCTION" "SYMBOL-HASH"
"BUILT-IN-CLASSOID" "CONDITION-CLASSOID-P"
"CONDITION-CLASSOID-SLOTS" "MAKE-UNDEFINED-CLASSOID"
"FORWARDING-POINTER-TYPE"
"FP-CONSTANT-SC-NUMBER"
"FP-DOUBLE-ZERO-SC-NUMBER" "FP-SINGLE-ZERO-SC-NUMBER"
- "FUNCALLABLE-INSTANCE-FUN-SLOT"
+ "FUNCALLABLE-INSTANCE-TRAMPOLINE-SLOT"
"FUNCALLABLE-INSTANCE-HEADER-WIDETAG"
"FUNCALLABLE-INSTANCE-INFO-OFFSET"
"SIMPLE-FUN-ARGLIST-SLOT" "SIMPLE-FUN-CODE-OFFSET"
"FUN-POINTER-LOWTAG"
"SIMPLE-FUN-SELF-SLOT"
"SIMPLE-FUN-TYPE-SLOT"
- "FUNCALLABLE-INSTANCE-LAYOUT-SLOT"
- "FUNCALLABLE-INSTANCE-LEXENV-SLOT"
"GENCGC-PAGE-SIZE"
#!+ppc "PSEUDO-ATOMIC-INTERRUPTED-FLAG"
#!+ppc "PSEUDO-ATOMIC-FLAG"
(macrolet ((def (name &optional (args '(x)))
`(defun ,name ,args (,name ,@args))))
+ (def %caller-frame-and-pc ())
(def %code-code-size)
(def %code-debug-info)
(def %code-entry-points)
- (def %funcallable-instance-fun)
(def %funcallable-instance-layout)
- (def %funcallable-instance-lexenv)
- (def %set-funcallable-instance-fun (fin new-val)))
-
-(defun %caller-frame-and-pc ()
- (%caller-frame-and-pc))
+ (def %set-funcallable-instance-layout (x new-value)))
(%set-funcallable-instance-info fin i new-value))
(defun funcallable-instance-fun (fin)
- (%funcallable-instance-lexenv fin))
-
-;;; 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
-;;; 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
-;;; 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
-;;; close over the FIN object.
-;;;
-;;; 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
-;;; effectively pre-flattens what would otherwise be a chain of
-;;; 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
-;;; FUNCALLABLE-INSTANCE-FUN, then won't get a FIN back. This
-;;; probably doesn't matter, since PCL only sets the FIN function.
+ (%funcallable-instance-function fin))
+
(defun (setf funcallable-instance-fun) (new-value fin)
- (setf (%funcallable-instance-fun fin)
- (%closure-fun new-value))
- (setf (%funcallable-instance-lexenv fin)
- (if (funcallable-instance-p new-value)
- (%funcallable-instance-lexenv new-value)
- new-value)))
+ (setf (%funcallable-instance-function fin) new-value))
;;; service function for structure constructors
(defun %make-instance-with-layout (layout)
"Return the class of the supplied object, which may be any Lisp object, not
just a CLOS STANDARD-OBJECT."
(layout-classoid (layout-of object)))
-
-;;; Pull the type specifier out of a function object.
-(defun extract-fun-type (fun)
- (specifier-type (%simple-fun-type (%closure-fun fun))))
\f
;;;; miscellaneous interfaces
(function
(if (funcallable-instance-p x)
(classoid-of x)
- (extract-fun-type x)))
+ (specifier-type (sb!impl::%fun-type x))))
(symbol
(make-member-type :members (list x)))
(number
(t
(inst bis alloc-tn fun-pointer-lowtag result)))
(storew temp result 0 fun-pointer-lowtag))
- (storew result result closure-self-slot fun-pointer-lowtag)
(storew function result closure-fun-slot fun-pointer-lowtag))))
;;; The compiler likes to be able to directly make value cells.
(:generator 1
(inst li unbound-marker-widetag result)))
+(define-vop (make-funcallable-instance-tramp)
+ (:args)
+ (:results (result :scs (any-reg)))
+ (:generator 1
+ (inst li (make-fixup "funcallable_instance_tramp" :foreign) result)))
+
(define-vop (fixed-alloc)
(:args)
(:info name words type lowtag)
funcallable-instance-info-offset fun-pointer-lowtag
(descriptor-reg any-reg) * %funcallable-instance-info)
-(define-vop (funcallable-instance-lexenv cell-ref)
- (:variant funcallable-instance-lexenv-slot fun-pointer-lowtag))
-
(define-vop (closure-ref slot-ref)
(:variant closure-info-offset fun-pointer-lowtag))
(define-primitive-object (closure :lowtag fun-pointer-lowtag
:widetag closure-header-widetag)
(fun :init :arg :ref-trans %closure-fun)
- ;; This SELF slot needs explanation.
- ;;
- ;; Ordinary closures did not need this slot before version 0.9.3.xx,
- ;; as the closure object was already in some dedicated register --
- ;; EAX/RAX on x86(-64), reg_LEXENV on register-rich platforms -- and
- ;; consequently setting up the environment (from the INFO slot,
- ;; below) was easy.
- ;;
- ;; However, it is not easy to support calling FUNCALLABLE-INSTANCEs
- ;; in the same way; in a FUNCALLABLE-INSTANCE, there are
- ;; conceptually two variable-length data areas: the closure
- ;; environment, if any, and the slots of the instance.
- ;;
- ;; Until sbcl-0.9.3.xx, it was required that closures to be set as a
- ;; FUNCALLABLE-INSTANCE-FUNCTION be defined using the magical
- ;; keyword SB-KERNEL:INSTANCE-LAMBDA, rather than ordinary LAMBDA;
- ;; this caused an extra indirection to be compiled into the closure
- ;; code to load the closure from the FUNCALLABLE-INSTANCE-LEXENV
- ;; slot before setting up the environment for the function body.
- ;; Failure to obey this protocol yielded confusing error messages as
- ;; either INSTANCE-LAMBDAs tried to dereference environments that
- ;; weren't there, or ordinary LAMBDAs got hold of the LAYOUT and
- ;; LEXENV slots of a FUNCALLABLE-INSTANCE.
- ;;
- ;; By adding this SELF slot, which is at the same offset in a
- ;; regular CLOSURE as the LEXENV slot is in a FUNCALLABLE-INSTANCE,
- ;; we enable the extra indirection (VOP FUNCALLABLE-INSTANCE-LEXENV,
- ;; in src/compiler/ir2tran.lisp) to be compiled unconditionally
- ;; (provided that we set this slot to the closure object itself).
- ;; Relative to the code before, this adds a word to the space
- ;; requirements of a closure, and one instruction (a memory fetch)
- ;; to the body of a closure function.
- ;;
- ;; There are potentially other implementation strategies which would
- ;; remove the need for this extra indirection in regular closures,
- ;; such as setting up a trampoline for funcallable instances (though
- ;; it was not clear to me that there are enough registers free in
- ;; the x86 backend to permit this). This indirection should not be
- ;; too disastrous, given that for regular closures the fetch is from
- ;; memory which is known to be active.
- ;;
- ;; CSR, 2005-08-05
- (self) ; KLUDGE (see above comment)
(info :rest-p t))
(define-primitive-object (funcallable-instance
:lowtag fun-pointer-lowtag
:widetag funcallable-instance-header-widetag
:alloc-trans %make-funcallable-instance)
- #!-(or x86 x86-64)
- (fun
- :ref-known (flushable) :ref-trans %funcallable-instance-fun
- :set-known (unsafe) :set-trans (setf %funcallable-instance-fun))
- #!+(or x86 x86-64)
- (fun
- :ref-known (flushable) :ref-trans %funcallable-instance-fun
- ;; KLUDGE: There's no :SET-KNOWN or :SET-TRANS in this case.
- ;; Instead, later in compiler/x86/system.lisp there's a separate
- ;; DEFKNOWN for (SETF %FUNCALLABLE-INSTANCE-FUN), and a weird
- ;; unexplained DEFTRANSFORM from (SETF %SIMPLE-FUN-INSTANCE-FUN)
- ;; into (SETF %SIMPLE-FUN-SELF). The #!+X86 wrapped around this case
- ;; is a literal translation of the old CMU CL implementation into
- ;; the new world of sbcl-0.6.12.63, where multiple DEFKNOWNs for
- ;; the same operator cause an error (instead of silently deleting
- ;; all information associated with the old DEFKNOWN, as before).
- ;; It's definitely not very clean, with too many #!+ conditionals and
- ;; too little documentation, but I have more urgent things to
- ;; clean up right now, so I've just left it as a literal
- ;; translation without trying to fix it. -- WHN 2001-08-02
- )
- (lexenv :ref-known (flushable) :ref-trans %funcallable-instance-lexenv
- :set-known (unsafe) :set-trans (setf %funcallable-instance-lexenv))
+ (trampoline :init :funcallable-instance-tramp)
+ (function :ref-known (flushable) :ref-trans %funcallable-instance-function
+ :set-known (unsafe) :set-trans (setf %funcallable-instance-function))
(info :rest-p t))
(define-primitive-object (value-cell :lowtag other-pointer-lowtag
(move-lvar-result node block (list value-tn) (node-lvar node))))
(defun emit-inits (node block name result lowtag inits args)
- (let ((unbound-marker-tn nil))
+ (let ((unbound-marker-tn nil)
+ (funcallable-instance-tramp-tn nil))
(dolist (init inits)
(let ((kind (car init))
(slot (cdr init)))
(vop make-unbound-marker node block tn)
tn))))
(:null
- (emit-constant nil)))
+ (emit-constant nil))
+ (:funcallable-instance-tramp
+ (or funcallable-instance-tramp-tn
+ (setf funcallable-instance-tramp-tn
+ (let ((tn (make-restricted-tn
+ nil
+ (sc-number-or-lose 'sb!vm::any-reg))))
+ (vop make-funcallable-instance-tramp node block tn)
+ tn)))))
name slot lowtag))))
(aver (null args)))
(defoptimizer ir2-convert-fixed-allocation
((&rest args) node block name words type lowtag inits)
(let* ((lvar (node-lvar node))
- (locs (lvar-result-tns lvar
- (list *backend-t-primitive-type*)))
+ (locs (lvar-result-tns lvar (list *backend-t-primitive-type*)))
(result (first locs)))
(emit-fixed-alloc node block name words type lowtag result)
(emit-inits node block name result lowtag inits args)
(defoptimizer ir2-convert-variable-allocation
((extra &rest args) node block name words type lowtag inits)
(let* ((lvar (node-lvar node))
- (locs (lvar-result-tns lvar
- (list *backend-t-primitive-type*)))
+ (locs (lvar-result-tns lvar (list *backend-t-primitive-type*)))
(result (first locs)))
(if (constant-lvar-p extra)
(let ((words (+ (lvar-value extra) words)))
:default
#+sb-xc-host (specifier-type 'function)
#-sb-xc-host (if (fboundp name)
- (extract-fun-type (fdefinition name))
+ (specifier-type (sb!impl::%fun-type (fdefinition name)))
(specifier-type 'function)))
;;; the ASSUMED-TYPE for this function, if we have to infer the type
(inst dep fun-pointer-lowtag 31 3 result)
(inst li (logior (ash (1- size) n-widetag-bits) closure-header-widetag) temp)
(storew temp result 0 fun-pointer-lowtag)))
- (storew result result closure-self-slot fun-pointer-lowtag)
(storew function result closure-fun-slot fun-pointer-lowtag)))
;;; The compiler likes to be able to directly make value cells.
-;;;
(define-vop (make-value-cell)
(:args (value :to :save :scs (descriptor-reg any-reg)))
(:temporary (:scs (non-descriptor-reg)) temp)
(:generator 1
(inst li unbound-marker-widetag result)))
+(define-vop (make-funcallable-instance-tramp)
+ (:args)
+ (:results (result :scs (any-reg)))
+ (:generator 1
+ (inst li (make-fixup "funcallable_instance_tramp" :foreign) result)))
+
(define-vop (fixed-alloc)
(:args)
(:info name words type lowtag)
funcallable-instance-info-offset fun-pointer-lowtag
(descriptor-reg any-reg) * %funcallable-instance-info)
-(define-vop (funcallable-instance-lexenv cell-ref)
- (:variant funcallable-instance-lexenv-slot fun-pointer-lowtag))
-
-
(define-vop (closure-ref slot-ref)
(:variant closure-info-offset fun-pointer-lowtag))
(define-vop (closure-init slot-set)
(:variant closure-info-offset fun-pointer-lowtag))
-
-
\f
;;;; Value Cell hackery.
(if (ir2-physenv-closure env)
(let ((closure (make-normal-tn *backend-t-primitive-type*)))
(vop setup-closure-environment node block start-label closure)
- ;; KLUDGE: see the comment around the definition of
- ;; CLOSURE objects in src/compiler/objdef.lisp
- (vop funcallable-instance-lexenv node block closure closure)
(let ((n -1))
(dolist (loc (ir2-physenv-closure env))
(vop closure-ref node block closure (incf n) (cdr loc)))))
(inst li temp (logior (ash (1- size) n-widetag-bits)
closure-header-widetag))
(storew temp result 0 fun-pointer-lowtag))
- (storew result result closure-self-slot fun-pointer-lowtag)
(storew function result closure-fun-slot fun-pointer-lowtag))))
;;; The compiler likes to be able to directly make value cells.
-;;;
(define-vop (make-value-cell)
(:args (value :to :save :scs (descriptor-reg any-reg null zero)))
(:temporary (:scs (non-descriptor-reg)) temp)
(:generator 1
(inst li result unbound-marker-widetag)))
+(define-vop (make-funcallable-instance-tramp)
+ (:args)
+ (:results (result :scs (any-reg)))
+ (:generator 1
+ (inst li result (make-fixup "funcallable_instance_tramp" :foreign))))
+
(define-vop (fixed-alloc)
(:args)
(:info name words type lowtag)
funcallable-instance-info-offset fun-pointer-lowtag
(descriptor-reg any-reg) * %funcallable-instance-info)
-(define-vop (funcallable-instance-lexenv cell-ref)
- (:variant funcallable-instance-lexenv-slot fun-pointer-lowtag))
-
(define-vop (closure-ref slot-ref)
(:variant closure-info-offset fun-pointer-lowtag))
(define-vop (closure-init slot-set)
(:variant closure-info-offset fun-pointer-lowtag))
-
\f
;;;; Value Cell hackery.
(inst lr temp (logior (ash (1- size) n-widetag-bits) closure-header-widetag))))
;;; should this be closure-fun-slot instead of 0?
(storew temp result 0 fun-pointer-lowtag)
- (storew result result closure-self-slot fun-pointer-lowtag)
(storew function result closure-fun-slot fun-pointer-lowtag)))))
;;; The compiler likes to be able to directly make value cells.
(:generator 1
(inst li result unbound-marker-widetag)))
+(define-vop (make-funcallable-instance-tramp)
+ (:args)
+ (:results (result :scs (any-reg)))
+ (:generator 1
+ (inst lr result (make-fixup "funcallable_instance_tramp" :foreign))))
+
(define-vop (fixed-alloc)
(:args)
(:info name words type lowtag)
(:variant funcallable-instance-info-offset fun-pointer-lowtag)
(:translate %set-funcallable-instance-info))
-(define-vop (funcallable-instance-lexenv cell-ref)
- (:variant funcallable-instance-lexenv-slot fun-pointer-lowtag))
-
-
(define-vop (closure-ref slot-ref)
(:variant closure-info-offset fun-pointer-lowtag))
(inst or result fun-pointer-lowtag)))
(inst li temp (logior (ash (1- size) n-widetag-bits) closure-header-widetag))
(storew temp result 0 fun-pointer-lowtag))
- (storew result result closure-self-slot fun-pointer-lowtag)
(storew function result closure-fun-slot fun-pointer-lowtag))))
;;; The compiler likes to be able to directly make value cells.
(:generator 1
(inst li result unbound-marker-widetag)))
+(define-vop (make-funcallable-instance-tramp)
+ (:args)
+ (:results (result :scs (any-reg)))
+ (:generator 1
+ (inst li result (make-fixup "funcallable_instance_tramp" :foreign))))
+
(define-vop (fixed-alloc)
(:args)
(:info name words type lowtag)
(:variant funcallable-instance-info-offset fun-pointer-lowtag)
(:translate %set-funcallable-instance-info))
-(define-vop (funcallable-instance-lexenv cell-ref)
- (:variant funcallable-instance-lexenv-slot fun-pointer-lowtag))
-
-
(define-vop (closure-ref slot-ref)
(:variant closure-info-offset fun-pointer-lowtag))
(make-ea :byte :base result :disp fun-pointer-lowtag))
(storew (logior (ash (1- size) n-widetag-bits) closure-header-widetag)
result 0 fun-pointer-lowtag))
- (storew result result closure-self-slot fun-pointer-lowtag)
(loadw temp function closure-fun-slot fun-pointer-lowtag)
(storew temp result closure-fun-slot fun-pointer-lowtag))))
(:generator 1
(inst mov result unbound-marker-widetag)))
+(define-vop (make-funcallable-instance-tramp)
+ (:args)
+ (:results (result :scs (any-reg)))
+ (:generator 1
+ (inst lea result (make-fixup "funcallable_instance_tramp" :foreign))))
+
(define-vop (fixed-alloc)
(:args)
(:info name words type lowtag)
funcallable-instance-info-offset fun-pointer-lowtag
(descriptor-reg any-reg) * %funcallable-instance-info)
-(define-vop (funcallable-instance-lexenv cell-ref)
- (:variant funcallable-instance-lexenv-slot fun-pointer-lowtag))
-
(define-vop (closure-ref slot-ref)
(:variant closure-info-offset fun-pointer-lowtag))
(define-source-transform %closure-fun (closure)
`(%simple-fun-self ,closure))
-(define-source-transform %funcallable-instance-fun (fin)
- `(%simple-fun-self ,fin))
-
(define-vop (%set-fun-self)
(:policy :fast-safe)
(:translate (setf %simple-fun-self))
fun-pointer-lowtag)))
(storew temp function simple-fun-self-slot fun-pointer-lowtag)
(move result new-self)))
-
-;;; KLUDGE: This seems to be some kind of weird override of the way
-;;; that the objdef.lisp code would ordinarily set up the slot
-;;; accessor. It's inherited from CMU CL, and it works, and naively
-;;; deleting it seemed to cause problems, but it's not obvious why
-;;; it's done this way. Any ideas? -- WHN 2001-08-02
-(defknown ((setf %funcallable-instance-fun)) (function function) function
- (unsafe))
-;;; CMU CL comment:
-;;; We would have really liked to use a source-transform for this, but
-;;; they don't work with SETF functions.
-;;; FIXME: Can't we just use DEFSETF or something?
-(deftransform (setf %funcallable-instance-fun) ((value fin))
- '(setf (%simple-fun-self fin) value))
\f
;;;; other miscellaneous VOPs
(make-ea :byte :base result :disp fun-pointer-lowtag))
(storew (logior (ash (1- size) n-widetag-bits) closure-header-widetag)
result 0 fun-pointer-lowtag))
- (storew result result closure-self-slot fun-pointer-lowtag)
(loadw temp function closure-fun-slot fun-pointer-lowtag)
(storew temp result closure-fun-slot fun-pointer-lowtag))))
(:generator 1
(inst mov result unbound-marker-widetag)))
+(define-vop (make-funcallable-instance-tramp)
+ (:args)
+ (:results (result :scs (any-reg)))
+ (:generator 1
+ (inst lea result (make-fixup "funcallable_instance_tramp" :foreign))))
+
(define-vop (fixed-alloc)
(:args)
(:info name words type lowtag)
funcallable-instance-info-offset fun-pointer-lowtag
(descriptor-reg any-reg) * %funcallable-instance-info)
-(define-vop (funcallable-instance-lexenv cell-ref)
- (:variant funcallable-instance-lexenv-slot fun-pointer-lowtag))
-
(define-vop (closure-ref slot-ref)
(:variant closure-info-offset fun-pointer-lowtag))
(define-source-transform %closure-fun (closure)
`(%simple-fun-self ,closure))
-(define-source-transform %funcallable-instance-fun (fin)
- `(%simple-fun-self ,fin))
-
(define-vop (%set-fun-self)
(:policy :fast-safe)
(:translate (setf %simple-fun-self))
fun-pointer-lowtag)))
(storew temp function simple-fun-self-slot fun-pointer-lowtag)
(move result new-self)))
-
-;;; KLUDGE: This seems to be some kind of weird override of the way
-;;; that the objdef.lisp code would ordinarily set up the slot
-;;; accessor. It's inherited from CMU CL, and it works, and naively
-;;; deleting it seemed to cause problems, but it's not obvious why
-;;; it's done this way. Any ideas? -- WHN 2001-08-02
-(defknown ((setf %funcallable-instance-fun)) (function function) function
- (unsafe))
-;;; CMU CL comment:
-;;; We would have really liked to use a source-transform for this, but
-;;; they don't work with SETF functions.
-;;; FIXME: Can't we just use DEFSETF or something?
-(deftransform (setf %funcallable-instance-fun) ((value fin))
- '(setf (%simple-fun-self fin) value))
\f
;;;; other miscellaneous VOPs
#include "lispregs.h"
#include "genesis/fdefn.h"
#include "genesis/closure.h"
+#include "genesis/funcallable-instance.h"
#include "genesis/simple-fun.h"
#include "genesis/static-symbols.h"
.globl end_of_tramps
end_of_tramps:
+ .text
+ .globl funcallable_instance_tramp
+ .align 2
+ .long SIMPLE_FUN_HEADER_WIDETAG
+funcallable_instance_tramp = . + 1
+ .long funcallable_instance_tramp
+ .long NIL
+ .long NIL
+ .long NIL
+ .long NIL
+
+ ldl reg_LEXENV, FUNCALLABLE_INSTANCE_FUNCTION_OFFSET(reg_LEXENV)
+ /* I think we don't actually need to use reg_CODE here, because
+ $CODE is computed from $LIP in the function itself */
+ ldl reg_CODE, CLOSURE_FUN_OFFSET(reg_LEXENV)
+ addl reg_CODE, SIMPLE_FUN_CODE_OFFSET, reg_LIP
+ jmp reg_ZERO, (reg_LIP)
/*
* fun-end breakpoint magic.
scavtab[SIMPLE_FUN_HEADER_WIDETAG] = scav_fun_header;
scavtab[RETURN_PC_HEADER_WIDETAG] = scav_return_pc_header;
#endif
+ scavtab[FUNCALLABLE_INSTANCE_HEADER_WIDETAG] = scav_boxed;
#if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
scavtab[CLOSURE_HEADER_WIDETAG] = scav_closure_header;
- scavtab[FUNCALLABLE_INSTANCE_HEADER_WIDETAG] = scav_closure_header;
#else
scavtab[CLOSURE_HEADER_WIDETAG] = scav_boxed;
- scavtab[FUNCALLABLE_INSTANCE_HEADER_WIDETAG] = scav_boxed;
#endif
scavtab[VALUE_CELL_HEADER_WIDETAG] = scav_boxed;
scavtab[SYMBOL_HEADER_WIDETAG] = scav_boxed;
}
#endif
-#if defined(LISP_FEATURE_PPC)
-extern int closure_tramp;
-extern int undefined_tramp;
-#else
-extern int undefined_tramp;
-#endif
-
static void
verify_space(lispobj *start, size_t words)
{
*/
} else {
/* Verify that it points to another valid space. */
- if (!to_readonly_space && !to_static_space &&
-#if defined(LISP_FEATURE_PPC)
- !((thing == &closure_tramp) ||
- (thing == &undefined_tramp))
-#else
- thing != (unsigned long)&undefined_tramp
-#endif
- ) {
+ if (!to_readonly_space && !to_static_space) {
lose("Ptr %x @ %x sees junk.\n", thing, start);
}
}
+/*
+ * very-low-level utilities for runtime support
+ */
+
+/*
+ * This software is part of the SBCL system. See the README file for
+ * more information.
+ *
+ * This software is derived from the CMU CL system, which was
+ * written at Carnegie Mellon University and released into the
+ * public domain. The software is in the public domain and is
+ * provided with absolutely no warranty. See the COPYING and CREDITS
+ * files for more information.
+ */
+\f
#include "sbcl.h"
#include "lispregs.h"
#include "globals.h"
#include "genesis/fdefn.h"
#include "genesis/closure.h"
+#include "genesis/funcallable-instance.h"
#include "genesis/return-pc.h"
#include "genesis/simple-fun.h"
#include "genesis/static-symbols.h"
END(closure_tramp)
/*
+ * The trampoline for funcallable instances
+ */
+ .globl funcallable_instance_tramp
+ .align 3
+ .word SIMPLE_FUN_HEADER_WIDETAG
+funcallable_instance_tramp = . + 1
+ .word funcallable_instance_tramp
+ .word NIL
+ .word NIL
+ .word NIL
+ .word NIL
+
+ lw reg_LEXENV, FUNCALLABLE_INSTANCE_FUNCTION_OFFSET(reg_LEXENV)
+ lw reg_CODE, CLOSURE_FUN_OFFSET(reg_LEXENV)
+ addu reg_LIP, reg_CODE, SIMPLE_FUN_CODE_OFFSET
+ jr reg_LIP
+ nop
+
+/*
* Function-end breakpoint magic. This is truely magic, the code is
* copied and has to be relocatable. It also needs a properly aligned
* header tag after the fun_end_breakpoint_guts symbol.
#include "genesis/simple-fun.h"
#include "genesis/fdefn.h"
#include "genesis/closure.h"
+#include "genesis/funcallable-instance.h"
#include "genesis/static-symbols.h"
#ifdef LISP_FEATURE_DARWIN
GFUNCDEF(xundefined_tramp)
.globl CSYMBOL(undefined_tramp)
- .byte 0,0,0,SIMPLE_FUN_HEADER_WIDETAG
- .byte 18<<2
CSYMBOL(undefined_tramp):
- .byte 0,0,48
- .long CSYMBOL(undefined_tramp)
- .long NIL
- .long NIL
- .long NIL
twllei reg_ZERO,trap_Cerror
.byte 4
.byte UNDEFINED_FUN_ERROR
.byte 254, sc_DescriptorReg+0x40, 1 /* 140? sparc says sc_descriptorReg */
+ /* This stuff is for the continuable error. I don't think there's
+ * any support for it on the lisp side */
.align 2
1: lwz reg_CODE,FDEFN_RAW_ADDR_OFFSET(reg_FDEFN)
la reg_LIP,SIMPLE_FUN_CODE_OFFSET(reg_CODE)
GFUNCDEF(xclosure_tramp)
.globl CSYMBOL(closure_tramp)
- .byte 0,0,0,SIMPLE_FUN_HEADER_WIDETAG
- .byte 18<<2
CSYMBOL(closure_tramp):
- .byte 0,0,24
- .long CSYMBOL(closure_tramp)
- .long NIL
- .long NIL
- .long NIL
- .long NIL
lwz reg_LEXENV,FDEFN_FUN_OFFSET(reg_FDEFN)
lwz reg_CODE,CLOSURE_FUN_OFFSET(reg_LEXENV)
la reg_LIP,SIMPLE_FUN_CODE_OFFSET(reg_CODE)
SET_SIZE(xclosure_tramp)
+ GFUNCDEF(xfuncallable_instance_tramp)
+ .globl CSYMBOL(funcallable_instance_tramp)
+ .long SIMPLE_FUN_HEADER_WIDETAG
+CSYMBOL(funcallable_instance_tramp) = . + 1
+ .long CSYMBOL(funcallable_instance_tramp)
+ .long NIL
+ .long NIL
+ .long NIL
+ .long NIL
+ lwz reg_LEXENV,FUNCALLABLE_INSTANCE_FUNCTION_OFFSET(reg_LEXENV)
+ lwz reg_FDEFN,CLOSURE_FUN_OFFSET(reg_LEXENV)
+ addi reg_LIP,reg_FDEFN,SIMPLE_FUN_CODE_OFFSET
+ mtctr reg_LIP
+ bctr
+ SET_SIZE(funcallable_instance_tramp)
+
GFUNCDEF(fun_end_breakpoint_trap)
.long 0
SET_SIZE(fun_end_breakpoint_trap)
#if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
case CLOSURE_HEADER_WIDETAG:
- case FUNCALLABLE_INSTANCE_HEADER_WIDETAG:
/* The function self pointer needs special care on the
* x86 because it is the real entry point. */
{
#include "globals.h"
#include "sbcl.h"
#include "genesis/closure.h"
+#include "genesis/funcallable-instance.h"
#include "genesis/fdefn.h"
#include "genesis/static-symbols.h"
#include "genesis/simple-fun.h"
jmp reg_CODE+SIMPLE_FUN_CODE_OFFSET
nop
-
+ .global funcallable_instance_tramp
+ FUNCDEF(funcallable_instance_tramp)
+ .align 8
+ .word SIMPLE_FUN_HEADER_WIDETAG
+funcallable_instance_tramp = . + 1
+ .word funcallable_instance_tramp
+ .word NIL
+ .word NIL
+ .word NIL
+ .word NIL
+
+ ld [reg_LEXENV+FUNCALLABLE_INSTANCE_FUNCTION_OFFSET], reg_LEXENV
+ ld [reg_LEXENV+CLOSURE_FUN_OFFSET], reg_CODE
+ jmp reg_CODE+SIMPLE_FUN_CODE_OFFSET
+ nop
/*
* Function-end breakpoint magic.
*/
#include "validate.h"
#include "sbcl.h"
#include "genesis/closure.h"
+#include "genesis/funcallable-instance.h"
#include "genesis/fdefn.h"
#include "genesis/static-symbols.h"
#include "genesis/symbol.h"
jmp *CLOSURE_FUN_OFFSET(%rax)
.size GNAME(closure_tramp), .-GNAME(closure_tramp)
+ .text
+ .align align_8byte,0x90
+ .global GNAME(funcallable_instance_tramp)
+ .type GNAME(funcallable_instance_tramp),@function
+GNAME(funcallable_instance_tramp):
+ mov FUNCALLABLE_INSTANCE_FUNCTION_OFFSET(%rax),%rax
+ /* KLUDGE: on this platform, whatever kind of function is in %rax
+ * now, the first word of it contains the address to jump to. */
+ jmp *CLOSURE_FUN_OFFSET(%rax)
+ .size GNAME(funcallable_instance_tramp), .-GNAME(funcallable_instance_tramp)
+
/*
* fun-end breakpoint magic
*/
jmp *CLOSURE_FUN_OFFSET(%eax)
SIZE(GNAME(closure_tramp))
+ .text
+ .align align_4byte,0x90
+ .global GNAME(funcallable_instance_tramp)
+ .type GNAME(funcallable_instance_tramp),@function
+GNAME(funcallable_instance_tramp):
+ movl FUNCALLABLE_INSTANCE_FUNCTION_OFFSET(%eax),%eax
+ /* KLUDGE: on this platform, whatever kind of function is in %rax
+ * now, the first word of it contains the address to jump to. */
+ jmp *CLOSURE_FUN_OFFSET(%eax)
+ .size GNAME(funcallable_instance_tramp), .-GNAME(funcallable_instance_tramp)
+
/*
* fun-end breakpoint magic
*/
-
;;;; miscellaneous tests of thread stuff
;;;; This software is part of the SBCL system. See the README file for
(incf i)))))
(format t "~&gc deadlock test done~%")
+\f
+(let ((count (make-array 8 :initial-element 0)))
+ (defun closure-one ()
+ (declare (optimize safety))
+ (values (incf (aref count 0)) (incf (aref count 1))
+ (incf (aref count 2)) (incf (aref count 3))
+ (incf (aref count 4)) (incf (aref count 5))
+ (incf (aref count 6)) (incf (aref count 7))))
+ (defun no-optimizing-away-closure-one ()
+ (setf count (make-array 8 :initial-element 0))))
+
+(defstruct box
+ (count 0))
+
+(let ((one (make-box))
+ (two (make-box))
+ (three (make-box)))
+ (defun closure-two ()
+ (declare (optimize safety))
+ (values (incf (box-count one)) (incf (box-count two)) (incf (box-count three))))
+ (defun no-optimizing-away-closure-two ()
+ (setf one (make-box)
+ two (make-box)
+ three (make-box))))
+
+(with-test (:name (:funcallable-instances))
+ ;; the funcallable-instance implementation used not to be threadsafe
+ ;; against setting the funcallable-instance function to a closure
+ ;; (because the code and lexenv were set separately).
+ (let ((fun (sb-kernel:%make-funcallable-instance 0))
+ (condition nil))
+ (setf (sb-kernel:funcallable-instance-fun fun) #'closure-one)
+ (flet ((changer ()
+ (loop (setf (sb-kernel:funcallable-instance-fun fun) #'closure-one)
+ (setf (sb-kernel:funcallable-instance-fun fun) #'closure-two)))
+ (test ()
+ (handler-case (loop (funcall fun))
+ (serious-condition (c) (setf condition c)))))
+ (let ((changer (make-thread #'changer))
+ (test (make-thread #'test)))
+ (handler-case
+ (progn
+ ;; The two closures above are fairly carefully crafted
+ ;; so that if given the wrong lexenv they will tend to
+ ;; do some serious damage, but it is of course difficult
+ ;; to predict where the various bits and pieces will be
+ ;; allocated. Five seconds failed fairly reliably on
+ ;; both my x86 and x86-64 systems. -- CSR, 2006-09-27.
+ (sb-ext:with-timeout 5
+ (wait-for-threads (list test)))
+ (error "~@<test thread got condition:~2I~_~A~@:>" condition))
+ (sb-ext:timeout ()
+ (terminate-thread changer)
+ (terminate-thread test)
+ (wait-for-threads (list changer test))))))))
+
+(format t "~&funcallable-instance test done~%")
;;; 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".)
-"0.9.17.7"
+"0.9.17.8"
projects / sbcl.git / commitdiff