From: Nikodemus Siivola Date: Wed, 30 Jul 2008 13:49:08 +0000 (+0000) Subject: 1.0.19.2: fix alien stack leak X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=dc3864367e0ae2964e6e346ff5c4ecfea9ddc0f0;p=sbcl.git 1.0.19.2: fix alien stack leak * On x86oids bind *ALIEN-STACK* once for the entire WITH-ALIEN, obviating the need to release local aliens one-by-one. * On other platforms protect the cleanup with UWP. * :STATIC option has been disabled in WITH-ALIEN for a while now -- not sure why, but remove the corresponding bit from docstring as well. * Test-case by Andy Hefner. --- diff --git a/NEWS b/NEWS index ff32b75..06c67fd 100644 --- a/NEWS +++ b/NEWS @@ -3,6 +3,8 @@ changes in sbcl-1.0.20 relative to 1.0.19: * bug fix: fixed #427: unused local aliens no longer cause compiler breakage. (reported by Stelian Ionescu, Andy Hefner and Stanislaw Halik) + * bug fix: non-local exit from a WITH-ALIEN form no longer causes + alien-stack leakage. (reported by Andy Hefner) changes in sbcl-1.0.19 relative to 1.0.18: * new feature: user-customizable variable SB-EXT:*MUFFLED-WARNINGS*; diff --git a/src/code/target-alieneval.lisp b/src/code/target-alieneval.lisp index 08e8b9e..af463b6 100644 --- a/src/code/target-alieneval.lisp +++ b/src/code/target-alieneval.lisp @@ -90,82 +90,103 @@ ALLOCATION should be one of: :LOCAL (the default) The alien is allocated on the stack, and has dynamic extent. - :STATIC - The alien is allocated on the heap, and has infinite extent. The alien - is allocated at load time, so the same piece of memory is used each time - this form executes. :EXTERN No alien is allocated, but VAR is established as a local name for the external alien given by EXTERNAL-NAME." + ;; FIXME: + ;; :STATIC + ;; The alien is allocated on the heap, and has infinite extent. The alien + ;; is allocated at load time, so the same piece of memory is used each time + ;; this form executes. (/show "entering WITH-ALIEN" bindings) - (with-auxiliary-alien-types env - (dolist (binding (reverse bindings)) - (/show binding) - (destructuring-bind - (symbol type &optional (opt1 nil opt1p) (opt2 nil opt2p)) - binding - (/show symbol type opt1 opt2) - (let* ((alien-type (parse-alien-type type env)) - (datap (not (alien-fun-type-p alien-type)))) - (/show alien-type) - (multiple-value-bind (allocation initial-value) - (if opt2p - (values opt1 opt2) - (case opt1 - (:extern - (values opt1 (guess-alien-name-from-lisp-name symbol))) - (:static - (values opt1 nil)) - (t - (values :local opt1)))) - (/show allocation initial-value) - (setf body - (ecase allocation - #+nil - (:static - (let ((sap - (make-symbol (concatenate 'string "SAP-FOR-" - (symbol-name symbol))))) - `((let ((,sap (load-time-value (%make-alien ...)))) - (declare (type system-area-pointer ,sap)) - (symbol-macrolet - ((,symbol (sap-alien ,sap ,type))) - ,@(when initial-value - `((setq ,symbol ,initial-value))) - ,@body))))) - (:extern - (/show0 ":EXTERN case") - (let ((info (make-heap-alien-info - :type alien-type - :sap-form `(foreign-symbol-sap ',initial-value - ,datap)))) - `((symbol-macrolet - ((,symbol (%heap-alien ',info))) - ,@body)))) - (:local - (/show0 ":LOCAL case") - (let ((var (gensym)) - (initval (if initial-value (gensym))) - (info (make-local-alien-info :type alien-type))) - (/show var initval info) - `((let ((,var (make-local-alien ',info)) + (let (bind-alien-stack) + (with-auxiliary-alien-types env + (dolist (binding (reverse bindings)) + (/show binding) + (destructuring-bind + (symbol type &optional (opt1 nil opt1p) (opt2 nil opt2p)) + binding + (/show symbol type opt1 opt2) + (let* ((alien-type (parse-alien-type type env)) + (datap (not (alien-fun-type-p alien-type)))) + (/show alien-type) + (multiple-value-bind (allocation initial-value) + (if opt2p + (values opt1 opt2) + (case opt1 + (:extern + (values opt1 (guess-alien-name-from-lisp-name symbol))) + (:static + (values opt1 nil)) + (t + (values :local opt1)))) + (/show allocation initial-value) + (setf body + (ecase allocation + #+nil + (:static + (let ((sap + (make-symbol (concatenate 'string "SAP-FOR-" + (symbol-name symbol))))) + `((let ((,sap (load-time-value (%make-alien ...)))) + (declare (type system-area-pointer ,sap)) + (symbol-macrolet + ((,symbol (sap-alien ,sap ,type))) ,@(when initial-value - `((,initval ,initial-value)))) - (note-local-alien-type ',info ,var) - (multiple-value-prog1 - (symbol-macrolet - ((,symbol (local-alien ',info ,var))) - ,@(when initial-value - `((setq ,symbol ,initval))) - ,@body) + `((setq ,symbol ,initial-value))) + ,@body))))) + (:extern + (/show0 ":EXTERN case") + (let ((info (make-heap-alien-info + :type alien-type + :sap-form `(foreign-symbol-sap ',initial-value + ,datap)))) + `((symbol-macrolet + ((,symbol (%heap-alien ',info))) + ,@body)))) + (:local + (/show0 ":LOCAL case") + (let* ((var (gensym)) + (initval (if initial-value (gensym))) + (info (make-local-alien-info :type alien-type)) + (inner-body + `((note-local-alien-type ',info ,var) + (symbol-macrolet ((,symbol (local-alien ',info ,var))) + ,@(when initial-value + `((setq ,symbol ,initval))) + ,@body))) + (body-forms + (if initial-value + `((let ((,initval ,initial-value)) + ,@inner-body)) + inner-body))) + (/show var initval info) + #!+(or x86 x86-64) + (progn + (setf bind-alien-stack t) + `((let ((,var (make-local-alien ',info))) + ,@body-forms))) + ;; FIXME: This version is less efficient then it needs to be, since + ;; it could just save and restore the number-stack pointer once, + ;; instead of doing multiple decrements if there are multiple bindings. + #!-(or x86 x86-64) + `((let (,var) + (unwind-protect + (progn + (setf ,var (make-local-alien ',info)) + (let ((,var ,var)) + ,body-form)) (dispose-local-alien ',info ,var)))))))))))) - (/show "revised" body) - (verify-local-auxiliaries-okay) - (/show0 "back from VERIFY-LOCAL-AUXILIARIES-OK, returning") - `(symbol-macrolet ((&auxiliary-type-definitions& - ,(append *new-auxiliary-types* - (auxiliary-type-definitions env)))) - ,@body))) + (/show "revised" body) + (verify-local-auxiliaries-okay) + (/show0 "back from VERIFY-LOCAL-AUXILIARIES-OK, returning") + `(symbol-macrolet ((&auxiliary-type-definitions& + ,(append *new-auxiliary-types* + (auxiliary-type-definitions env)))) + ,@(if bind-alien-stack + `((let ((sb!vm::*alien-stack* sb!vm::*alien-stack*)) + ,@body)) + body))))) ;;;; runtime C values that don't correspond directly to Lisp types diff --git a/tests/alien.impure.lisp b/tests/alien.impure.lisp index 8eda29a..74da45a 100644 --- a/tests/alien.impure.lisp +++ b/tests/alien.impure.lisp @@ -210,4 +210,20 @@ (values))))) (assert (not (funcall (compile nil fun)))))) +;;; Non-local exit from WITH-ALIEN caused alien stack to be leaked. +(defvar *sap-int*) +(defun try-to-leak-alien-stack (x) + (with-alien ((alien (array (sb-alien:unsigned 8) 72))) + (let ((sap-int (sb-sys:sap-int (alien-sap alien)))) + (if *sap-int* + (assert (= *sap-int* sap-int)) + (setf *sap-int* sap-int))) + (when x + (return-from try-to-leak-alien-stack 'going)) + (never))) +(with-test (:name :nlx-causes-alien-stack-leak) + (let ((*sap-int* nil)) + (loop repeat 1024 + do (try-to-leak-alien-stack t)))) + ;;; success diff --git a/version.lisp-expr b/version.lisp-expr index d60b9a4..57e47ab 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.19.1" +"1.0.19.2"