Update of /cvsroot/sbcl/sbcl/src/code
In directory usw-pr-cvs1:/tmp/cvs-serv22592/src/code
Modified Files:
cold-init.lisp exhaust.lisp fd-stream.lisp interr.lisp
run-program.lisp stream.lisp toplevel.lisp
Log Message:
0.7.6.1:
Mostly-tested but still considered "experimental" non-invasive
stack exhaustion checking, using a guard page at the end of the
stack and an extra clause in the sigsegv (on some ports, sigbus)
handler. One day there will be an internals doc with the
gory details: for now, try http://ww.telent.net/diary/2002/7/#23.59392
Index: cold-init.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/cold-init.lisp,v
retrieving revision 1.34
retrieving revision 1.35
diff -u -d -r1.34 -r1.35
--- cold-init.lisp 16 Mar 2002 21:16:09 -0000 1.34
+++ cold-init.lisp 23 Jul 2002 17:22:36 -0000 1.35
@@ -99,7 +99,6 @@
*cold-init-complete-p* nil
*type-system-initialized* nil)
- (show-and-call !exhaust-cold-init)
(show-and-call !typecheckfuns-cold-init)
;; Anyone might call RANDOM to initialize a hash value or something;
Index: exhaust.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/exhaust.lisp,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -d -r1.6 -r1.7
--- exhaust.lisp 16 Mar 2002 16:12:32 -0000 1.6
+++ exhaust.lisp 23 Jul 2002 17:22:36 -0000 1.7
@@ -11,63 +11,6 @@
;;;; files for more information.
(in-package "SB!KERNEL")
+(define-alien-routine "protect_control_stack_guard_page"
+ sb!alien:int (protect-p sb!alien:int))
-;;; a soft limit on control stack overflow; the boundary beyond which
-;;; the control stack will be considered to've overflowed
-;;;
-;;; When overflow is detected, this soft limit is to be bound to a new
-;;; value closer to the hard limit (allowing some more space for error
-;;; handling) around the call to ERROR, to allow space for the
-;;; error-handling logic.
-;;;
-;;; FIXME: Maybe (probably?) this should be in SB!VM. And maybe the
-;;; size of the buffer zone should be set in src/compiler/cpu/parms.lisp
-;;; instead of constantly 1Mb for all CPU architectures?
-(defvar *control-stack-exhaustion-sap*
- ;; (initialized in cold init)
- )
-(defun !exhaust-cold-init ()
- (let (;; initial difference between soft limit and hard limit
- (initial-slack (expt 2 20)))
- (setf *control-stack-exhaustion-sap*
- (int-sap #!+stack-grows-downward-not-upward
- (+ sb!vm:control-stack-start initial-slack)
- #!-stack-grows-downward-not-upward
- (- sb!vm:control-stack-end initial-slack)))))
-
-;;; FIXME: Even though this is only called when (> SAFETY (MAX SPEED SPACE))
-;;; it's still annoyingly wasteful for it to be a full function call.
-;;; It should probably be a VOP calling an assembly routine or something
-;;; like that.
-(defun %detect-stack-exhaustion ()
- (when (#!-stack-grows-downward-not-upward sap>=
- #!+stack-grows-downward-not-upward sap<=
- (current-sp)
- *control-stack-exhaustion-sap*)
- (let ((*control-stack-exhaustion-sap*
- (revised-control-stack-exhaustion-sap)))
- (warn "~@<ordinary control stack soft limit temporarily displaced to ~
- allow possible interactive debugging~@:>")
- (error "The system control stack was exhausted.")))
- ;; FIXME: It'd be good to check other stacks (e.g. binding stack)
- ;; here too.
- )
-
-;;; Return a revised value for the *CONTROL-STACK-EXHAUSTION-SAP* soft
-;;; limit, allocating half the remaining space up to the hard limit in
-;;; order to allow interactive debugging to be used around the point
-;;; of a stack overflow failure without immediately failing again from
-;;; the (continuing) stack overflow.
-(defun revised-control-stack-exhaustion-sap ()
- (let* ((old-slack
- #!-stack-grows-downward-not-upward
- (- sb!vm:control-stack-end
- (sap-int *control-stack-exhaustion-sap*))
- #!+stack-grows-downward-not-upward
- (- (sap-int *control-stack-exhaustion-sap*)
- sb!vm:control-stack-start))
- (new-slack (ash old-slack -1)))
- (int-sap #!-stack-grows-downward-not-upward
- (- sb!vm:control-stack-end new-slack)
- #!+stack-grows-downward-not-upward
- (+ sb!vm:control-stack-start new-slack))))
Index: fd-stream.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/fd-stream.lisp,v
retrieving revision 1.26
retrieving revision 1.27
diff -u -d -r1.26 -r1.27
--- fd-stream.lisp 15 Jul 2002 20:52:47 -0000 1.26
+++ fd-stream.lisp 23 Jul 2002 17:22:36 -0000 1.27
@@ -369,6 +369,9 @@
(if (stringp thing)
(let ((last-newline (and (find #\newline (the simple-string thing)
:start start :end end)
+ ;; FIXME why do we need both calls?
+ ;; Is find faster forwards than
+ ;; position is backwards?
(position #\newline (the simple-string thing)
:from-end t
:start start
@@ -1079,7 +1082,7 @@
(:io (values t t sb!unix:o_rdwr))
(:probe (values t nil sb!unix:o_rdonly)))
(declare (type index mask))
- (let* ((pathname (merge-pathnames filename))
+ (let* ((pathname (pathname filename))
(namestring
(cond ((unix-namestring pathname input))
((and input (eq if-does-not-exist :create))
Index: interr.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/interr.lisp,v
retrieving revision 1.19
retrieving revision 1.20
diff -u -d -r1.19 -r1.20
--- interr.lisp 7 Mar 2002 02:02:24 -0000 1.19
+++ interr.lisp 23 Jul 2002 17:22:36 -0000 1.20
@@ -482,3 +482,12 @@
arguments))))
(t
(funcall handler name fp alien-context arguments)))))))))
+
+(defun control-stack-exhausted-error ()
+ (let ((sb!debug:*stack-top-hint* nil))
+ (infinite-error-protect
+ (format *error-output*
+ "Control stack guard page temporarily disabled: proceed with caution~%")
+ (error "Control stack exhausted (no more space for function call frames). This is probably due to heavily nested or infinitely recursive function calls, or a tail call that SBCL cannot or has not optimized away."))))
+
+
Index: run-program.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/run-program.lisp,v
retrieving revision 1.28
retrieving revision 1.29
diff -u -d -r1.28 -r1.29
--- run-program.lisp 25 Mar 2002 18:25:03 -0000 1.28
+++ run-program.lisp 23 Jul 2002 17:22:36 -0000 1.29
@@ -425,6 +425,7 @@
(stderr sb-alien:int))
;;; Is UNIX-FILENAME the name of a file that we can execute?
+;;; XXX does this actually work for symlinks?
(defun unix-filename-is-executable-p (unix-filename)
(declare (type simple-string unix-filename))
(values (and (eq (sb-unix:unix-file-kind unix-filename) :file)
Index: stream.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/stream.lisp,v
retrieving revision 1.27
retrieving revision 1.28
diff -u -d -r1.27 -r1.28
--- stream.lisp 8 Feb 2002 23:10:25 -0000 1.27
+++ stream.lisp 23 Jul 2002 17:22:36 -0000 1.28
@@ -1153,6 +1153,7 @@
(if (null arg1)
(string-output-stream-index stream)))
(:charpos
+ ;; FIXME there's some reason we can't do this with POSITION?
(do ((index (1- (the fixnum (string-output-stream-index stream)))
(1- index))
(count 0 (1+ count))
Index: toplevel.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/toplevel.lisp,v
retrieving revision 1.29
retrieving revision 1.30
diff -u -d -r1.29 -r1.30
--- toplevel.lisp 6 Jun 2002 14:08:09 -0000 1.29
+++ toplevel.lisp 23 Jul 2002 17:22:36 -0000 1.30
@@ -152,75 +152,89 @@
;;; Zero the unused portion of the control stack so that old objects
;;; are not kept alive because of uninitialized stack variables.
-;;;
-;;; FIXME: Why do we need to do this instead of just letting GC read
-;;; the stack pointer and avoid messing with the unused portion of
-;;; the control stack? (Is this a multithreading thing where there's
-;;; one control stack and stack pointer per thread, and it might not
-;;; be easy to tell what a thread's stack pointer value is when
-;;; looking in from another thread?)
+
+;;; "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
- (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 ((= offset bytes-per-scrub-unit)
- (look (sap+ ptr bytes-per-scrub-unit) 0 count))
- (t
- (setf (sap-ref-32 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 ((= offset bytes-per-scrub-unit)
- count)
- ((zerop (sap-ref-32 ptr offset))
- (look ptr (+ offset sb!vm:n-word-bytes) count))
- (t
- (scrub ptr offset (+ count sb!vm:n-word-bytes))))))
- (let* ((csp (sap-int (sb!c::control-stack-pointer-sap)))
- (initial-offset (logand csp (1- bytes-per-scrub-unit))))
+ (let* ((csp (sap-int (sb!c::control-stack-pointer-sap)))
+ (initial-offset (logand csp (1- bytes-per-scrub-unit)))
+ (end-of-stack
+ (- sb!vm:control-stack-end sb!c:*backend-page-size*)))
+ (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-32 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-32 ptr offset))
+ (look ptr (+ offset sb!vm:n-word-bytes) count))
+ (t
+ (scrub ptr offset (+ count sb!vm:n-word-bytes))))))
(declare (type (unsigned-byte 32) 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
- (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 ((= 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-32 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 ((= 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)))))))
- (let* ((csp (sap-int (sb!c::control-stack-pointer-sap)))
- (initial-offset (logand csp (1- bytes-per-scrub-unit))))
+ (let* ((csp (sap-int (sb!c::control-stack-pointer-sap)))
+ (end-of-stack (+ sb!vm:control-stack-start sb!c:*backend-page-size*))
+ (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-32 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 (unsigned-byte 32) csp))
(scrub (int-sap (+ csp initial-offset))
(* (floor initial-offset sb!vm:n-word-bytes) sb!vm:n-word-bytes)
@@ -485,6 +499,10 @@
"Reduce debugger level (leaving debugger, returning to toplevel).")
(catch 'toplevel-catcher
#!-sunos (sb!unix:unix-sigsetmask 0) ; FIXME: What is this for?
+ ;; in the event of a control-stack-exhausted-error, we should
+ ;; have unwound enough stack by the time we get here that this
+ ;; is now possible
+ (sb!kernel::protect-control-stack-guard-page 1)
(repl noprint)
(critically-unreachable "after REPL")))))))
@@ -492,10 +510,7 @@
(/show0 "entering REPL")
(let ((eof-marker (cons :eof nil)))
(loop
- ;; FIXME: It seems bad to have GC behavior depend on scrubbing the
- ;; control stack before each interactive command. Isn't there some
- ;; way we can convince the GC to just ignore dead areas of the
- ;; control stack, so that we don't need to rely on this half-measure?
+ ;; see comment preceding definition of SCRUB-CONTROL-STACK
(scrub-control-stack)
(unless noprint
(fresh-line)
|