From dc5e3163fe667e2629c7769aa8cf2e501eeeefa6 Mon Sep 17 00:00:00 2001 From: Daniel Barlow Date: Tue, 23 Jul 2002 17:22:35 +0000 Subject: [PATCH] 0.7.6.1: Mostly-tested but still considered "experimental" non-invasive stack exhaustion checking, using a guard page at the end of the stack and an extra clause in the sigsegv (on some ports, sigbus) handler. One day there will be an internals doc with the gory details: for now, try http://ww.telent.net/diary/2002/7/#23.59392 --- make-config.sh | 2 +- package-data-list.lisp-expr | 1 + src/code/cold-init.lisp | 1 - src/code/exhaust.lisp | 61 +--------------- src/code/fd-stream.lisp | 5 +- src/code/interr.lisp | 9 +++ src/code/run-program.lisp | 1 + src/code/stream.lisp | 1 + src/code/toplevel.lisp | 139 ++++++++++++++++++++----------------- src/cold/warm.lisp | 8 +++ src/compiler/alpha/parms.lisp | 1 + src/compiler/generic/genesis.lisp | 1 + src/compiler/ir1tran.lisp | 23 +----- src/compiler/ppc/parms.lisp | 1 + src/compiler/sparc/parms.lisp | 1 + src/compiler/x86/parms.lisp | 24 +++++-- src/runtime/GNUmakefile | 3 +- src/runtime/bsd-os.c | 18 ++--- src/runtime/bsd-os.h | 3 + src/runtime/globals.c | 6 +- src/runtime/interrupt.c | 128 ++++++++++++++++++++++++---------- src/runtime/interrupt.h | 1 + src/runtime/linux-os.c | 46 +++++------- src/runtime/linux-os.h | 2 + src/runtime/osf1-os.c | 6 +- src/runtime/osf1-os.h | 2 + src/runtime/runtime.c | 5 -- src/runtime/sunos-os.c | 8 +-- src/runtime/sunos-os.h | 2 + src/runtime/validate.c | 13 +++- src/runtime/validate.h | 6 ++ src/runtime/x86-linux-os.c | 10 ++- 32 files changed, 291 insertions(+), 247 deletions(-) diff --git a/make-config.sh b/make-config.sh index 686a9c2..021b115 100644 --- a/make-config.sh +++ b/make-config.sh @@ -60,7 +60,7 @@ printf ":%s" "$sbcl_arch" >> $ltf # 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 diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index f632013..5e06b46 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1849,6 +1849,7 @@ structure representations" "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" diff --git a/src/code/cold-init.lisp b/src/code/cold-init.lisp index f2dca7d..2b7f329 100644 --- a/src/code/cold-init.lisp +++ b/src/code/cold-init.lisp @@ -99,7 +99,6 @@ *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; diff --git a/src/code/exhaust.lisp b/src/code/exhaust.lisp index 25c038e..e3ce6ef 100644 --- a/src/code/exhaust.lisp +++ b/src/code/exhaust.lisp @@ -11,63 +11,6 @@ ;;;; 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 "~@") - (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)))) diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp index 9ba1ec8..7015b2a 100644 --- a/src/code/fd-stream.lisp +++ b/src/code/fd-stream.lisp @@ -369,6 +369,9 @@ (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 @@ -1079,7 +1082,7 @@ (: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)) diff --git a/src/code/interr.lisp b/src/code/interr.lisp index 95d4437..02147a8 100644 --- a/src/code/interr.lisp +++ b/src/code/interr.lisp @@ -482,3 +482,12 @@ 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.")))) + + diff --git a/src/code/run-program.lisp b/src/code/run-program.lisp index 372fe26..aee63b8 100644 --- a/src/code/run-program.lisp +++ b/src/code/run-program.lisp @@ -425,6 +425,7 @@ (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) diff --git a/src/code/stream.lisp b/src/code/stream.lisp index 5788195..e8991ac 100644 --- a/src/code/stream.lisp +++ b/src/code/stream.lisp @@ -1153,6 +1153,7 @@ (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)) diff --git a/src/code/toplevel.lisp b/src/code/toplevel.lisp index 092a0cb..1348ad7 100644 --- a/src/code/toplevel.lisp +++ b/src/code/toplevel.lisp @@ -152,75 +152,89 @@ ;;; 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) @@ -485,6 +499,10 @@ "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"))))))) @@ -492,10 +510,7 @@ (/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) diff --git a/src/cold/warm.lisp b/src/cold/warm.lisp index 36430af..1292f46 100644 --- a/src/cold/warm.lisp +++ b/src/cold/warm.lisp @@ -13,6 +13,14 @@ ;;;; 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) diff --git a/src/compiler/alpha/parms.lisp b/src/compiler/alpha/parms.lisp index 1a5f921..f208e17 100644 --- a/src/compiler/alpha/parms.lisp +++ b/src/compiler/alpha/parms.lisp @@ -195,6 +195,7 @@ ;; 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 diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index 8640884..ca733d9 100644 --- a/src/compiler/generic/genesis.lisp +++ b/src/compiler/generic/genesis.lisp @@ -1247,6 +1247,7 @@ (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)) diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 59cf711..80aba16 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -1466,30 +1466,11 @@ (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))) diff --git a/src/compiler/ppc/parms.lisp b/src/compiler/ppc/parms.lisp index 72e930f..088d178 100644 --- a/src/compiler/ppc/parms.lisp +++ b/src/compiler/ppc/parms.lisp @@ -160,6 +160,7 @@ ;; 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 diff --git a/src/compiler/sparc/parms.lisp b/src/compiler/sparc/parms.lisp index ab3adf1..f66386a 100644 --- a/src/compiler/sparc/parms.lisp +++ b/src/compiler/sparc/parms.lisp @@ -209,6 +209,7 @@ ;; 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 diff --git a/src/compiler/x86/parms.lisp b/src/compiler/x86/parms.lisp index 1c5c1b1..63d7d5c 100644 --- a/src/compiler/x86/parms.lisp +++ b/src/compiler/x86/parms.lisp @@ -148,7 +148,8 @@ (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 @@ -168,12 +169,19 @@ #!+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: @@ -230,9 +238,11 @@ ;; 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 diff --git a/src/runtime/GNUmakefile b/src/runtime/GNUmakefile index 9a7bbee..bf32c7a 100644 --- a/src/runtime/GNUmakefile +++ b/src/runtime/GNUmakefile @@ -52,9 +52,10 @@ sbcl.nm: sbcl 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 diff --git a/src/runtime/bsd-os.c b/src/runtime/bsd-os.c index eaf6e10..54a1c00 100644 --- a/src/runtime/bsd-os.c +++ b/src/runtime/bsd-os.c @@ -230,23 +230,19 @@ memory_fault_handler(int signal, siginfo_t *siginfo, void *void_context) #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()"); } diff --git a/src/runtime/bsd-os.h b/src/runtime/bsd-os.h index 63da20b..86d8f6e 100644 --- a/src/runtime/bsd-os.h +++ b/src/runtime/bsd-os.h @@ -28,14 +28,17 @@ typedef int os_context_register_t; * 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 diff --git a/src/runtime/globals.c b/src/runtime/globals.c index 2dee4ce..e775166 100644 --- a/src/runtime/globals.c +++ b/src/runtime/globals.c @@ -60,10 +60,10 @@ void globals_init(void) 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; diff --git a/src/runtime/interrupt.c b/src/runtime/interrupt.c index 68c5fe0..feb2cc9 100644 --- a/src/runtime/interrupt.c +++ b/src/runtime/interrupt.c @@ -32,7 +32,6 @@ #include "dynbind.h" #include "interr.h" - void sigaddset_blockable(sigset_t *s) { sigaddset(s, SIGHUP); @@ -106,31 +105,15 @@ static boolean maybe_gc_pending = 0; * 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)) @@ -155,9 +138,10 @@ fake_foreign_function_call(os_context_t *context) 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)); @@ -170,6 +154,29 @@ fake_foreign_function_call(os_context_t *context) 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. */ @@ -180,8 +187,7 @@ fake_foreign_function_call(os_context_t *context) * 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, @@ -493,16 +499,53 @@ gc_trigger_hit(int signal, siginfo_t *info, os_context_t *context) 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 @@ -547,8 +590,8 @@ interrupt_maybe_gc(int signal, siginfo_t *info, void *void_context) 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); @@ -622,7 +665,20 @@ undoably_install_low_level_interrupt_handler (int signal, 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) { diff --git a/src/runtime/interrupt.h b/src/runtime/interrupt.h index dbd0082..2a35852 100644 --- a/src/runtime/interrupt.h +++ b/src/runtime/interrupt.h @@ -35,6 +35,7 @@ extern void interrupt_handle_now(int, siginfo_t*, void*); 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 diff --git a/src/runtime/linux-os.c b/src/runtime/linux-os.c index bef7006..0bee001 100644 --- a/src/runtime/linux-os.c +++ b/src/runtime/linux-os.c @@ -87,7 +87,7 @@ void os_init(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 } @@ -242,6 +242,7 @@ is_valid_lisp_addr(os_vm_address_t addr) * any OS-dependent special low-level handling for signals */ + #if defined GENCGC /* @@ -253,9 +254,9 @@ sigsegv_handler(int signal, siginfo_t *info, void* void_context) { 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 @@ -266,19 +267,14 @@ sigsegv_handler(int signal, siginfo_t *info, void* void_context) 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 @@ -287,28 +283,18 @@ sigsegv_handler(int signal, siginfo_t *info, void* void_context) */ *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); } diff --git a/src/runtime/linux-os.h b/src/runtime/linux-os.h index ed8733d..8d05e0b 100644 --- a/src/runtime/linux-os.h +++ b/src/runtime/linux-os.h @@ -36,5 +36,7 @@ typedef int os_vm_prot_t; #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 ; diff --git a/src/runtime/osf1-os.c b/src/runtime/osf1-os.c index ba62135..05fd248 100644 --- a/src/runtime/osf1-os.c +++ b/src/runtime/osf1-os.c @@ -142,7 +142,8 @@ sigsegv_handler(int signal, siginfo_t *info, void* void_context) 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); } } @@ -150,6 +151,7 @@ sigsegv_handler(int signal, siginfo_t *info, void* void_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); } diff --git a/src/runtime/osf1-os.h b/src/runtime/osf1-os.h index b82e313..0f35d1a 100644 --- a/src/runtime/osf1-os.h +++ b/src/runtime/osf1-os.h @@ -12,6 +12,8 @@ typedef int os_vm_prot_t; #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 */ diff --git a/src/runtime/runtime.c b/src/runtime/runtime.c index 019b12f..039dac6 100644 --- a/src/runtime/runtime.c +++ b/src/runtime/runtime.c @@ -254,11 +254,6 @@ More information about SBCL is available at .\n\ set_lossage_handler(monitor_or_something); -#if 0 - os_init(); - gc_init(); - validate(); -#endif globals_init(); initial_function = load_core_file(core); diff --git a/src/runtime/sunos-os.c b/src/runtime/sunos-os.c index 5e721f9..2a6bf34 100644 --- a/src/runtime/sunos-os.c +++ b/src/runtime/sunos-os.c @@ -173,10 +173,9 @@ sigsegv_handler(int signal, siginfo_t *info, void* void_context) 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); } } @@ -185,5 +184,6 @@ sigsegv_handler(int signal, siginfo_t *info, void* void_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); } diff --git a/src/runtime/sunos-os.h b/src/runtime/sunos-os.h index 6132fd9..15475d3 100644 --- a/src/runtime/sunos-os.h +++ b/src/runtime/sunos-os.h @@ -30,5 +30,7 @@ typedef int os_vm_prot_t; #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 ; diff --git a/src/runtime/validate.c b/src/runtime/validate.c index 9d712db..54b3a6b 100644 --- a/src/runtime/validate.c +++ b/src/runtime/validate.c @@ -74,6 +74,9 @@ validate(void) #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(); @@ -81,8 +84,16 @@ validate(void) #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); +} + diff --git a/src/runtime/validate.h b/src/runtime/validate.h index 9f13e9f..61a1d51 100644 --- a/src/runtime/validate.h +++ b/src/runtime/validate.h @@ -19,6 +19,12 @@ #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 diff --git a/src/runtime/x86-linux-os.c b/src/runtime/x86-linux-os.c index 3d6e8a3..e5c3895 100644 --- a/src/runtime/x86-linux-os.c +++ b/src/runtime/x86-linux-os.c @@ -67,13 +67,19 @@ os_context_register_addr(os_context_t *context, int offset) 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 -- 1.7.10.4