# if we're building for x86. -- CSR, 2002-02-21 Then we do something
# similar with :STACK-GROWS-FOOWARD, too. -- WHN 2002-03-03
if [ "$sbcl_arch" = "x86" ] ; then
- printf ' :gencgc :stack-grows-downward-not-upward' >> $ltf
+ printf ' :gencgc :stack-grows-downward-not-upward :c-stack-is-control-stack' >> $ltf
else
# Nothing need be done in this case, but sh syntax wants a placeholder.
echo > /dev/null
"BINDING-STACK-START" "BINDING-STACK-END"
"CONTROL-STACK-START" "CONTROL-STACK-END"
"DYNAMIC-SPACE-START" "DYNAMIC-SPACE-END"
+ #!+c-stack-is-control-stack "ALTERNATE-SIGNAL-STACK-START"
#!-gencgc "DYNAMIC-0-SPACE-START"
#!-gencgc "DYNAMIC-0-SPACE-END"
#!-gencgc "DYNAMIC-1-SPACE-START"
*cold-init-complete-p* nil
*type-system-initialized* nil)
- (show-and-call !exhaust-cold-init)
(show-and-call !typecheckfuns-cold-init)
;; Anyone might call RANDOM to initialize a hash value or something;
;;;; files for more information.
(in-package "SB!KERNEL")
+(define-alien-routine "protect_control_stack_guard_page"
+ sb!alien:int (protect-p sb!alien:int))
-;;; a soft limit on control stack overflow; the boundary beyond which
-;;; the control stack will be considered to've overflowed
-;;;
-;;; When overflow is detected, this soft limit is to be bound to a new
-;;; value closer to the hard limit (allowing some more space for error
-;;; handling) around the call to ERROR, to allow space for the
-;;; error-handling logic.
-;;;
-;;; 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 *control-stack-exhaustion-sap*
- ;; (initialized in cold init)
- )
-(defun !exhaust-cold-init ()
- (let (;; initial difference between soft limit and hard limit
- (initial-slack (expt 2 20)))
- (setf *control-stack-exhaustion-sap*
- (int-sap #!+stack-grows-downward-not-upward
- (+ sb!vm:control-stack-start initial-slack)
- #!-stack-grows-downward-not-upward
- (- sb!vm:control-stack-end initial-slack)))))
-
-;;; 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
-;;; like that.
-(defun %detect-stack-exhaustion ()
- (when (#!-stack-grows-downward-not-upward sap>=
- #!+stack-grows-downward-not-upward sap<=
- (current-sp)
- *control-stack-exhaustion-sap*)
- (let ((*control-stack-exhaustion-sap*
- (revised-control-stack-exhaustion-sap)))
- (warn "~@<ordinary control stack soft limit temporarily displaced to ~
- allow possible interactive debugging~@:>")
- (error "The system control stack was exhausted.")))
- ;; FIXME: It'd be good to check other stacks (e.g. binding stack)
- ;; here too.
- )
-
-;;; Return a revised value for the *CONTROL-STACK-EXHAUSTION-SAP* soft
-;;; limit, allocating half the remaining space up to the hard limit in
-;;; order to allow interactive debugging to be used around the point
-;;; of a stack overflow failure without immediately failing again from
-;;; the (continuing) stack overflow.
-(defun revised-control-stack-exhaustion-sap ()
- (let* ((old-slack
- #!-stack-grows-downward-not-upward
- (- sb!vm:control-stack-end
- (sap-int *control-stack-exhaustion-sap*))
- #!+stack-grows-downward-not-upward
- (- (sap-int *control-stack-exhaustion-sap*)
- sb!vm:control-stack-start))
- (new-slack (ash old-slack -1)))
- (int-sap #!-stack-grows-downward-not-upward
- (- sb!vm:control-stack-end new-slack)
- #!+stack-grows-downward-not-upward
- (+ sb!vm:control-stack-start new-slack))))
(if (stringp thing)
(let ((last-newline (and (find #\newline (the simple-string thing)
:start start :end end)
+ ;; FIXME why do we need both calls?
+ ;; Is find faster forwards than
+ ;; position is backwards?
(position #\newline (the simple-string thing)
:from-end t
:start start
(:io (values t t sb!unix:o_rdwr))
(:probe (values t nil sb!unix:o_rdonly)))
(declare (type index mask))
- (let* ((pathname (merge-pathnames filename))
+ (let* ((pathname (pathname filename))
(namestring
(cond ((unix-namestring pathname input))
((and input (eq if-does-not-exist :create))
arguments))))
(t
(funcall handler name fp alien-context arguments)))))))))
+
+(defun control-stack-exhausted-error ()
+ (let ((sb!debug:*stack-top-hint* nil))
+ (infinite-error-protect
+ (format *error-output*
+ "Control stack guard page temporarily disabled: proceed with caution~%")
+ (error "Control stack exhausted (no more space for function call frames). This is probably due to heavily nested or infinitely recursive function calls, or a tail call that SBCL cannot or has not optimized away."))))
+
+
(stderr sb-alien:int))
;;; Is UNIX-FILENAME the name of a file that we can execute?
+;;; XXX does this actually work for symlinks?
(defun unix-filename-is-executable-p (unix-filename)
(declare (type simple-string unix-filename))
(values (and (eq (sb-unix:unix-file-kind unix-filename) :file)
(if (null arg1)
(string-output-stream-index stream)))
(:charpos
+ ;; FIXME there's some reason we can't do this with POSITION?
(do ((index (1- (the fixnum (string-output-stream-index stream)))
(1- index))
(count 0 (1+ count))
;;; Zero the unused portion of the control stack so that old objects
;;; are not kept alive because of uninitialized stack variables.
-;;;
-;;; FIXME: Why do we need to do this instead of just letting GC read
-;;; the stack pointer and avoid messing with the unused portion of
-;;; the control stack? (Is this a multithreading thing where there's
-;;; one control stack and stack pointer per thread, and it might not
-;;; be easy to tell what a thread's stack pointer value is when
-;;; looking in from another thread?)
+
+;;; "To summarize the problem, since not all allocated stack frame
+;;; slots are guaranteed to be written by the time you call an another
+;;; function or GC, there may be garbage pointers retained in your
+;;; dead stack locations. The stack scrubbing only affects the part
+;;; of the stack from the SP to the end of the allocated stack."
+;;; - ram, on cmucl-imp, Tue, 25 Sep 2001
+
+;;; So, as an (admittedly lame) workaround, from time to time we call
+;;; scrub-control-stack to zero out all the unused portion. This is
+;;; supposed to happen when the stack is mostly empty, so that we have
+;;; a chance of clearing more of it: callers are currently (2002.07.18)
+;;; REPL and SUB-GC
+
(defun scrub-control-stack ()
(declare (optimize (speed 3) (safety 0))
(values (unsigned-byte 20))) ; FIXME: DECLARE VALUES?
#!-stack-grows-downward-not-upward
- (labels
- ((scrub (ptr offset count)
- (declare (type system-area-pointer ptr)
- (type (unsigned-byte 16) offset)
- (type (unsigned-byte 20) count)
- (values (unsigned-byte 20)))
- (cond ((= offset bytes-per-scrub-unit)
- (look (sap+ ptr bytes-per-scrub-unit) 0 count))
- (t
- (setf (sap-ref-32 ptr offset) 0)
- (scrub ptr (+ offset sb!vm:n-word-bytes) count))))
- (look (ptr offset count)
- (declare (type system-area-pointer ptr)
- (type (unsigned-byte 16) offset)
- (type (unsigned-byte 20) count)
- (values (unsigned-byte 20)))
- (cond ((= offset bytes-per-scrub-unit)
- count)
- ((zerop (sap-ref-32 ptr offset))
- (look ptr (+ offset sb!vm:n-word-bytes) count))
- (t
- (scrub ptr offset (+ count sb!vm:n-word-bytes))))))
- (let* ((csp (sap-int (sb!c::control-stack-pointer-sap)))
- (initial-offset (logand csp (1- bytes-per-scrub-unit))))
+ (let* ((csp (sap-int (sb!c::control-stack-pointer-sap)))
+ (initial-offset (logand csp (1- bytes-per-scrub-unit)))
+ (end-of-stack
+ (- sb!vm:control-stack-end sb!c:*backend-page-size*)))
+ (labels
+ ((scrub (ptr offset count)
+ (declare (type system-area-pointer ptr)
+ (type (unsigned-byte 16) offset)
+ (type (unsigned-byte 20) count)
+ (values (unsigned-byte 20)))
+ (cond ((>= (sap-int ptr) end-of-stack) 0)
+ ((= offset bytes-per-scrub-unit)
+ (look (sap+ ptr bytes-per-scrub-unit) 0 count))
+ (t
+ (setf (sap-ref-32 ptr offset) 0)
+ (scrub ptr (+ offset sb!vm:n-word-bytes) count))))
+ (look (ptr offset count)
+ (declare (type system-area-pointer ptr)
+ (type (unsigned-byte 16) offset)
+ (type (unsigned-byte 20) count)
+ (values (unsigned-byte 20)))
+ (cond ((>= (sap-int ptr) end-of-stack) 0)
+ ((= offset bytes-per-scrub-unit)
+ count)
+ ((zerop (sap-ref-32 ptr offset))
+ (look ptr (+ offset sb!vm:n-word-bytes) count))
+ (t
+ (scrub ptr offset (+ count sb!vm:n-word-bytes))))))
(declare (type (unsigned-byte 32) csp))
(scrub (int-sap (- csp initial-offset))
(* (floor initial-offset sb!vm:n-word-bytes) sb!vm:n-word-bytes)
0)))
#!+stack-grows-downward-not-upward
- (labels
- ((scrub (ptr offset count)
- (declare (type system-area-pointer ptr)
- (type (unsigned-byte 16) offset)
- (type (unsigned-byte 20) count)
- (values (unsigned-byte 20)))
- (let ((loc (int-sap (- (sap-int ptr) (+ offset sb!vm:n-word-bytes)))))
- (cond ((= offset bytes-per-scrub-unit)
- (look (int-sap (- (sap-int ptr) bytes-per-scrub-unit))
- 0 count))
- (t ;; need to fix bug in %SET-STACK-REF
- (setf (sap-ref-32 loc 0) 0)
- (scrub ptr (+ offset sb!vm:n-word-bytes) count)))))
- (look (ptr offset count)
- (declare (type system-area-pointer ptr)
- (type (unsigned-byte 16) offset)
- (type (unsigned-byte 20) count)
- (values (unsigned-byte 20)))
- (let ((loc (int-sap (- (sap-int ptr) offset))))
- (cond ((= offset bytes-per-scrub-unit)
- count)
- ((zerop (sb!kernel::get-lisp-obj-address (stack-ref loc 0)))
- (look ptr (+ offset sb!vm:n-word-bytes) count))
- (t
- (scrub ptr offset (+ count sb!vm:n-word-bytes)))))))
- (let* ((csp (sap-int (sb!c::control-stack-pointer-sap)))
- (initial-offset (logand csp (1- bytes-per-scrub-unit))))
+ (let* ((csp (sap-int (sb!c::control-stack-pointer-sap)))
+ (end-of-stack (+ sb!vm:control-stack-start sb!c:*backend-page-size*))
+ (initial-offset (logand csp (1- bytes-per-scrub-unit))))
+ (labels
+ ((scrub (ptr offset count)
+ (declare (type system-area-pointer ptr)
+ (type (unsigned-byte 16) offset)
+ (type (unsigned-byte 20) count)
+ (values (unsigned-byte 20)))
+ (let ((loc (int-sap (- (sap-int ptr) (+ offset sb!vm:n-word-bytes)))))
+ (cond ((<= (sap-int loc) end-of-stack) 0)
+ ((= offset bytes-per-scrub-unit)
+ (look (int-sap (- (sap-int ptr) bytes-per-scrub-unit))
+ 0 count))
+ (t ;; need to fix bug in %SET-STACK-REF
+ (setf (sap-ref-32 loc 0) 0)
+ (scrub ptr (+ offset sb!vm:n-word-bytes) count)))))
+ (look (ptr offset count)
+ (declare (type system-area-pointer ptr)
+ (type (unsigned-byte 16) offset)
+ (type (unsigned-byte 20) count)
+ (values (unsigned-byte 20)))
+ (let ((loc (int-sap (- (sap-int ptr) offset))))
+ (cond ((<= (sap-int loc) end-of-stack) 0)
+ ((= offset bytes-per-scrub-unit)
+ count)
+ ((zerop (sb!kernel::get-lisp-obj-address (stack-ref loc 0)))
+ (look ptr (+ offset sb!vm:n-word-bytes) count))
+ (t
+ (scrub ptr offset (+ count sb!vm:n-word-bytes)))))))
(declare (type (unsigned-byte 32) csp))
(scrub (int-sap (+ csp initial-offset))
(* (floor initial-offset sb!vm:n-word-bytes) sb!vm:n-word-bytes)
"Reduce debugger level (leaving debugger, returning to toplevel).")
(catch 'toplevel-catcher
#!-sunos (sb!unix:unix-sigsetmask 0) ; FIXME: What is this for?
+ ;; in the event of a control-stack-exhausted-error, we should
+ ;; have unwound enough stack by the time we get here that this
+ ;; is now possible
+ (sb!kernel::protect-control-stack-guard-page 1)
(repl noprint)
(critically-unreachable "after REPL")))))))
(/show0 "entering REPL")
(let ((eof-marker (cons :eof nil)))
(loop
- ;; FIXME: It seems bad to have GC behavior depend on scrubbing the
- ;; control stack before each interactive command. Isn't there some
- ;; way we can convince the GC to just ignore dead areas of the
- ;; control stack, so that we don't need to rely on this half-measure?
+ ;; see comment preceding definition of SCRUB-CONTROL-STACK
(scrub-control-stack)
(unless noprint
(fresh-line)
\f
;;;; general warm init compilation policy
+#+(and sbcl alpha) ; SBCL/Alpha uses stop-and-copy, and Alphas have lotso RAM.
+(progn
+ (sb!ext::gc-off)
+ (setf (sb!ext::bytes-consed-between-gcs) (* 30 (expt 10 6)))
+ (sb!ext::gc-on)
+ (sb!ext::gc))
+
+
(proclaim '(optimize (compilation-speed 1)
(debug #+sb-show 2 #-sb-show 1)
(inhibit-warnings 2)
;; functions that the C code needs to call
maybe-gc
sb!kernel::internal-error
+ sb!kernel::control-stack-exhausted-error
sb!di::handle-breakpoint
sb!di::handle-fun-end-breakpoint
(cold-fdefinition-object (cold-intern ',symbol)))))
(frob maybe-gc)
(frob internal-error)
+ (frob sb!kernel::control-stack-exhausted-error)
(frob sb!di::handle-breakpoint)
(frob sb!di::handle-fun-end-breakpoint))
(setf (node-lexenv bind) *lexenv*)
(let ((cont1 (make-continuation))
- (cont2 (make-continuation))
- (revised-body (if (policy bind
- (or (> safety
- (max speed space))
- (= safety 3)))
- ;; (Stuffing this in at IR1 level like
- ;; this is pretty crude. And it's
- ;; particularly inefficient to execute
- ;; it on *every* LAMBDA, including
- ;; LET-converted LAMBDAs. Improvements
- ;; are welcome, but meanwhile, when
- ;; SAFETY is high, it's still arguably
- ;; an improvement over the old CMU CL
- ;; approach of doing nothing (waiting
- ;; for evolution to breed careful
- ;; users:-). -- WHN)
- `((%detect-stack-exhaustion)
- ,@body)
- body)))
+ (cont2 (make-continuation)))
(continuation-starts-block cont1)
(link-node-to-previous-continuation bind cont1)
(use-continuation bind cont2)
- (ir1-convert-special-bindings cont2 result
- revised-body
+ (ir1-convert-special-bindings cont2 result body
aux-vars aux-vals (svars)))
(let ((block (continuation-block result)))
;; functions that the C code needs to call
sb!impl::maybe-gc
sb!kernel::internal-error
+ sb!kernel::control-stack-exhausted-error
sb!di::handle-breakpoint
sb!impl::fdefinition-object
;; functions that the C code needs to call
maybe-gc
sb!kernel::internal-error
+ sb!kernel::control-stack-exhausted-error
sb!di::handle-breakpoint
sb!di::handle-fun-end-breakpoint
(def!constant control-stack-end #x57fff000)
(def!constant binding-stack-start #x60000000)
- (def!constant binding-stack-end #x67fff000))
+ (def!constant binding-stack-end #x67fff000)
+ (def!constant alternate-signal-stack-start #x58000000))
#!+bsd
(progn
#!+freebsd #x40000000
#!+openbsd #x48000000)
(def!constant control-stack-end
- #!+freebsd #x47fff000
- #!+openbsd #x4ffff000)
+ #!+freebsd #x43fff000
+ #!+openbsd #x4bfff000)
(def!constant dynamic-space-start
- #!+freebsd #x48000000
- #!+openbsd #x50000000)
- (def!constant dynamic-space-end #x88000000))
+ #!+freebsd #x48000000
+ #!+openbsd #x50000000)
+ (def!constant dynamic-space-end #x88000000)
+ (def!constant alternate-signal-stack-start
+ #!+freebsd #x44000000
+ #!+openbsd #x4c000000))
+
+
+;;; don't need alternate-signal-stack-end : it's -start+SIGSTKSZ
+
;;; Given that NIL is the first thing allocated in static space, we
;;; know its value at compile time:
;; The C startup code must fill these in.
*posix-argv*
- ;; functions that the C code needs to call
+ ;; functions that the C code needs to call. When adding to this list,
+ ;; also add a `frob' form in genesis.lisp finish-symbols.
maybe-gc
sb!kernel::internal-error
+ sb!kernel::control-stack-exhausted-error
sb!di::handle-breakpoint
fdefinition-object
sbcl: ${OBJS}
$(CC) ${LINKFLAGS} ${OS_LINK_FLAGS} -o $@ ${OBJS} ${OS_LIBS} -lm
+
.PHONY: clean all
clean:
- rm -f depend *.o sbcl sbcl.nm core *.tmp ; true
+ -rm -f depend *.o sbcl sbcl.nm core *.tmp
depend: ${C_SRCS} sbcl.h
#else
#error unsupported BSD variant
#endif
- if (!gencgc_handle_wp_violation(fault_addr)) {
- interrupt_handle_now(signal, siginfo, void_context);
- }
+ os_context_t *context = arch_os_get_context(&void_context);
+ if (!gencgc_handle_wp_violation(fault_addr))
+ if(!handle_control_stack_guard_triggered(context,fault_addr))
+ /* FIXME is this context or void_context? not that it */
+ /* makes a difference currently except on linux/sparc */
+ interrupt_handle_now(signal, siginfo, void_context);
}
void
os_install_interrupt_handlers(void)
{
SHOW("os_install_interrupt_handlers()/bsd-os/defined(GENCGC)");
-#if defined __FreeBSD__
- undoably_install_low_level_interrupt_handler(SIGBUS,
- memory_fault_handler);
-#elif defined __OpenBSD__
- undoably_install_low_level_interrupt_handler(SIGSEGV,
+ undoably_install_low_level_interrupt_handler(SIG_MEMORY_FAULT,
memory_fault_handler);
-#else
-#error unsupported BSD variant
-#endif
SHOW("leaving os_install_interrupt_handlers()");
}
* is an mcontext_t, but according to comments by Raymond Wiker in the
* original FreeBSD port of SBCL, that's wrong, it's actually a
* ucontext_t. */
+
typedef ucontext_t os_context_t;
/* As the sbcl-devel message from Raymond Wiker 2000-12-01, FreeBSD
* (unlike Linux and OpenBSD) doesn't let us tweak the CPU's single
* step flag bit by messing with the flags stored in a signal context,
* so we need to implement single stepping in a more roundabout way. */
#define CANNOT_GET_TO_SINGLE_STEP_FLAG
+#define SIG_MEMORY_FAULT SIGBUS
#elif defined __OpenBSD__
typedef struct sigcontext os_context_t;
+#define SIG_MEMORY_FAULT SIGSEGV
#else
#error unsupported BSD variant
#endif
foreign_function_call_active = 1;
/* Initialize the current Lisp state. */
-#ifndef __i386__ /* if stack grows upward */
- current_control_stack_pointer = (lispobj *)CONTROL_STACK_START;
-#else
+#ifdef LISP_FEATURE_STACK_GROWS_DOWNWARD_NOT_UPWARD
current_control_stack_pointer = (lispobj *)CONTROL_STACK_END;
+#else
+ current_control_stack_pointer = (lispobj *)CONTROL_STACK_START;
#endif
current_control_frame_pointer = (lispobj *)0;
#include "dynbind.h"
#include "interr.h"
-
void sigaddset_blockable(sigset_t *s)
{
sigaddset(s, SIGHUP);
* utility routines used by various signal handlers
*/
-void
-fake_foreign_function_call(os_context_t *context)
+void
+build_fake_control_stack_frames(os_context_t *context)
{
- int context_index;
-#ifndef __i386__
+#ifndef LISP_FEATURE_X86
+
lispobj oldcont;
-#endif
- /* Get current Lisp state from context. */
-#ifdef reg_ALLOC
- dynamic_space_free_pointer =
- (lispobj *)(*os_context_register_addr(context, reg_ALLOC));
-#ifdef alpha
- if ((long)dynamic_space_free_pointer & 1) {
- lose("dead in fake_foreign_function_call, context = %x", context);
- }
-#endif
-#endif
-#ifdef reg_BSP
- current_binding_stack_pointer =
- (lispobj *)(*os_context_register_addr(context, reg_BSP));
-#endif
+ /* Build a fake stack frame or frames */
-#ifndef __i386__
- /* Build a fake stack frame. */
current_control_frame_pointer =
(lispobj *)(*os_context_register_addr(context, reg_CSP));
if ((lispobj *)(*os_context_register_addr(context, reg_CFP))
oldcont = (lispobj)(*os_context_register_addr(context, reg_OCFP));
}
}
- /* ### We can't tell whether we are still in the caller if it had
- * to reg_ALLOCate the stack frame due to stack arguments. */
- /* ### Can anything strange happen during return? */
+ /* We can't tell whether we are still in the caller if it had to
+ * allocate a stack frame due to stack arguments. */
+ /* This observation provoked some past CMUCL maintainer to ask
+ * "Can anything strange happen during return?" */
else {
/* normal case */
oldcont = (lispobj)(*os_context_register_addr(context, reg_CFP));
current_control_frame_pointer[2] =
(lispobj)(*os_context_register_addr(context, reg_CODE));
#endif
+}
+
+void
+fake_foreign_function_call(os_context_t *context)
+{
+ int context_index;
+
+ /* Get current Lisp state from context. */
+#ifdef reg_ALLOC
+ dynamic_space_free_pointer =
+ (lispobj *)(*os_context_register_addr(context, reg_ALLOC));
+#ifdef alpha
+ if ((long)dynamic_space_free_pointer & 1) {
+ lose("dead in fake_foreign_function_call, context = %x", context);
+ }
+#endif
+#endif
+#ifdef reg_BSP
+ current_binding_stack_pointer =
+ (lispobj *)(*os_context_register_addr(context, reg_BSP));
+#endif
+
+ build_fake_control_stack_frames(context);
/* Do dynamic binding of the active interrupt context index
* and save the context in the context array. */
* which do bare >> and << for fixnum_value and make_fixnum. */
if (context_index >= MAX_INTERRUPTS) {
- lose("maximum interrupt nesting depth (%d) exceeded",
- MAX_INTERRUPTS);
+ lose("maximum interrupt nesting depth (%d) exceeded", MAX_INTERRUPTS);
}
bind_variable(FREE_INTERRUPT_CONTEXT_INDEX,
if (current_auto_gc_trigger == NULL)
return 0;
else{
- lispobj *badaddr=(lispobj *)arch_get_bad_addr(signal,
- info,
- context);
-
- return (badaddr >= current_auto_gc_trigger &&
- badaddr < current_dynamic_space + DYNAMIC_SPACE_SIZE);
+ void *badaddr=arch_get_bad_addr(signal,info,context);
+ return (badaddr >= (void *)current_auto_gc_trigger &&
+ badaddr <((void *)current_dynamic_space + DYNAMIC_SPACE_SIZE));
}
}
#endif
+/* and similarly for the control stack guard page */
+
+boolean handle_control_stack_guard_triggered(os_context_t *context,void *addr)
+{
+ /* note the os_context hackery here. When the signal handler returns,
+ * it won't go back to what it was doing ... */
+ if(addr>=CONTROL_STACK_GUARD_PAGE &&
+ addr<(CONTROL_STACK_GUARD_PAGE+os_vm_page_size)) {
+ void *function;
+ /* we hit the end of the control stack. disable protection
+ * temporarily so the error handler has some headroom */
+ protect_control_stack_guard_page(0);
+
+ function=
+ &(((struct simple_fun *)
+ native_pointer(SymbolFunction(CONTROL_STACK_EXHAUSTED_ERROR)))
+ ->code);
+
+ /* Build a stack frame showing `interrupted' so that the
+ * user's backtrace makes (as much) sense (as usual) */
+ build_fake_control_stack_frames(context);
+ /* signal handler will "return" to this error-causing function */
+ *os_context_pc_addr(context)= function;
+#ifndef LISP_FEATURE_X86
+ /* this much of the calling convention is common to all
+ non-x86 ports */
+ *os_context_register_addr(context,reg_NARGS)=0;
+ *os_context_register_addr(context,reg_LIP)= function;
+ *os_context_register_addr(context,reg_CFP)=
+ current_control_frame_pointer;
+#ifdef ARCH_HAS_NPC_REGISTER
+ *os_context_register_addr(context,reg_LIP)=
+ 4+*os_context_pc_addr(context);
+#endif
+#endif
+ return 1;
+ }
+ else return 0;
+}
+
#ifndef __i386__
/* This function gets called from the SIGSEGV (for e.g. Linux or
* OpenBSD) or SIGBUS (for e.g. FreeBSD) handler. Here we check
if(current_dynamic_space==old_free_space)
/* MAYBE-GC (as the name suggest) might not. If it
* doesn't, it won't reset the GC trigger either, so we
- * have to do it ourselves. Add small amount of space
- * to tide us over while GC is inhibited
+ * have to do it ourselves. Put it near the end of
+ * dynamic space so we're not running into it continually
*/
set_auto_gc_trigger(DYNAMIC_SPACE_SIZE
-(u32)os_vm_page_size);
sigemptyset(&sa.sa_mask);
sigaddset_blockable(&sa.sa_mask);
sa.sa_flags = SA_SIGINFO | SA_RESTART;
-
+#ifdef LISP_FEATURE_C_STACK_IS_CONTROL_STACK
+ /* Signal handlers are run on the control stack, so if it is exhausted
+ * we had better use an alternate stack for whatever signal tells us
+ * we've exhausted it */
+ if(signal==SIG_MEMORY_FAULT) {
+ stack_t sigstack;
+ sigstack.ss_sp=(void *) ALTERNATE_SIGNAL_STACK_START;
+ sigstack.ss_flags=0;
+ sigstack.ss_size = SIGSTKSZ;
+ sigaltstack(&sigstack,0);
+ sa.sa_flags|=SA_ONSTACK;
+ }
+#endif
+
/* In the case of interrupt handlers which are modified more than
* once, we only save the original unmodified copy. */
if (!old_low_level_signal_handler_state->was_modified) {
extern void interrupt_handle_pending(os_context_t*);
extern void interrupt_internal_error(int, siginfo_t*, os_context_t*,
boolean continuable);
+extern boolean handle_control_stack_guard_triggered(os_context_t *,void *);
extern boolean interrupt_maybe_gc(int, siginfo_t*, void*);
extern void undoably_install_low_level_interrupt_handler (int signal,
void
started up a process with a different set of traps, or
something?) Find out what this was meant to do, and reenable it
or delete it if possible. -- CSR, 2002-07-15 */
- /* SET_FPU_CONTROL_WORD(0x1372|4|8|16|32); /* no interrupts */
+ /* SET_FPU_CONTROL_WORD(0x1372|4|8|16|32); no interrupts */
#endif
}
* any OS-dependent special low-level handling for signals
*/
+
#if defined GENCGC
/*
{
os_context_t *context = arch_os_get_context(&void_context);
void* fault_addr = (void*)context->uc_mcontext.cr2;
- if (!gencgc_handle_wp_violation(fault_addr)) {
- interrupt_handle_now(signal, info, void_context);
- }
+ if (!gencgc_handle_wp_violation(fault_addr))
+ if(!handle_control_stack_guard_triggered(context,fault_addr))
+ interrupt_handle_now(signal, info, void_context);
}
#else
os_context_t *context = arch_os_get_context(&void_context);
os_vm_address_t addr;
-#ifdef __i386__
- interrupt_handle_now(signal,contextstruct);
-#else
- char *control_stack_top = (char*)CONTROL_STACK_START + CONTROL_STACK_SIZE;
-
addr = arch_get_bad_addr(signal,info,context);
-
if (addr != NULL &&
- *os_context_register_addr(context,reg_ALLOC) & (1L<<63)){
+ *os_context_register_addr(context,reg_ALLOC) & (1L<<63)){
- /* This is the end of a pseudo-atomic section during which
- * a signal was received. We must deal with the pending interrupt
- * (see also interrupt.c, ../code/interrupt.lisp)
+ /* Alpha stuff: This is the end of a pseudo-atomic section
+ * during which a signal was received. We must deal with the
+ * pending interrupt (see also interrupt.c,
+ * ../code/interrupt.lisp)
*/
/* (how we got here: when interrupting, we set bit 63 in
* reg_Alloc. At the end of the atomic section we tried to
*/
*os_context_register_addr(context,reg_ALLOC) -= (1L<<63);
interrupt_handle_pending(context);
- } else if (addr > control_stack_top && addr < BINDING_STACK_START) {
- fprintf(stderr,
- "Possible stack overflow at 0x%016lX:\n"
- "control_stack_top=%lx, BINDING_STACK_START=%lx\n",
- addr,
- control_stack_top,
- BINDING_STACK_START);
- /* Try to fix control frame pointer. */
- while ( ! (CONTROL_STACK_START <= *current_control_frame_pointer &&
- *current_control_frame_pointer <= control_stack_top))
- ((char*)current_control_frame_pointer) -= sizeof(lispobj);
- monitor_or_something();
- } else if (!interrupt_maybe_gc(signal, info, context)) {
- interrupt_handle_now(signal, info, context);
+ } else {
+ if(!interrupt_maybe_gc(signal, info, context))
+ if(!handle_control_stack_guard_triggered(context,addr))
+ interrupt_handle_now(signal, info, context);
}
-#endif
}
#endif
void
os_install_interrupt_handlers(void)
{
- undoably_install_low_level_interrupt_handler(SIGSEGV, sigsegv_handler);
+ undoably_install_low_level_interrupt_handler(SIG_MEMORY_FAULT,
+ sigsegv_handler);
}
#define OS_VM_PROT_WRITE PROT_WRITE
#define OS_VM_PROT_EXECUTE PROT_EXEC
+#define SIG_MEMORY_FAULT SIGSEGV
+
/* /usr/include/asm/sigcontext.h */
typedef long os_context_register_t ;
fprintf(stderr, "bad address 0x%p\n",addr);
lose("ran off end of dynamic space");
} else if (!interrupt_maybe_gc(signal, info, context)) {
- interrupt_handle_now(signal, info, context);
+ if(!handle_control_stack_guard_triggered(context,addr))
+ interrupt_handle_now(signal, info, context);
}
}
void
os_install_interrupt_handlers(void)
{
- undoably_install_low_level_interrupt_handler(SIGSEGV, sigsegv_handler);
+ undoably_install_low_level_interrupt_handler(SIG_MEMORY_FAULT,
+ sigsegv_handler);
}
#define OS_VM_PROT_WRITE PROT_WRITE
#define OS_VM_PROT_EXECUTE PROT_EXEC
+#define SIG_MEMORY_FAULT SIGSEGV
+
typedef long os_context_register_t ;
#ifndef NSIG /* osf1 -D_XOPEN_SOURCE_EXTENDED omits this */
set_lossage_handler(monitor_or_something);
-#if 0
- os_init();
- gc_init();
- validate();
-#endif
globals_init();
initial_function = load_core_file(core);
os_vm_address_t addr;
addr = arch_get_bad_addr(signal, info, context);
- /* There's some complicated recovery code in linux-os.c here
- that I'm currently too confused to understand. FIXME. */
if(!interrupt_maybe_gc(signal, info, context)) {
- interrupt_handle_now(signal, info, context);
+ if(!handle_control_stack_guard_triggered(context,addr))
+ interrupt_handle_now(signal, info, context);
}
}
void
os_install_interrupt_handlers()
{
- undoably_install_low_level_interrupt_handler(SIGSEGV,sigsegv_handler);
+ undoably_install_low_level_interrupt_handler(SIG_MEMORY_FAULT,
+ sigsegv_handler);
}
#define OS_VM_PROT_WRITE PROT_WRITE
#define OS_VM_PROT_EXECUTE PROT_EXEC
+#define SIG_MEMORY_FAULT SIGSEGV
+
/* Yaargh?! */
typedef int os_context_register_t ;
#endif
ensure_space( (lispobj *)CONTROL_STACK_START , CONTROL_STACK_SIZE);
ensure_space( (lispobj *)BINDING_STACK_START , BINDING_STACK_SIZE);
+#ifdef LISP_FEATURE_C_STACK_IS_CONTROL_STACK
+ ensure_space( (lispobj *) ALTERNATE_SIGNAL_STACK_START, SIGSTKSZ);
+#endif
#ifdef HOLES
make_holes();
#ifndef GENCGC
current_dynamic_space = DYNAMIC_0_SPACE_START;
#endif
-
+
#ifdef PRINTNOISE
printf(" done.\n");
#endif
+ protect_control_stack_guard_page(1);
}
+
+void protect_control_stack_guard_page(int protect_p) {
+ os_protect(CONTROL_STACK_GUARD_PAGE,
+ os_vm_page_size,protect_p ?
+ (OS_VM_PROT_READ|OS_VM_PROT_EXECUTE) : OS_VM_PROT_ALL);
+}
+
#define READ_ONLY_SPACE_SIZE (READ_ONLY_SPACE_END - READ_ONLY_SPACE_START)
#define STATIC_SPACE_SIZE ( STATIC_SPACE_END - STATIC_SPACE_START)
+#ifdef LISP_FEATURE_STACK_GROWS_DOWNWARD_NOT_UPWARD
+#define CONTROL_STACK_GUARD_PAGE (CONTROL_STACK_START)
+#else
+#define CONTROL_STACK_GUARD_PAGE (CONTROL_STACK_END - os_vm_page_size)
+#endif
+
#if !defined(LANGUAGE_ASSEMBLY)
extern void validate(void);
#endif
os_context_register_t *
os_context_pc_addr(os_context_t *context)
{
- return &context->uc_mcontext.gregs[14];
+ return &context->uc_mcontext.gregs[14]; /* REG_EIP */
}
os_context_register_t *
os_context_sp_addr(os_context_t *context)
+{
+ return &context->uc_mcontext.gregs[17]; /* REG_UESP */
+}
+
+os_context_register_t *
+os_context_fp_addr(os_context_t *context)
{
- return &context->uc_mcontext.gregs[17];
+ return &context->uc_mcontext.gregs[6]; /* REG_EBP */
}
unsigned long
projects / sbcl.git / commitdiff