src/code/exhaust.lisp

   1 ;;;; detecting and handling exhaustion of fundamental system resources
   2 ;;;; (stack or heap)
   3
   4 ;;;; This software is part of the SBCL system. See the README file for
   5 ;;;; more information.
   6 ;;;;
   7 ;;;; This software is derived from the CMU CL system, which was
   8 ;;;; written at Carnegie Mellon University and released into the
   9 ;;;; public domain. The software is in the public domain and is
  10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  11 ;;;; files for more information.
  12
  13 (in-package "SB!KERNEL")
  14
  15 ;;; a soft limit on stack overflow; the boundary beyond which the
  16 ;;; control stack will be considered to've overflowed
  17 ;;;
  18 ;;; When stack overflow is detected, this soft limit is to be bound to
  19 ;;; a new value closer to the hard limit (allowing some more space for
  20 ;;; error handling) around the call to ERROR.
  21 ;;;
  22 ;;; FIXME: Maybe (probably?) this should be in SB!VM. And maybe the
  23 ;;; size of the buffer zone should be set in src/compiler/cpu/parms.lisp
  24 ;;; instead of constantly 1Mb for all CPU architectures?
  25 (defvar *stack-exhaustion-sap*
  26   ;; (initialized in cold init)
  27   )
  28 (defun !exhaust-cold-init ()
  29   (let (;; initial difference between soft limit and hard limit
  30         (initial-slack (expt 2 20)))
  31     (setf *stack-exhaustion-sap*
  32           (int-sap #!+stack-grows-downward (+ sb!vm:control-stack-start
  33                                               initial-slack)
  34                    #!+stack-grows-upward (- sb!vm:control-stack-end
  35                                             initial-slack)))))
  36
  37 ;;; FIXME: Even though this is only called when (> SAFETY (MAX SPEED SPACE))
  38 ;;; it's still annoyingly wasteful for it to be a full function call.
  39 ;;; It should probably be a VOP calling an assembly routine or something
  40 ;;; like that.
  41 (defun %detect-stack-exhaustion ()
  42   (when (#!+stack-grows-upward sap>=
  43          #!+stack-grows-downward sap<=
  44          (current-sp)
  45          *stack-exhaustion-sap*)
  46     (let ((*stack-exhaustion-sap* (revised-stack-exhaustion-sap)))
  47       (warn "~@<ordinary control stack soft limit temporarily displaced to ~
  48              allow possible interactive debugging~@:>")
  49       (error "The system control stack was exhausted."))))
  50
  51 ;;; Return a revised value for the *STACK-EXHAUSTION-SAP* soft limit,
  52 ;;; allocating half the remaining space up to the hard limit in order
  53 ;;; to allow interactive debugging to be used around the point of a
  54 ;;; stack overflow failure without immediately failing again from the
  55 ;;; (continuing) stack overflow.
  56 (defun revised-stack-exhaustion-sap ()
  57   (let* ((old-slack
  58           #!+stack-grows-upward (- sb!vm:control-stack-end
  59                                    (sap-int *stack-exhaustion-sap*))
  60           #!+stack-grows-downward (- (sap-int *stack-exhaustion-sap*)
  61                                      sb!vm:control-stack-start))
  62          (new-slack (ash old-slack -1)))
  63     (int-sap
  64      #!+stack-grows-upward (- sb!vm:control-stack-end new-slack)
  65      #!+stack-grows-downward (+ sb!vm:control-stack-start new-slack))))