[Sbcl-commits] CVS: sbcl/src/code exhaust.lisp, 1.13, 1.14 gc.lisp, 1.86, 1.87 toplevel.lisp, 1.105, 1.106

[Gabor M. <me...@us...>]

Update of /cvsroot/sbcl/sbcl/src/code
In directory fdv4jf1.ch3.sourceforge.com:/tmp/cvs-serv9113/src/code

Modified Files:
	exhaust.lisp gc.lisp toplevel.lisp 
Log Message:
1.0.29.32: SCRUB-CONTROL-STACK related changes

- remove unused count logic from SCRUB-CONTROL-STACK

- fix SCRUB-CONTROL-STACK being uncareful about touching the guard
  page

- threads stopped by gc do a quick scrubbing of the control stack to
  slightly lessen the probability of uninitialized stack locations
  pointing to live objects


Index: exhaust.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/exhaust.lisp,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -d -r1.13 -r1.14
--- exhaust.lisp	16 Feb 2009 22:23:08 -0000	1.13
+++ exhaust.lisp	22 Jun 2009 12:58:23 -0000	1.14
@@ -11,10 +11,4 @@
 ;;;; files for more information.
 
 (in-package "SB!KERNEL")
-(define-alien-routine ("protect_control_stack_guard_page"
-                       %protect-control-stack-guard-page)
-    sb!alien:void
-  (protect-p sb!alien:int)
-  (thread sb!alien:int))
-(defun protect-control-stack-guard-page (n)
-  (%protect-control-stack-guard-page (if n 1 0) 0))
+(define-alien-routine reset-control-stack-guard-page sb!alien:void)

Index: gc.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/gc.lisp,v
retrieving revision 1.86
retrieving revision 1.87
diff -u -d -r1.86 -r1.87
--- gc.lisp	8 May 2009 19:08:07 -0000	1.86
+++ gc.lisp	22 Jun 2009 12:58:23 -0000	1.87
@@ -285,6 +285,8 @@
   (when (sub-gc :gen (if full 6 gen))
     (post-gc)))
 
+(define-alien-routine scrub-control-stack sb!alien:void)
+
 (defun unsafe-clear-roots ()
   ;; KLUDGE: Do things in an attempt to get rid of extra roots. Unsafe
   ;; as having these cons more then we have space left leads to huge

Index: toplevel.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/toplevel.lisp,v
retrieving revision 1.105
retrieving revision 1.106
diff -u -d -r1.105 -r1.106
--- toplevel.lisp	21 Jun 2009 16:30:33 -0000	1.105
+++ toplevel.lisp	22 Jun 2009 12:58:23 -0000	1.106
@@ -179,103 +179,6 @@
   (sb!win32:millisleep (truncate (* n 1000)))
   nil)
 
