X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fexhaust.lisp;h=25c038e0920434a4988ef72ffaff6421fe5d777f;hb=86210c4e406c1b2ff10cc3bac0e71435867db48b;hp=50c5bdb8f9e8271c5d5d1d2daee543ae7a16cf2c;hpb=08671cc8f003e0b1f9879635fa950c78f7bf40fe;p=sbcl.git

diff --git a/src/code/exhaust.lisp b/src/code/exhaust.lisp
index 50c5bdb..25c038e 100644
--- a/src/code/exhaust.lisp
+++ b/src/code/exhaust.lisp
@@ -1,4 +1,5 @@
-;;;; detecting and handling exhaustion of memory (stack or heap)
+;;;; detecting and handling exhaustion of fundamental system resources
+;;;; (stack or heap)
 
 ;;;; This software is part of the SBCL system. See the README file for
 ;;;; more information.
@@ -11,13 +12,62 @@
 
 (in-package "SB!KERNEL")
 
+;;; 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 ()
-  ;; FIXME: Check the stack pointer against *STACK-EXHAUSTION*, and if
-  ;; out of range signal an error (in a context where *S-E* has been
-  ;; rebound to give some space to let error handling code do its
-  ;; thing without new exhaustion problems).
-  (values))
+  (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))))