0.7.5.15:
[sbcl.git] / 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))))