From b9e94e326f79ab01e56cb437e424ce5ea489471f Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Fri, 6 Oct 2006 10:54:09 +0000 Subject: [PATCH] 0.9.17.8: MORE THREADSAFE FUNCALLABLE-INSTANCE ... in a threaded world, we can't set the function and lexenv of a funcallable instance separately, because some other thread might inconveniently funcall the object 'twixt the one and the other. ... instead, make the funcallable-instance-function a fully-fledged slot, and give a funcallable-instance a trampoline which knows how to call it. ... which means implementing this strategy for $n$ architectures. Tested on x86, x86-64, ppc, alpha and sparc; completely untested on mips, and unimplemented on hppa. This removes some of the complexity in calling closures (the closure-self slot is now redundant, as is the extra indirection). Other miscellaneous fixes: * extract-fun-type worked only by accident; * new magic :init :funcallable-instance-tramp for primitive objects * verify_space() need no longer worry its little brain about undefined_tramp and closure_tramp (I think) * test case for threaded funcallable-instance interaction. --- NEWS | 3 ++ package-data-list.lisp-expr | 13 +++---- src/code/stubs.lisp | 8 +--- src/code/target-defstruct.lisp | 33 ++-------------- src/code/target-type.lisp | 6 +-- src/compiler/alpha/alloc.lisp | 7 +++- src/compiler/alpha/cell.lisp | 3 -- src/compiler/generic/objdef.lisp | 69 ++-------------------------------- src/compiler/generic/vm-ir2tran.lisp | 19 +++++++--- src/compiler/globaldb.lisp | 2 +- src/compiler/hppa/alloc.lisp | 8 +++- src/compiler/hppa/cell.lisp | 6 --- src/compiler/ir2tran.lisp | 3 -- src/compiler/mips/alloc.lisp | 8 +++- src/compiler/mips/cell.lisp | 4 -- src/compiler/ppc/alloc.lisp | 7 +++- src/compiler/ppc/cell.lisp | 4 -- src/compiler/sparc/alloc.lisp | 7 +++- src/compiler/sparc/cell.lisp | 4 -- src/compiler/x86-64/alloc.lisp | 7 +++- src/compiler/x86-64/cell.lisp | 3 -- src/compiler/x86-64/system.lisp | 17 --------- src/compiler/x86/alloc.lisp | 7 +++- src/compiler/x86/cell.lisp | 3 -- src/compiler/x86/system.lisp | 17 --------- src/runtime/alpha-assem.S | 18 +++++++++ src/runtime/gc-common.c | 3 +- src/runtime/gencgc.c | 16 +------- src/runtime/mips-assem.S | 35 +++++++++++++++++ src/runtime/ppc-assem.S | 34 +++++++++-------- src/runtime/purify.c | 1 - src/runtime/sparc-assem.S | 17 ++++++++- src/runtime/x86-64-assem.S | 12 ++++++ src/runtime/x86-assem.S | 11 ++++++ tests/threads.impure.lisp | 58 +++++++++++++++++++++++++++- version.lisp-expr | 2 +- 36 files changed, 244 insertions(+), 231 deletions(-) diff --git a/NEWS b/NEWS index 22eaf0f..4d647ab 100644 --- a/NEWS +++ b/NEWS @@ -5,6 +5,9 @@ changes in sbcl-0.9.18 (1.0.beta?) relative to sbcl-0.9.16: 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. diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 569a836..507eae4 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -337,6 +337,7 @@ of SBCL which maintained the CMU-CL-style split into two packages.)" "DEF-SETTER" "FIXED-ALLOC" "MAKE-UNBOUND-MARKER" + "MAKE-FUNCALLABLE-INSTANCE-TRAMP" "RETURN-SINGLE" "NOTE-NEXT-INSTRUCTION" "SET-SLOT" @@ -345,7 +346,6 @@ of SBCL which maintained the CMU-CL-style split into two packages.)" "BLOCK-NUMBER" "BACKEND" "IR2-BLOCK-BLOCK" - "FUNCALLABLE-INSTANCE-LEXENV" "VOP-BLOCK" "*ASSEMBLY-OPTIMIZE*" "LARGE-ALLOC" @@ -1154,8 +1154,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "%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" @@ -1546,8 +1545,8 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "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" @@ -2162,7 +2161,7 @@ structure representations" "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" @@ -2177,8 +2176,6 @@ structure representations" "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" diff --git a/src/code/stubs.lisp b/src/code/stubs.lisp index 13413d4..c2c35c2 100644 --- a/src/code/stubs.lisp +++ b/src/code/stubs.lisp @@ -15,13 +15,9 @@ (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))) diff --git a/src/code/target-defstruct.lisp b/src/code/target-defstruct.lisp index 8978cc5..810ebce 100644 --- a/src/code/target-defstruct.lisp +++ b/src/code/target-defstruct.lisp @@ -147,37 +147,10 @@ (%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) diff --git a/src/code/target-type.lisp b/src/code/target-type.lisp index 4ae6003..665b453 100644 --- a/src/code/target-type.lisp +++ b/src/code/target-type.lisp @@ -143,10 +143,6 @@ "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)))) ;;;; miscellaneous interfaces @@ -182,7 +178,7 @@ (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 diff --git a/src/compiler/alpha/alloc.lisp b/src/compiler/alpha/alloc.lisp index 85e82bd..4852fec 100644 --- a/src/compiler/alpha/alloc.lisp +++ b/src/compiler/alpha/alloc.lisp @@ -141,7 +141,6 @@ (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. @@ -162,6 +161,12 @@ (: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) diff --git a/src/compiler/alpha/cell.lisp b/src/compiler/alpha/cell.lisp index 97e250e..c3fadf9 100644 --- a/src/compiler/alpha/cell.lisp +++ b/src/compiler/alpha/cell.lisp @@ -227,9 +227,6 @@ 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)) diff --git a/src/compiler/generic/objdef.lisp b/src/compiler/generic/objdef.lisp index 2428126..7b9b242 100644 --- a/src/compiler/generic/objdef.lisp +++ b/src/compiler/generic/objdef.lisp @@ -221,78 +221,15 @@ (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 diff --git a/src/compiler/generic/vm-ir2tran.lisp b/src/compiler/generic/vm-ir2tran.lisp index 2c9320e..c9e064a 100644 --- a/src/compiler/generic/vm-ir2tran.lisp +++ b/src/compiler/generic/vm-ir2tran.lisp @@ -33,7 +33,8 @@ (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))) @@ -51,7 +52,15 @@ (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))) @@ -61,8 +70,7 @@ (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) @@ -71,8 +79,7 @@ (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))) diff --git a/src/compiler/globaldb.lisp b/src/compiler/globaldb.lisp index 1f1eeb5..c5e1a7a 100644 --- a/src/compiler/globaldb.lisp +++ b/src/compiler/globaldb.lisp @@ -936,7 +936,7 @@ :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 diff --git a/src/compiler/hppa/alloc.lisp b/src/compiler/hppa/alloc.lisp index f532c76..8ad6676 100644 --- a/src/compiler/hppa/alloc.lisp +++ b/src/compiler/hppa/alloc.lisp @@ -126,11 +126,9 @@ (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) @@ -150,6 +148,12 @@ (: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) diff --git a/src/compiler/hppa/cell.lisp b/src/compiler/hppa/cell.lisp index 607fe12..545051c 100644 --- a/src/compiler/hppa/cell.lisp +++ b/src/compiler/hppa/cell.lisp @@ -208,17 +208,11 @@ 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)) - - ;;;; Value Cell hackery. diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index 30a0cff..026b509 100644 --- a/src/compiler/ir2tran.lisp +++ b/src/compiler/ir2tran.lisp @@ -1128,9 +1128,6 @@ (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))))) diff --git a/src/compiler/mips/alloc.lisp b/src/compiler/mips/alloc.lisp index d0f21a3..eb194d5 100644 --- a/src/compiler/mips/alloc.lisp +++ b/src/compiler/mips/alloc.lisp @@ -147,11 +147,9 @@ (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) @@ -170,6 +168,12 @@ (: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) diff --git a/src/compiler/mips/cell.lisp b/src/compiler/mips/cell.lisp index 79b2bbe..40ac92c 100644 --- a/src/compiler/mips/cell.lisp +++ b/src/compiler/mips/cell.lisp @@ -232,15 +232,11 @@ 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)) - ;;;; Value Cell hackery. diff --git a/src/compiler/ppc/alloc.lisp b/src/compiler/ppc/alloc.lisp index 4f83b44..55c6df5 100644 --- a/src/compiler/ppc/alloc.lisp +++ b/src/compiler/ppc/alloc.lisp @@ -149,7 +149,6 @@ (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. @@ -173,6 +172,12 @@ (: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) diff --git a/src/compiler/ppc/cell.lisp b/src/compiler/ppc/cell.lisp index b0e1afc..553dfe8 100644 --- a/src/compiler/ppc/cell.lisp +++ b/src/compiler/ppc/cell.lisp @@ -220,10 +220,6 @@ (: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)) diff --git a/src/compiler/sparc/alloc.lisp b/src/compiler/sparc/alloc.lisp index f743dfe..aa46f2f 100644 --- a/src/compiler/sparc/alloc.lisp +++ b/src/compiler/sparc/alloc.lisp @@ -143,7 +143,6 @@ (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. @@ -164,6 +163,12 @@ (: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) diff --git a/src/compiler/sparc/cell.lisp b/src/compiler/sparc/cell.lisp index fc5e324..7670c05 100644 --- a/src/compiler/sparc/cell.lisp +++ b/src/compiler/sparc/cell.lisp @@ -215,10 +215,6 @@ (: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)) diff --git a/src/compiler/x86-64/alloc.lisp b/src/compiler/x86-64/alloc.lisp index 7138cdd..690e34b 100644 --- a/src/compiler/x86-64/alloc.lisp +++ b/src/compiler/x86-64/alloc.lisp @@ -218,7 +218,6 @@ (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)))) @@ -240,6 +239,12 @@ (: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) diff --git a/src/compiler/x86-64/cell.lisp b/src/compiler/x86-64/cell.lisp index 60171da..b9371f2 100644 --- a/src/compiler/x86-64/cell.lisp +++ b/src/compiler/x86-64/cell.lisp @@ -419,9 +419,6 @@ 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)) diff --git a/src/compiler/x86-64/system.lisp b/src/compiler/x86-64/system.lisp index e411567..5d8ab1c 100644 --- a/src/compiler/x86-64/system.lisp +++ b/src/compiler/x86-64/system.lisp @@ -234,9 +234,6 @@ (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)) @@ -251,20 +248,6 @@ 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)) ;;;; other miscellaneous VOPs diff --git a/src/compiler/x86/alloc.lisp b/src/compiler/x86/alloc.lisp index f3cdb3c..9306c1b 100644 --- a/src/compiler/x86/alloc.lisp +++ b/src/compiler/x86/alloc.lisp @@ -218,7 +218,6 @@ (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)))) @@ -240,6 +239,12 @@ (: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) diff --git a/src/compiler/x86/cell.lisp b/src/compiler/x86/cell.lisp index c998c2c..53cea4a 100644 --- a/src/compiler/x86/cell.lisp +++ b/src/compiler/x86/cell.lisp @@ -421,9 +421,6 @@ 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)) diff --git a/src/compiler/x86/system.lisp b/src/compiler/x86/system.lisp index b9e9c5f..67bf3a3 100644 --- a/src/compiler/x86/system.lisp +++ b/src/compiler/x86/system.lisp @@ -232,9 +232,6 @@ (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)) @@ -249,20 +246,6 @@ 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)) ;;;; other miscellaneous VOPs diff --git a/src/runtime/alpha-assem.S b/src/runtime/alpha-assem.S index c0ab2cc..ac79fa1 100644 --- a/src/runtime/alpha-assem.S +++ b/src/runtime/alpha-assem.S @@ -20,6 +20,7 @@ #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" @@ -296,6 +297,23 @@ closure_tramp= call_into_lisp_LRA_page+0x150 .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. diff --git a/src/runtime/gc-common.c b/src/runtime/gc-common.c index a439957..408ef8a 100644 --- a/src/runtime/gc-common.c +++ b/src/runtime/gc-common.c @@ -2081,12 +2081,11 @@ gc_init_tables(void) 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; diff --git a/src/runtime/gencgc.c b/src/runtime/gencgc.c index 88de20f..6902759 100644 --- a/src/runtime/gencgc.c +++ b/src/runtime/gencgc.c @@ -3229,13 +3229,6 @@ print_ptr(lispobj *addr) } #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) { @@ -3290,14 +3283,7 @@ 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); } } diff --git a/src/runtime/mips-assem.S b/src/runtime/mips-assem.S index 4be3628..ca4cfd0 100644 --- a/src/runtime/mips-assem.S +++ b/src/runtime/mips-assem.S @@ -1,8 +1,24 @@ +/* + * 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. + */ + #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" @@ -405,6 +421,25 @@ lra: .word RETURN_PC_HEADER_WIDETAG 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. diff --git a/src/runtime/ppc-assem.S b/src/runtime/ppc-assem.S index c760abb..10f46d5 100644 --- a/src/runtime/ppc-assem.S +++ b/src/runtime/ppc-assem.S @@ -7,6 +7,7 @@ #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 @@ -515,18 +516,13 @@ lra: 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) @@ -539,15 +535,7 @@ CSYMBOL(undefined_tramp): 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) @@ -556,6 +544,22 @@ CSYMBOL(closure_tramp): 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) diff --git a/src/runtime/purify.c b/src/runtime/purify.c index 7ebf991..56ec207 100644 --- a/src/runtime/purify.c +++ b/src/runtime/purify.c @@ -1364,7 +1364,6 @@ pscav(lispobj *addr, long nwords, boolean constant) #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. */ { diff --git a/src/runtime/sparc-assem.S b/src/runtime/sparc-assem.S index 9107951..c856cc9 100644 --- a/src/runtime/sparc-assem.S +++ b/src/runtime/sparc-assem.S @@ -7,6 +7,7 @@ #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" @@ -242,7 +243,21 @@ closure_tramp = . + 1 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. */ diff --git a/src/runtime/x86-64-assem.S b/src/runtime/x86-64-assem.S index 92e0716..6ea7d21 100644 --- a/src/runtime/x86-64-assem.S +++ b/src/runtime/x86-64-assem.S @@ -17,6 +17,7 @@ #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" @@ -283,6 +284,17 @@ GNAME(closure_tramp): 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 */ diff --git a/src/runtime/x86-assem.S b/src/runtime/x86-assem.S index 72b14b8..551841a 100644 --- a/src/runtime/x86-assem.S +++ b/src/runtime/x86-assem.S @@ -361,6 +361,17 @@ GNAME(closure_tramp): 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 */ diff --git a/tests/threads.impure.lisp b/tests/threads.impure.lisp index 8eb97ae..cbebcd8 100644 --- a/tests/threads.impure.lisp +++ b/tests/threads.impure.lisp @@ -1,4 +1,3 @@ - ;;;; miscellaneous tests of thread stuff ;;;; This software is part of the SBCL system. See the README file for @@ -709,3 +708,60 @@ (incf i))))) (format t "~&gc deadlock test done~%") + +(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 "~@" condition)) + (sb-ext:timeout () + (terminate-thread changer) + (terminate-thread test) + (wait-for-threads (list changer test)))))))) + +(format t "~&funcallable-instance test done~%") diff --git a/version.lisp-expr b/version.lisp-expr index bea0f7c..1000660 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; 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" -- 1.7.10.4