From d01a6883a21ee073c1a00c401c12185dbd2a8133 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Fri, 9 Nov 2007 17:38:14 +0000 Subject: [PATCH] 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. --- NEWS | 4 ++++ src/compiler/fndb.lisp | 8 +++---- src/compiler/x86-64/c-call.lisp | 29 +++++++---------------- src/compiler/x86-64/macros.lisp | 38 ++++++++++++++++++------------ src/compiler/x86/c-call.lisp | 29 +++++++---------------- src/compiler/x86/macros.lisp | 42 ++++++++++++++++++--------------- tests/compiler.impure.lisp | 49 +++++++++++++++++++++++++++++++++++++++ version.lisp-expr | 2 +- 8 files changed, 122 insertions(+), 79 deletions(-) diff --git a/NEWS b/NEWS index 5f90a31..a48543c 100644 --- a/NEWS +++ b/NEWS @@ -1,5 +1,9 @@ ;;;; -*- coding: utf-8; -*- changes in sbcl-1.0.12 relative to sbcl-1.0.11: + * bug fix: SB-SYS:WITH-PINNED-OBJECTS could cause garbage values to + be returned from its body when the values were being returned + using unknown-values return convection and the W-P-O was wrapped + inside an UNWIND-PROTECT. * bug fix: sb-posix should now compile again under Windows, enabling slime to work again. diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp index efee375..3c131b9 100644 --- a/src/compiler/fndb.lisp +++ b/src/compiler/fndb.lisp @@ -1520,10 +1520,10 @@ ;;;; ALIEN and call-out-to-C stuff -;;; 'unsafe' attribute because we store the arg on the stack, which is in -;;; some sense 'passing it upwards' -(defknown sb!vm::push-word-on-c-stack (system-area-pointer) (values) (unsafe)) -(defknown sb!vm::pop-words-from-c-stack (index) (values) ()) +;; Used by WITH-PINNED-OBJECTS +#!+(or x86 x86-64) +(defknown sb!vm::touch-object (t) (values) + (unsafe always-translatable)) #!+linkage-table (defknown foreign-symbol-dataref-sap (simple-string) diff --git a/src/compiler/x86-64/c-call.lisp b/src/compiler/x86-64/c-call.lisp index 807e547..0589617 100644 --- a/src/compiler/x86-64/c-call.lisp +++ b/src/compiler/x86-64/c-call.lisp @@ -335,27 +335,16 @@ (- other-pointer-lowtag))) 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))) +;;; 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) - (: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 60))) - (:info number) - (:policy :fast-safe) - (:generator 2 - (inst add rsp-tn (fixnumize number)))) + (:arg-types t) + (:generator 0)) ;;; Callbacks diff --git a/src/compiler/x86-64/macros.lisp b/src/compiler/x86-64/macros.lisp index 5bcb03a..e150e7e 100644 --- a/src/compiler/x86-64/macros.lisp +++ b/src/compiler/x86-64/macros.lisp @@ -529,22 +529,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 `(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))) diff --git a/src/compiler/x86/c-call.lisp b/src/compiler/x86/c-call.lisp index f6de0de..8c756b3 100644 --- a/src/compiler/x86/c-call.lisp +++ b/src/compiler/x86/c-call.lisp @@ -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))) +;;; 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) - (: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) - (: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) diff --git a/src/compiler/x86/macros.lisp b/src/compiler/x86/macros.lisp index 4c1fba6..71440fc 100644 --- a/src/compiler/x86/macros.lisp +++ b/src/compiler/x86/macros.lisp @@ -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))) diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp index f91feb3..9431e70 100644 --- a/tests/compiler.impure.lisp +++ b/tests/compiler.impure.lisp @@ -1462,4 +1462,53 @@ (assert (equal '(0 1) (multiple-value-list (local-copy-prop-bug-with-move-arg nil)))) (assert (equal '(1 0) (multiple-value-list (local-copy-prop-bug-with-move-arg t)))) +;;;; with-pinned-objects & unwind-protect, using all non-tail conventions + +(defun wpo-quux () (list 1 2 3)) +(defvar *wpo-quux* #'wpo-quux) + +(defun wpo-call () + (unwind-protect + (sb-sys:with-pinned-objects (*wpo-quux*) + (values (funcall *wpo-quux*))))) +(assert (equal '(1 2 3) (wpo-call))) + +(defun wpo-multiple-call () + (unwind-protect + (sb-sys:with-pinned-objects (*wpo-quux*) + (funcall *wpo-quux*)))) +(assert (equal '(1 2 3) (wpo-multiple-call))) + +(defun wpo-call-named () + (unwind-protect + (sb-sys:with-pinned-objects (*wpo-quux*) + (values (wpo-quux))))) +(assert (equal '(1 2 3) (wpo-call-named))) + +(defun wpo-multiple-call-named () + (unwind-protect + (sb-sys:with-pinned-objects (*wpo-quux*) + (wpo-quux)))) +(assert (equal '(1 2 3) (wpo-multiple-call-named))) + +(defun wpo-call-variable (&rest args) + (unwind-protect + (sb-sys:with-pinned-objects (*wpo-quux*) + (values (apply *wpo-quux* args))))) +(assert (equal '(1 2 3) (wpo-call-variable))) + +(defun wpo-multiple-call-variable (&rest args) + (unwind-protect + (sb-sys:with-pinned-objects (*wpo-quux*) + (apply #'wpo-quux args)))) +(assert (equal '(1 2 3) (wpo-multiple-call-named))) + +(defun wpo-multiple-call-local () + (flet ((quux () + (wpo-quux))) + (unwind-protect + (sb-sys:with-pinned-objects (*wpo-quux*) + (quux))))) +(assert (equal '(1 2 3) (wpo-multiple-call-local))) + ;;; success diff --git a/version.lisp-expr b/version.lisp-expr index 22cfe31..3ca6149 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".) -"1.0.11.19" +"1.0.11.20" -- 1.7.10.4