Update of /cvsroot/sbcl/sbcl/src/compiler/x86
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv15547/src/compiler/x86
Modified Files:
c-call.lisp macros.lisp
Log Message:
1.0.11.20: fix with-pinned-objects stack corruption potential
* In the old WITH-PINNED-OBJECTS implementation we pushed pointers
onto stack explicitly (without telling the compiler), executed
the body, and _prior_to_returning_values_of_body_ popped the pointers.
If the values from the body were in progress of being returned via
unknown-values convention we would (try to) pop the pointers while
the last callee stack frame (where the values to be returned are)
is still on the stack. In many cases this was harmless, as the correct
SP was restored soon enough, but there were bad interactions as well.
* Solution: instead of explicitly pushing pointers, use a LET to
add binding to the current stack frame for the objects, and further
use a magic TOUCH-OBJECT function implemented with an empty VOP
to trick the compiler into keeping the variables live till the end
of the body.
Probably not perfect, but seems to do the job. Of the added test-case,
the MULTIPLE variants used to fail prior to this.
Index: c-call.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/x86/c-call.lisp,v
retrieving revision 1.38
retrieving revision 1.39
diff -u -d -r1.38 -r1.39
--- c-call.lisp 6 May 2007 17:56:28 -0000 1.38
+++ c-call.lisp 9 Nov 2007 17:38:16 -0000 1.39
@@ -328,27 +328,16 @@
(inst add (make-ea-for-symbol-value *alien-stack*)
delta)))))
-;;; these are not strictly part of the c-call convention, but are
-;;; needed for the WITH-PRESERVED-POINTERS macro used for "locking
-;;; down" lisp objects so that GC won't move them while foreign
-;;; functions go to work.
-
-(define-vop (push-word-on-c-stack)
- (:translate push-word-on-c-stack)
- (:args (val :scs (sap-reg)))
- (:policy :fast-safe)
- (:arg-types system-area-pointer)
- (:generator 2
- (inst push val)))
-
-(define-vop (pop-words-from-c-stack)
- (:translate pop-words-from-c-stack)
- (:args)
- (:arg-types (:constant (unsigned-byte 29)))
- (:info number)
+;;; not strictly part of the c-call convention, but needed for the
+;;; WITH-PINNED-OBJECTS macro used for "locking down" lisp objects so
+;;; that GC won't move them while foreign functions go to work.
+(define-vop (touch-object)
+ (:translate touch-object)
+ (:args (object :scs (descriptor-reg)))
+ (:ignore object)
(:policy :fast-safe)
- (:generator 2
- (inst add esp-tn (fixnumize number))))
+ (:arg-types t)
+ (:generator 0))
#-sb-xc-host
(defun alien-callback-accessor-form (type sp offset)
Index: macros.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/x86/macros.lisp,v
retrieving revision 1.49
retrieving revision 1.50
diff -u -d -r1.49 -r1.50
--- macros.lisp 6 Nov 2007 14:17:40 -0000 1.49
+++ macros.lisp 9 Nov 2007 17:38:16 -0000 1.50
@@ -548,26 +548,30 @@
(move result value)))))
;;; helper for alien stuff.
+
(def!macro with-pinned-objects ((&rest objects) &body body)
"Arrange with the garbage collector that the pages occupied by
-OBJECTS will not be moved in memory for the duration of BODY. Useful
-for e.g. foreign calls where another thread may trigger garbage
-collection"
+OBJECTS will not be moved in memory for the duration of BODY.
+Useful for e.g. foreign calls where another thread may trigger
+collection."
(if objects
- `(multiple-value-prog1
- (progn
- ,@(loop for p in objects
- collect
- ;; There is no race here wrt to gc, because at every
- ;; point during the execution there is a reference to
- ;; P on the stack or in a register.
- `(push-word-on-c-stack
- (int-sap (sb!kernel:get-lisp-obj-address ,p))))
- ,@body)
- ;; If the body returned normally, we should restore the stack pointer
- ;; for the benefit of any following code in the same function. If
- ;; there's a non-local exit in the body, sp is garbage anyway and
- ;; will get set appropriately from {a, the} frame pointer before it's
- ;; next needed
- (pop-words-from-c-stack ,(length objects)))
+ (let ((pins (make-gensym-list (length objects)))
+ (wpo (block-gensym "WPO")))
+ ;; BODY is stuffed in a function to preserve the lexical
+ ;; environment.
+ `(flet ((,wpo () (progn ,@body)))
+ ;; PINS are dx-allocated in case the compiler for some
+ ;; unfathomable reason decides to allocate value-cells
+ ;; for them -- since we have DX value-cells on x86oid
+ ;; platforms this still forces them on the stack.
+ (dx-let ,(mapcar #'list pins objects)
+ (multiple-value-prog1 (,wpo)
+ ;; TOUCH-OBJECT has a VOP with an empty body: compiler
+ ;; thinks we're using the argument and doesn't flush
+ ;; the variable, but we don't have to pay any extra
+ ;; beyond that -- and MULTIPLE-VALUE-PROG1 keeps them
+ ;; live till the body has finished. *whew*
+ ,@(mapcar (lambda (pin)
+ `(touch-object ,pin))
+ pins)))))
`(progn ,@body)))
|