\f
(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")
\f
-;;;; magic specials initialized by genesis
+;;;; magic specials initialized by GENESIS
-#!-gengc
+;;; FIXME: The DEFVAR here is redundant with the (DECLAIM (SPECIAL ..))
+;;; of all static symbols in early-impl.lisp.
(progn
(defvar *current-catch-block*)
(defvar *current-unwind-protect-block*)
\f
;;; specials initialized by !COLD-INIT
-;;; FIXME: These could be converted to DEFVARs, and the stuff shared
-;;; in both #!+GENGC and #!-GENGC (actually everything in #!+GENGC)
-;;; could be made non-conditional.
-(declaim
- #!-gengc
- (special *gc-inhibit* *already-maybe-gcing*
- *need-to-collect-garbage*
- *gc-notify-stream*
- *before-gc-hooks* *after-gc-hooks*
- #!+x86 *pseudo-atomic-atomic*
- #!+x86 *pseudo-atomic-interrupted*
- sb!unix::*interrupts-enabled*
- sb!unix::*interrupt-pending*
- *type-system-initialized*)
- #!+gengc
- (special *before-gc-hooks* *after-gc-hooks*
- *gc-notify-stream*
- *type-system-initialized*))
+;;; FIXME: These could be converted to DEFVARs.
+(declaim (special *gc-inhibit* *already-maybe-gcing*
+ *need-to-collect-garbage*
+ *gc-notify-stream*
+ *before-gc-hooks* *after-gc-hooks*
+ #!+x86 *pseudo-atomic-atomic*
+ #!+x86 *pseudo-atomic-interrupted*
+ sb!unix::*interrupts-enabled*
+ sb!unix::*interrupt-pending*
+ *type-system-initialized*))
(defvar *cold-init-complete-p*)
\f
;;;; 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))
(%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*
"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
(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?
(look (sap+ ptr bytes-per-scrub-unit) 0 count))
(t
(setf (sap-ref-32 ptr offset) 0)
- (scrub ptr (+ offset sb!vm:word-bytes) count))))
+ (scrub ptr (+ offset sb!vm:n-word-bytes) count))))
(look (ptr offset count)
(declare (type system-area-pointer ptr)
(type (unsigned-byte 16) offset)
(cond ((= offset bytes-per-scrub-unit)
count)
((zerop (sap-ref-32 ptr offset))
- (look ptr (+ offset sb!vm:word-bytes) count))
+ (look ptr (+ offset sb!vm:n-word-bytes) count))
(t
- (scrub ptr offset (+ count sb!vm:word-bytes))))))
+ (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))))
(declare (type (unsigned-byte 32) csp))
(scrub (int-sap (- csp initial-offset))
- (* (floor initial-offset sb!vm:word-bytes) sb!vm:word-bytes)
+ (* (floor initial-offset sb!vm:n-word-bytes) sb!vm:n-word-bytes)
0)))
#!+x86 ;; (Stack grows downwards.)
(type (unsigned-byte 16) offset)
(type (unsigned-byte 20) count)
(values (unsigned-byte 20)))
- (let ((loc (int-sap (- (sap-int ptr) (+ offset sb!vm:word-bytes)))))
+ (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:word-bytes) count)))))
+ (scrub ptr (+ offset sb!vm:n-word-bytes) count)))))
(look (ptr offset count)
(declare (type system-area-pointer ptr)
(type (unsigned-byte 16) offset)
(cond ((= offset bytes-per-scrub-unit)
count)
((zerop (sb!kernel::get-lisp-obj-address (stack-ref loc 0)))
- (look ptr (+ offset sb!vm:word-bytes) count))
+ (look ptr (+ offset sb!vm:n-word-bytes) count))
(t
- (scrub ptr offset (+ count sb!vm:word-bytes)))))))
+ (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))))
(declare (type (unsigned-byte 32) csp))
(scrub (int-sap (+ csp initial-offset))
- (* (floor initial-offset sb!vm:word-bytes) sb!vm:word-bytes)
+ (* (floor initial-offset sb!vm:n-word-bytes) sb!vm:n-word-bytes)
0))))
\f
;;;; the default toplevel function
-;;; FIXME: Most stuff below here can probably be byte-compiled.
-
(defvar / nil
#!+sb-doc
"a list of all the values returned by the most recent top-level EVAL")
(/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")
(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))
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))))
(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*
- "~@<unhandled CONDITION (of type ~S): ~2I~_~A~:>~2%"
+ "~@<unhandled condition (of type ~S): ~2I~_~A~:>~2%"
(type-of condition)
condition)
;; Flush *ERROR-OUTPUT* even before the BACKTRACE, so that
;; (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)))))
\f
;;; a convenient way to get into the assembly-level debugger
projects / sbcl.git / blobdiff