X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftoplevel.lisp;h=a36683ff3f2e38d84a9cb566173b1ac064cb7feb;hb=4f7211e1d005696dcd29d8322fa531992ea8fed4;hp=47a1efe5d1a85ca9fc608f3d90d4c2dca1af6c83;hpb=f0338f6fa732b21daa4405e19465bd460e0526d9;p=sbcl.git diff --git a/src/code/toplevel.lisp b/src/code/toplevel.lisp index 47a1efe..a36683f 100644 --- a/src/code/toplevel.lisp +++ b/src/code/toplevel.lisp @@ -15,14 +15,16 @@ (defconstant most-positive-fixnum #.sb!vm:*target-most-positive-fixnum* #!+sb-doc - "The fixnum closest in value to positive infinity.") + "the fixnum closest in value to positive infinity") (defconstant most-negative-fixnum #.sb!vm:*target-most-negative-fixnum* #!+sb-doc - "The fixnum closest in value to negative infinity.") + "the fixnum closest in value to negative infinity") -;;;; magic specials initialized by genesis +;;;; magic specials initialized by GENESIS +;;; FIXME: The DEFVAR here is redundant with the (DECLAIM (SPECIAL ..)) +;;; of all static symbols in early-impl.lisp. #!-gengc (progn (defvar *current-catch-block*) @@ -73,15 +75,20 @@ ;;;; working with *CURRENT-ERROR-DEPTH* and *MAXIMUM-ERROR-DEPTH* -;;; INFINITE-ERROR-PROTECT is used by ERROR and friends to keep us out of -;;; hyperspace. +;;; INFINITE-ERROR-PROTECT is used by ERROR and friends to keep us out +;;; of hyperspace. (defmacro infinite-error-protect (&rest forms) `(unless (infinite-error-protector) + (/show0 "back from INFINITE-ERROR-PROTECTOR") (let ((*current-error-depth* (1+ *current-error-depth*))) + (/show0 "in INFINITE-ERROR-PROTECT, incremented error depth") + #+sb-show (sb-debug:backtrace) ,@forms))) ;;; a helper function for INFINITE-ERROR-PROTECT (defun infinite-error-protector () + (/show0 "entering INFINITE-ERROR-PROTECTOR, *CURRENT-ERROR-DEPTH*=..") + (/hexstr *current-error-depth*) (cond ((not *cold-init-complete-p*) (%primitive print "Argh! error in cold init, halting") (%primitive sb!c:halt)) @@ -92,6 +99,8 @@ (%primitive print "Argh! corrupted error depth, halting") (%primitive sb!c:halt)) ((> *current-error-depth* *maximum-error-depth*) + (/show0 "*MAXIMUM-ERROR-DEPTH*=..") + (/hexstr *maximum-error-depth*) (/show0 "in INFINITE-ERROR-PROTECTOR, calling ERROR-ERROR") (error-error "Help! " *current-error-depth* @@ -99,6 +108,7 @@ "KERNEL:*MAXIMUM-ERROR-DEPTH* exceeded.") t) (t + (/show0 "returning normally from INFINITE-ERROR-PROTECTOR") nil))) ;;; FIXME: I had a badly broken version of INFINITE-ERROR-PROTECTOR at @@ -155,16 +165,16 @@ (defconstant bytes-per-scrub-unit 2048) +;;; 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?) (defun scrub-control-stack () - #!+sb-doc - "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?) (declare (optimize (speed 3) (safety 0)) (values (unsigned-byte 20))) ; FIXME: DECLARE VALUES? @@ -291,11 +301,11 @@ (/show0 "entering TOPLEVEL-INIT") - (let ((sysinit nil) ; value of --sysinit option - (userinit nil) ; value of --userinit option - (evals nil) ; values of --eval options (in reverse order) - (noprint nil) ; Has a --noprint option been seen? - (noprogrammer nil) ; Has a --noprogammer option been seen? + (let ((sysinit nil) ; value of --sysinit option + (userinit nil) ; value of --userinit option + (reversed-evals nil) ; values of --eval options, in reverse order + (noprint nil) ; Has a --noprint option been seen? + (noprogrammer nil) ; Has a --noprogammer option been seen? (options (rest *posix-argv*))) ; skipping program name (/show0 "done with outer LET in TOPLEVEL-INIT") @@ -339,7 +349,7 @@ (error "more than one expression in ~S" eval-as-string)) (t - (push eval evals))))))) + (push eval reversed-evals))))))) ((string= option "--noprint") (pop-option) (setf noprint t)) @@ -411,23 +421,45 @@ user-home "/.sbclrc")))) (/show0 "assigned SYSINIT-TRUENAME and USERINIT-TRUENAME") - (when sysinit-truename - (unless (load sysinit-truename) - (error "~S was not successfully loaded." sysinit-truename)) - (flush-standard-output-streams)) - (/show0 "loaded SYSINIT-TRUENAME") - (when userinit-truename - (unless (load userinit-truename) - (error "~S was not successfully loaded." userinit-truename)) - (flush-standard-output-streams)) - (/show0 "loaded USERINIT-TRUENAME")) - - ;; Handle --eval options. - (/show0 "handling --eval options in TOPLEVEL-INIT") - (dolist (eval (reverse evals)) - (/show0 "handling one --eval option in TOPLEVEL-INIT") - (eval eval) - (flush-standard-output-streams)) + + + ;; We wrap all the pre-REPL user/system customized startup code + ;; in a restart. + ;; + ;; (Why not wrap everything, even the stuff above, in this + ;; restart? Errors above here are basically command line or + ;; Unix environment errors, e.g. a missing file or a typo on + ;; the Unix command line, and you don't need to get into Lisp + ;; to debug them, you should just start over and do it right + ;; at the Unix level. Errors below here are usually errors in + ;; user Lisp code, and it might be helpful to let the user + ;; reach the REPL in order to help figure out what's going on.) + (restart-case + (flet ((process-init-file (truename) + (when truename + (unless (load truename) + (error "~S was not successfully loaded." truename)) + (flush-standard-output-streams)))) + (process-init-file sysinit-truename) + (process-init-file userinit-truename) + + ;; Process --eval options. + (/show0 "handling --eval options in TOPLEVEL-INIT") + (dolist (eval (reverse reversed-evals)) + (/show0 "handling one --eval option in TOPLEVEL-INIT") + (eval eval) + (flush-standard-output-streams))) + (continue () + :report "Continue anyway (skipping to toplevel read/eval/print loop)." + (values)) ; (no-op, just fall through) + (quit () + :report "Quit SBCL (calling #'QUIT, killing the process)." + (quit)))) + + ;; one more time for good measure, in case we fell out of the + ;; RESTART-CASE above before one of the flushes in the ordinary + ;; flow of control had a chance to operate + (flush-standard-output-streams) (/show0 "falling into TOPLEVEL-REPL from TOPLEVEL-INIT") (toplevel-repl noprint)))) @@ -485,13 +517,13 @@ (quit :unix-status 1 :recklessly-p recklessly-p))) ;; This HANDLER-CASE is here mostly to stop output immediately ;; (and fall through to QUIT) when there's an I/O error. Thus, - ;; when we're run under a Perl script or something, we can die + ;; when we're run under a shell script or something, we can die ;; cleanly when the script dies (and our pipes are cut), instead ;; of falling into ldb or something messy like that. (handler-case (progn (format *error-output* - "~@~2%" + "~@~2%" (type-of condition) condition) ;; Flush *ERROR-OUTPUT* even before the BACKTRACE, so that @@ -501,12 +533,29 @@ ;; (Where to truncate the BACKTRACE is of course arbitrary, but ;; it seems as though we should at least truncate it somewhere.) (sb!debug:backtrace 128 *error-output*) - (finish-output *error-output*) (format *error-output* - "~%unhandled CONDITION in --noprogrammer mode, quitting~%") + "~%unhandled condition in --noprogrammer mode, quitting~%") + (finish-output *error-output*) (failure-quit)) (condition () - (%primitive print "Argh! error within --noprogrammer error handling") + ;; We IGNORE-ERRORS here because even %PRIMITIVE PRINT can + ;; fail when our output streams are blown away, as e.g. when + ;; we're running under a Unix shell script and it dies somehow + ;; (e.g. because of a SIGINT). In that case, we might as well + ;; just give it up for a bad job, and stop trying to notify + ;; the user of anything. + ;; + ;; Actually, the only way I've run across to exercise the + ;; problem is to have more than one layer of shell script. + ;; I have a shell script which does + ;; time nice -10 sh make.sh "$1" 2>&1 | tee make.tmp + ;; and the problem occurs when I interrupt this with Ctrl-C + ;; under Linux 2.2.14-5.0 and GNU bash, version 1.14.7(1). + ;; I haven't figured out whether it's bash, time, tee, Linux, or + ;; what that is responsible, but that it's possible at all + ;; means that we should IGNORE-ERRORS here. -- WHN 2001-04-24 + (ignore-errors + (%primitive print "Argh! error within --noprogrammer error handling")) (failure-quit :recklessly-p t))))) ;;; a convenient way to get into the assembly-level debugger