-;;;; SCRUB-CONTROL-STACK
-
-(defconstant bytes-per-scrub-unit 2048)
-
-;;; Zero the unused portion of the control stack so that old objects
-;;; are not kept alive because of uninitialized stack variables.
-
-;;; "To summarize the problem, since not all allocated stack frame
-;;; slots are guaranteed to be written by the time you call an another
-;;; function or GC, there may be garbage pointers retained in your
-;;; dead stack locations.  The stack scrubbing only affects the part
-;;; of the stack from the SP to the end of the allocated stack."
-;;; - ram, on cmucl-imp, Tue, 25 Sep 2001
-
-;;; So, as an (admittedly lame) workaround, from time to time we call
-;;; scrub-control-stack to zero out all the unused portion.  This is
-;;; supposed to happen when the stack is mostly empty, so that we have
-;;; a chance of clearing more of it: callers are currently (2002.07.18)
-;;; REPL and SUB-GC
-
-(defun scrub-control-stack ()
-  (declare (optimize (speed 3) (safety 0))
-           (values (unsigned-byte 20))) ; FIXME: DECLARE VALUES?
-
-  #!-stack-grows-downward-not-upward
-  (let* ((csp (sap-int (sb!c::control-stack-pointer-sap)))
-         (initial-offset (logand csp (1- bytes-per-scrub-unit)))
-         (end-of-stack
-          (- (sap-int (sb!di::descriptor-sap sb!vm:*control-stack-end*))
-             (* 2 sb!c:*backend-page-bytes*))))
-    (labels
-        ((scrub (ptr offset count)
-           (declare (type system-area-pointer ptr)
-                    (type (unsigned-byte 16) offset)
-                    (type (unsigned-byte 20) count)
-                    (values (unsigned-byte 20)))
-           (cond ((>= (sap-int ptr) end-of-stack) 0)
-                 ((= offset bytes-per-scrub-unit)
-                  (look (sap+ ptr bytes-per-scrub-unit) 0 count))
-                 (t
-                  (setf (sap-ref-word ptr offset) 0)
-                  (scrub ptr (+ offset sb!vm:n-word-bytes) count))))
-         (look (ptr offset count)
-           (declare (type system-area-pointer ptr)
-                    (type (unsigned-byte 16) offset)
-                    (type (unsigned-byte 20) count)
-                    (values (unsigned-byte 20)))
-           (cond ((>= (sap-int ptr) end-of-stack) 0)
-                 ((= offset bytes-per-scrub-unit)
-                  count)
-                 ((zerop (sap-ref-word ptr offset))
-                  (look ptr (+ offset sb!vm:n-word-bytes) count))
-                 (t
-                  (scrub ptr offset (+ count sb!vm:n-word-bytes))))))
-      (declare (type sb!vm::word csp))
-      (scrub (int-sap (- csp initial-offset))
-             (* (floor initial-offset sb!vm:n-word-bytes) sb!vm:n-word-bytes)
-             0)))
-
-  #!+stack-grows-downward-not-upward
-  (let* ((csp (sap-int (sb!c::control-stack-pointer-sap)))
-         (end-of-stack (+ (sap-int
-                           (sb!di::descriptor-sap sb!vm:*control-stack-start*))
-                          (* 2 sb!c:*backend-page-bytes*)))
-         (initial-offset (logand csp (1- bytes-per-scrub-unit))))
-    (labels
-        ((scrub (ptr offset count)
-           (declare (type system-area-pointer ptr)
-                    (type (unsigned-byte 16) offset)
-                    (type (unsigned-byte 20) count)
-                    (values (unsigned-byte 20)))
-           (let ((loc (int-sap (- (sap-int ptr) (+ offset sb!vm:n-word-bytes)))))
-             (cond ((< (sap-int loc) end-of-stack) 0)
-                   ((= offset bytes-per-scrub-unit)
-                    (look (int-sap (- (sap-int ptr) bytes-per-scrub-unit))
-                          0 count))
-                   (t ;; need to fix bug in %SET-STACK-REF
-                    (setf (sap-ref-word loc 0) 0)
-                    (scrub ptr (+ offset sb!vm:n-word-bytes) count)))))
-         (look (ptr offset count)
-           (declare (type system-area-pointer ptr)
-                    (type (unsigned-byte 16) offset)
-                    (type (unsigned-byte 20) count)
-                    (values (unsigned-byte 20)))
-           (let ((loc (int-sap (- (sap-int ptr) offset))))
-             (cond ((< (sap-int loc) end-of-stack) 0)
-                   ((= offset bytes-per-scrub-unit)
-                    count)
-                   ((zerop (sb!kernel::get-lisp-obj-address (stack-ref loc 0)))
-                    (look ptr (+ offset sb!vm:n-word-bytes) count))
-                   (t
-                    (scrub ptr offset (+ count sb!vm:n-word-bytes)))))))
-      (declare (type sb!vm::word csp))
-      (scrub (int-sap (+ csp initial-offset))
-             (* (floor initial-offset sb!vm:n-word-bytes) sb!vm:n-word-bytes)
-             0))))
-
 ;;;; the default toplevel function
 
 (defvar / nil
@@ -609,7 +512,7 @@
                    ;; should have unwound enough stack by the time we get
                    ;; here that this is now possible.
                    #!-win32
-                   (sb!kernel::protect-control-stack-guard-page 1)
+                   (sb!kernel::reset-control-stack-guard-page)
                    (funcall repl-fun noprint)
                    (critically-unreachable "after REPL")))))))))