X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftoplevel.lisp;h=d9348ab18543fc6bac87073ac7fb23ca7f107edd;hb=fd526bc66c53616a2e757323cbda0271c72b3d54;hp=acf013e10c53c3bceb54f4f8e8d59ac1e06d933a;hpb=ab03a2f300a4706196ed3ba9429965523c5f7ddb;p=sbcl.git diff --git a/src/code/toplevel.lisp b/src/code/toplevel.lisp index acf013e..d9348ab 100644 --- a/src/code/toplevel.lisp +++ b/src/code/toplevel.lisp @@ -18,15 +18,15 @@ ;;; 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*) + (defvar sb!vm::*current-catch-block*) + (defvar sb!vm::*current-unwind-protect-block*) (defvar *free-interrupt-context-index*)) ;;; specials initialized by !COLD-INIT ;;; FIXME: These could be converted to DEFVARs. (declaim (special *gc-inhibit* *need-to-collect-garbage* - *before-gc-hooks* *after-gc-hooks* + *after-gc-hooks* #!+x86 *pseudo-atomic-atomic* #!+x86 *pseudo-atomic-interrupted* sb!unix::*interrupts-enabled* @@ -38,6 +38,17 @@ ;;; counts of nested errors (with internal errors double-counted) (defvar *maximum-error-depth*) (defvar *current-error-depth*) + +;;;; stepping control +(defvar *step*) +(defvar *stepping*) +(defvar *step-form-stack* nil + "A place for single steppers to push information about +STEP-FORM-CONDITIONS avaiting the corresponding +STEP-VALUES-CONDITIONS. The system is guaranteed to empty the stack +when stepping terminates, so that it remains in sync, but doesn't +modify it in any other way: it is provided for implmentors of single +steppers to maintain contextual information.") ;;;; miscellaneous utilities for working with with TOPLEVEL @@ -136,13 +147,13 @@ :format-arguments (list n) :datum n :expected-type '(real 0))) - (multiple-value-bind (sec usec) + (multiple-value-bind (sec nsec) (if (integerp n) (values n 0) (multiple-value-bind (sec frac) (truncate n) - (values sec (truncate frac 1e-6)))) - (sb!unix:unix-select 0 0 0 0 sec usec)) + (values sec (truncate frac 1e-9)))) + (sb!unix:nanosleep sec nsec)) nil) ;;;; SCRUB-CONTROL-STACK @@ -185,7 +196,7 @@ ((= offset bytes-per-scrub-unit) (look (sap+ ptr bytes-per-scrub-unit) 0 count)) (t - (setf (sap-ref-32 ptr offset) 0) + (setf (sap-ref-word ptr offset) 0) (scrub ptr (+ offset sb!vm:n-word-bytes) count)))) (look (ptr offset count) (declare (type system-area-pointer ptr) @@ -195,11 +206,11 @@ (cond ((>= (sap-int ptr) end-of-stack) 0) ((= offset bytes-per-scrub-unit) count) - ((zerop (sap-ref-32 ptr offset)) + ((zerop (sap-ref-word 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)) + (declare (type sb!vm::word csp)) (scrub (int-sap (- csp initial-offset)) (* (floor initial-offset sb!vm:n-word-bytes) sb!vm:n-word-bytes) 0))) @@ -221,7 +232,7 @@ (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) + (setf (sap-ref-word loc 0) 0) (scrub ptr (+ offset sb!vm:n-word-bytes) count))))) (look (ptr offset count) (declare (type system-area-pointer ptr) @@ -236,7 +247,7 @@ (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)) + (declare (type sb!vm::word csp)) (scrub (int-sap (+ csp initial-offset)) (* (floor initial-offset sb!vm:n-word-bytes) sb!vm:n-word-bytes) 0)))) @@ -260,10 +271,7 @@ "Evaluate FORM, returning whatever it returns and adjusting ***, **, *, +++, ++, +, ///, //, /, and -." (setf - form) - (let ((results - (multiple-value-list - (eval-in-lexenv form - (make-null-interactive-lexenv))))) + (let ((results (multiple-value-list (eval form)))) (setf /// // // / / results @@ -293,12 +301,53 @@ (finish-output (symbol-value name))) (values)) +(defun process-init-file (truename) + (when truename + (restart-case + (with-open-file (s truename :if-does-not-exist nil) + (flet ((next () + (let ((form (read s nil s))) + (if (eq s form) + (return-from process-init-file nil) + (eval form))))) + (loop + (restart-case + (handler-bind ((error (lambda (e) + (error + "Error during processing of ~ + initialization file ~A:~%~% ~A" + truename e)))) + (next)) + (continue () + :report "Ignore and continue processing."))))) + (abort () + :report "Skip rest of initialization file.")))) + +(defun process-eval-options (eval-strings) + (/show0 "handling --eval options") + (flet ((process-1 (string) + (multiple-value-bind (expr pos) (read-from-string string) + (unless (eq string (read-from-string string nil string :start pos)) + (error "More the one expression in ~S" string)) + (eval expr) + (flush-standard-output-streams)))) + (restart-case + (dolist (expr-as-string eval-strings) + (/show0 "handling one --eval option") + (restart-case + (handler-bind ((error (lambda (e) + (error "Error during processing of --eval ~ + option ~S:~%~% ~A" + expr-as-string e)))) + (process-1 expr-as-string)) + (continue () + :report "Ignore and continue with next --eval option."))) + (abort () + :report "Skip rest of --eval options.")))) + ;;; the default system top level function (defun toplevel-init () - - (/show0 "entering TOPLEVEL-INIT") - (sb!thread::init-job-control) - (sb!thread::get-foreground) + (/show0 "entering TOPLEVEL-INIT") (let (;; value of --sysinit option (sysinit nil) ;; value of --userinit option @@ -368,13 +417,6 @@ ((string= option "--noprint") (pop-option) (setf noprint t)) - ;; FIXME: --noprogrammer was deprecated in 0.7.5, and - ;; in a year or so this backwards compatibility can - ;; go away. - ((string= option "--noprogrammer") - (warn "treating deprecated --noprogrammer as --disable-debugger") - (pop-option) - (push "(|DISABLE-DEBUGGER|)" reversed-evals)) ((string= option "--disable-debugger") (pop-option) (push "(|DISABLE-DEBUGGER|)" reversed-evals)) @@ -409,7 +451,7 @@ ;; USERINITish files (probe-init-files (explicitly-specified-init-file-name &rest default-init-file-names) - (declare (type list possible-init-file-names)) + (declare (type list default-init-file-names)) (if explicitly-specified-init-file-name (or (probe-file explicitly-specified-init-file-name) (startup-error "The file ~S was not found." @@ -432,60 +474,34 @@ (init-file-name (posix-getenv "HOME") ".sbclrc")))) - ;; 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 generally 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 - (progn - (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 (expr-as-string (reverse reversed-evals)) - (/show0 "handling one --eval option in TOPLEVEL-INIT") - (let ((expr (with-input-from-string (eval-stream - expr-as-string) - (let* ((eof-marker (cons :eof :eof)) - (result (read eval-stream - nil - eof-marker)) - (eof (read eval-stream nil eof-marker))) - (cond ((eq result eof-marker) - (error "unable to parse ~S" - expr-as-string)) - ((not (eq eof eof-marker)) - (error - "more than one expression in ~S" - expr-as-string)) - (t - result)))))) - (eval expr) - (flush-standard-output-streams)))) - (continue () - :report - "Continue anyway (skipping to toplevel read/eval/print loop)." - (/show0 "CONTINUEing from pre-REPL RESTART-CASE") - (values)) ; (no-op, just fall through) - (quit () - :report "Quit SBCL (calling #'QUIT, killing the process)." - (/show0 "falling through to QUIT from pre-REPL RESTART-CASE") - (quit)))) + ;; This CATCH is needed for the debugger command TOPLEVEL to + ;; work. + (catch 'toplevel-catcher + ;; 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 generally 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 + (progn + (process-init-file sysinit-truename) + (process-init-file userinit-truename) + (process-eval-options (reverse reversed-evals))) + (abort () + :report "Skip to toplevel READ/EVAL/PRINT loop." + (/show0 "CONTINUEing from pre-REPL RESTART-CASE") + (values)) ; (no-op, just fall through) + (quit () + :report "Quit SBCL (calling #'QUIT, killing the process)." + (/show0 "falling through to QUIT from pre-REPL RESTART-CASE") + (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 @@ -526,36 +542,24 @@ ;; Each REPL in a multithreaded world should have bindings of ;; most CL specials (most critically *PACKAGE*). (with-rebound-io-syntax - ;; WITH-SIMPLE-RESTART doesn't actually restart its body as - ;; some (like WHN for an embarrassingly long time - ;; ca. 2001-12-07) might think, but instead drops control back - ;; out at the end. So when a TOPLEVEL or outermost-ABORT - ;; restart happens, we need this outer LOOP wrapper to grab - ;; control and start over again. (And it also wraps CATCH - ;; 'TOPLEVEL-CATCHER for similar reasons.) - (loop - (/show0 "about to set up restarts in TOPLEVEL-REPL") - ;; There should only be one TOPLEVEL restart, and it's here, - ;; so restarting at TOPLEVEL always bounces you all the way - ;; out here. - (with-simple-restart (toplevel - "Restart at toplevel READ/EVAL/PRINT loop.") - ;; We add a new ABORT restart for every debugger level, so - ;; restarting at ABORT in a nested debugger gets you out to - ;; the innermost enclosing debugger, and only when you're - ;; in the outermost, unnested debugger level does - ;; restarting at ABORT get you out to here. - (with-simple-restart - (abort - "~@") - (catch 'toplevel-catcher - (sb!unix::reset-signal-mask) - ;; 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) - (funcall repl-fun noprint) - (critically-unreachable "after REPL"))))))))) + (handler-bind ((step-condition 'invoke-stepper)) + (let ((*stepping* nil) + (*step* nil)) + (loop + (/show0 "about to set up restarts in TOPLEVEL-REPL") + ;; CLHS recommends that there should always be an + ;; ABORT restart; we have this one here, and one per + ;; debugger level. + (with-simple-restart + (abort "~@") + (catch 'toplevel-catcher + (sb!unix::reset-signal-mask) + ;; 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) + (funcall repl-fun noprint) + (critically-unreachable "after REPL")))))))))) ;;; Our default REPL prompt is the minimal traditional one. (defun repl-prompt-fun (stream) @@ -575,26 +579,31 @@ (defun repl-fun (noprint) (/show0 "entering REPL") (loop - ;; (See comment preceding the definition of SCRUB-CONTROL-STACK.) - (scrub-control-stack) - (sb!thread::get-foreground) - (unless noprint - (funcall *repl-prompt-fun* *standard-output*) - ;; (Should *REPL-PROMPT-FUN* be responsible for doing its own - ;; FORCE-OUTPUT? I can't imagine a valid reason for it not to - ;; be done here, so leaving it up to *REPL-PROMPT-FUN* seems - ;; odd. But maybe there *is* a valid reason in some - ;; circumstances? perhaps some deadlock issue when being driven - ;; by another process or something...) - (force-output *standard-output*)) - (let* ((form (funcall *repl-read-form-fun* - *standard-input* - *standard-output*)) - (results (multiple-value-list (interactive-eval form)))) - (unless noprint - (dolist (result results) - (fresh-line) - (prin1 result)))))) + (unwind-protect + (progn + ;; (See comment preceding the definition of SCRUB-CONTROL-STACK.) + (scrub-control-stack) + (sb!thread::get-foreground) + (unless noprint + (funcall *repl-prompt-fun* *standard-output*) + ;; (Should *REPL-PROMPT-FUN* be responsible for doing its own + ;; FORCE-OUTPUT? I can't imagine a valid reason for it not to + ;; be done here, so leaving it up to *REPL-PROMPT-FUN* seems + ;; odd. But maybe there *is* a valid reason in some + ;; circumstances? perhaps some deadlock issue when being driven + ;; by another process or something...) + (force-output *standard-output*)) + (let* ((form (funcall *repl-read-form-fun* + *standard-input* + *standard-output*)) + (results (multiple-value-list (interactive-eval form)))) + (unless noprint + (dolist (result results) + (fresh-line) + (prin1 result))))) + ;; If we started stepping in the debugger we want to stop now. + (setf *stepping* nil + *step* nil)))) ;;; a convenient way to get into the assembly-level debugger (defun %halt ()