X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fexhaust.lisp;h=7de2f007085623ee139b3a457b7c35ae4f4c4c55;hb=860543cc7ba0266e41e1d41ac9b6a208f3795f1a;hp=25c038e0920434a4988ef72ffaff6421fe5d777f;hpb=aca45f35fc54bc29e2c79397e3538ff27f6e0db9;p=sbcl.git

diff --git a/src/code/exhaust.lisp b/src/code/exhaust.lisp
index 25c038e..7de2f00 100644
--- a/src/code/exhaust.lisp
+++ b/src/code/exhaust.lisp
@@ -11,63 +11,11 @@
 ;;;; files for more information.
 
 (in-package "SB!KERNEL")
+(define-alien-routine ("protect_control_stack_guard_page"
+		       %protect-control-stack-guard-page)
+    sb!alien:int (thread-id sb!alien:int) (protect-p sb!alien:int))
+(defun protect-control-stack-guard-page (n)
+  (%protect-control-stack-guard-page 
+   (sb!thread:current-thread-id) (if n 1 0)))
 
-;;; 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))))