- ;; 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))))