0.7.1.29:

[sbcl.git] / src / code / exhaust.lisp

diff --git a/src/code/exhaust.lisp b/src/code/exhaust.lisp
index 50c5bdb..67f5a38 100644 (file)
--- a/src/code/exhaust.lisp
+++ b/src/code/exhaust.lisp
@@ -11,6 +11,52 @@
 
 (in-package "SB!KERNEL")
 
+;;; A native address on a 4-byte boundary can be thought of (and
+;;; passed around in Lisp code as) a FIXNUM. This function converts
+;;; from a byte address represented as an unsigned integer to such
+;;; a FIXNUM.
+;;;
+;;; FIXME: There should be some better place for this definition to
+;;; go. (Or a redundant definition might already exist. Especially
+;;; since this is essentially just a type pun, so there might be some
+;;; VOP or something which'd do it for us.)
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defun native-address-encoded-as-fixnum (native-address)
+    (declare (type unsigned-byte native-address))
+    (aver (zerop (logand native-address 3)))
+    (let* (;; naive encoding
+          (first-try (ash native-address -2))
+          ;; final encoding
+          (second-try 
+           (if (<= first-try sb!vm:*target-most-positive-fixnum*)
+               ;; looks good
+               first-try
+               ;; When the naive encoding fails to make a FIXNUM
+               ;; because the sign is wrong, subtracting *T-M-P-F*
+               ;; should fix it. 
+               (- first-try sb!vm:*target-most-positive-fixnum*))))
+      (aver (<= second-try sb!vm:*target-most-positive-fixnum*))
+      second-try)))
+
+;;; a FIXNUM, to be interpreted as a native pointer, which serves
+;;; as a boundary to catch stack overflow
+;;;
+;;; When stack overflow is detected, this is to be bound to a new
+;;; value (allowing some more space for error handling) around the
+;;; call to ERROR.
+;;;
+;;; FIXME: Maybe (probably?) this should be in SB!VM. And maybe the
+;;; size of the buffer zone should be set in src/compiler/cpu/parms.lisp
+;;; instead of constantly 1Mb for all CPU architectures?
+(defvar *stack-exhaustion*
+  ;; (initialized in cold init)
+  )
+(defun !exhaust-cold-init ()
+  (setf *stack-exhaustion*
+       #.(native-address-encoded-as-fixnum
+          #!+stack-grows-downward (+ sb!vm:control-stack-start (expt 2 20))
+          #!+stack-grows-upward (- sb!vm:control-stack-end (expt 2 20)))))
+  
 ;;; FIXME: Even though this is only called when (> SAFETY (MAX SPEED SPACE))
 ;;; it's still annoyingly wasteful for it to be a full function call.
 ;;; It should probably be a VOP calling an assembly routine or something