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 control stack overflow; the boundary beyond which
  16 ;;; the control stack will be considered to've overflowed
  17 ;;;
  18 ;;; When overflow is detected, this soft limit is to be bound to a new
  19 ;;; value closer to the hard limit (allowing some more space for error
  20 ;;; handling) around the call to ERROR, to allow space for the
  21 ;;; error-handling logic.
  22 ;;;
  23 ;;; FIXME: Maybe (probably?) this should be in SB!VM. And maybe the
  24 ;;; size of the buffer zone should be set in src/compiler/cpu/parms.lisp
  25 ;;; instead of constantly 1Mb for all CPU architectures?
  26 (defvar *control-stack-exhaustion-sap*
  27   ;; (initialized in cold init)
  28   )
  29 (defun !exhaust-cold-init ()
  30   (let (;; initial difference between soft limit and hard limit
  31         (initial-slack (expt 2 20)))
  32     (setf *control-stack-exhaustion-sap*
  33           (int-sap #!+stack-grows-downward-not-upward
  34                    (+ sb!vm:control-stack-start initial-slack)
  35                    #!-stack-grows-downward-not-upward
  36                    (- sb!vm:control-stack-end initial-slack)))))
  37
  38 ;;; FIXME: Even though this is only called when (> SAFETY (MAX SPEED SPACE))
  39 ;;; it's still annoyingly wasteful for it to be a full function call.
  40 ;;; It should probably be a VOP calling an assembly routine or something
  41 ;;; like that.
  42 (defun %detect-stack-exhaustion ()
  43   (when (#!-stack-grows-downward-not-upward sap>=
  44          #!+stack-grows-downward-not-upward sap<=
  45          (current-sp)
  46          *control-stack-exhaustion-sap*)
  47     (let ((*control-stack-exhaustion-sap*
  48            (revised-control-stack-exhaustion-sap)))
  49       (warn "~@<ordinary control stack soft limit temporarily displaced to ~
  50              allow possible interactive debugging~@:>")
  51       (error "The system control stack was exhausted.")))
  52   ;; FIXME: It'd be good to check other stacks (e.g. binding stack)
  53   ;; here too.
  54   )
  55
  56 ;;; Return a revised value for the *CONTROL-STACK-EXHAUSTION-SAP* soft
  57 ;;; limit, allocating half the remaining space up to the hard limit in
  58 ;;; order to allow interactive debugging to be used around the point
  59 ;;; of a stack overflow failure without immediately failing again from
  60 ;;; the (continuing) stack overflow.
  61 (defun revised-control-stack-exhaustion-sap ()
  62   (let* ((old-slack
  63           #!-stack-grows-downward-not-upward
  64           (- sb!vm:control-stack-end
  65              (sap-int *control-stack-exhaustion-sap*))
  66           #!+stack-grows-downward-not-upward
  67           (- (sap-int *control-stack-exhaustion-sap*)
  68              sb!vm:control-stack-start))
  69          (new-slack (ash old-slack -1)))
  70     (int-sap #!-stack-grows-downward-not-upward
  71              (- sb!vm:control-stack-end new-slack)
  72              #!+stack-grows-downward-not-upward
  73              (+ sb!vm:control-stack-start new-slack))))