src/code/exhaust.lisp

   1 ;;;; detecting and handling exhaustion of memory (stack or heap)
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; This software is derived from the CMU CL system, which was
   7 ;;;; written at Carnegie Mellon University and released into the
   8 ;;;; public domain. The software is in the public domain and is
   9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  10 ;;;; files for more information.
  11
  12 (in-package "SB!KERNEL")
  13
  14 ;;; A native address on a 4-byte boundary can be thought of (and
  15 ;;; passed around in Lisp code as) a FIXNUM. This function converts
  16 ;;; from a byte address represented as an unsigned integer to such
  17 ;;; a FIXNUM.
  18 ;;;
  19 ;;; FIXME: There should be some better place for this definition to
  20 ;;; go. (Or a redundant definition might already exist. Especially
  21 ;;; since this is essentially just a type pun, so there might be some
  22 ;;; VOP or something which'd do it for us.)
  23 (eval-when (:compile-toplevel :load-toplevel :execute)
  24   (defun native-address-encoded-as-fixnum (native-address)
  25     (declare (type unsigned-byte native-address))
  26     (aver (zerop (logand native-address 3)))
  27     (let* (;; naive encoding
  28            (first-try (ash native-address -2))
  29            ;; final encoding
  30            (second-try
  31             (if (<= first-try sb!xc:most-positive-fixnum)
  32                 ;; looks good
  33                 first-try
  34                 ;; When the naive encoding fails to make a FIXNUM
  35                 ;; because the sign is wrong, subtracting *T-M-P-F*
  36                 ;; should fix it.
  37                 (- first-try sb!xc:most-positive-fixnum))))
  38       (aver (<= second-try sb!xc:most-positive-fixnum))
  39       second-try)))
  40
  41 ;;; a FIXNUM, to be interpreted as a native pointer, which serves
  42 ;;; as a boundary to catch stack overflow
  43 ;;;
  44 ;;; When stack overflow is detected, this is to be bound to a new
  45 ;;; value (allowing some more space for error handling) around the
  46 ;;; call to ERROR.
  47 ;;;
  48 ;;; FIXME: Maybe (probably?) this should be in SB!VM. And maybe the
  49 ;;; size of the buffer zone should be set in src/compiler/cpu/parms.lisp
  50 ;;; instead of constantly 1Mb for all CPU architectures?
  51 (defvar *stack-exhaustion*
  52   ;; (initialized in cold init)
  53   )
  54 (defun !exhaust-cold-init ()
  55   (setf *stack-exhaustion*
  56         #.(native-address-encoded-as-fixnum
  57            #!+stack-grows-downward (+ sb!vm:control-stack-start (expt 2 20))
  58            #!+stack-grows-upward (- sb!vm:control-stack-end (expt 2 20)))))
  59
  60 ;;; FIXME: Even though this is only called when (> SAFETY (MAX SPEED SPACE))
  61 ;;; it's still annoyingly wasteful for it to be a full function call.
  62 ;;; It should probably be a VOP calling an assembly routine or something
  63 ;;; like that.
  64 (defun %detect-stack-exhaustion ()
  65   ;; FIXME: Check the stack pointer against *STACK-EXHAUSTION*, and if
  66   ;; out of range signal an error (in a context where *S-E* has been
  67   ;; rebound to give some space to let error handling code do its
  68   ;; thing without new exhaustion problems).
  69   (values))