Menu
▾
▴
[Sbcl-commits] CVS: sbcl/src/code debug.lisp,1.55.2.1,1.55.2.2 stream.lisp,1.35,1.35.4.1 target-thread.lisp,1.1.4.6,1.1.4.7 toplevel.lisp,1.36.2.1,1.36.2.2
|
From: Daniel B. <da...@us...> - 2003-02-19 23:13:42
|
Update of /cvsroot/sbcl/sbcl/src/code
In directory sc8-pr-cvs1:/tmp/cvs-serv25093/src/code
Modified Files:
Tag: dan_native_threads_2_branch
debug.lisp stream.lisp target-thread.lisp toplevel.lisp
Log Message:
0.7.11.10.thread.9
One step closer to heaven.
The debugger now remembers if it had to wait to get access
to its input stream, and auto-backgrounds the thread again
when restarting. Well, what use is it having a foreground thread
that's not interested in talking to you?
MAYBE-WAIT-UNTIL-FOREGROUND-THREAD is now
DEBUGGER-WAIT-UNTIL-FOREGROUND-THREAD, and takes a stream as
argument
Extended the extensible repl prompt mechanism to take input
and output streams, and wrote THREAD-REPL-PROMPT-FUN which
needs this new protocol.
Deleted more old-tty stuff
OK, the problem is that we didn't actually want to protect per
stream, or even per underlying fd-stream, we wanted to protect
per file, so e.g. dup() confuses matters. This manifests
itself most obviously when one stream is at the repl and
another in the debugger:
#<FILE-STREAM for "the terminal" {9004749}> and
#<FILE-STREAM for "standard input" {9004539}> are two different
streams, but they still both conflict with each other
We're going to have to do fstat on the streams and compare
device/inode to find out if they really are the same. Sucky
Index: debug.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/debug.lisp,v
retrieving revision 1.55.2.1
retrieving revision 1.55.2.2
diff -u -d -r1.55.2.1 -r1.55.2.2
--- debug.lisp 19 Feb 2003 06:16:24 -0000 1.55.2.1
+++ debug.lisp 19 Feb 2003 23:13:36 -0000 1.55.2.2
@@ -652,7 +652,6 @@
;; If we're a background thread and *background-threads-wait-for-debugger*
;; is NIL, this will invoke a restart
- (sb!thread::maybe-wait-until-foreground-thread)
;; Note: CMU CL had (SB-UNIX:UNIX-SIGSETMASK 0) here. I deleted it
;; around sbcl-0.7.8.5 (by which time it had mutated to have a
@@ -707,6 +706,7 @@
(*readtable* *debug-readtable*)
(*print-readably* nil)
(*package* original-package)
+ (background-p nil)
(*print-pretty* original-print-pretty))
;; Before we start our own output, finish any pending output.
@@ -751,33 +751,38 @@
;; older debugger code which was written to do i/o on whatever
;; stream was in fashion at the time, and not all of it has
;; been converted to behave this way. -- WHN 2000-11-16)
- (let (;; FIXME: Rebinding *STANDARD-OUTPUT* here seems wrong,
- ;; violating the principle of least surprise, and making
- ;; it impossible for the user to do reasonable things
- ;; like using PRINT at the debugger prompt to send output
- ;; to the program's ordinary (possibly
- ;; redirected-to-a-file) *STANDARD-OUTPUT*. (CMU CL
- ;; used to rebind *STANDARD-INPUT* here too, but that's
- ;; been fixed already.)
- (*standard-output* *debug-io*)
- ;; This seems reasonable: e.g. if the user has redirected
- ;; *ERROR-OUTPUT* to some log file, it's probably wrong
- ;; to send errors which occur in interactive debugging to
- ;; that file, and right to send them to *DEBUG-IO*.
- (*error-output* *debug-io*))
- (unless (typep condition 'step-condition)
- (when *debug-beginner-help-p*
- (format *debug-io*
- "~%~@<Within the debugger, you can type HELP for help. ~
+
+ (setf background-p
+ (sb!thread::debugger-wait-until-foreground-thread *debug-io*))
+ (unwind-protect
+ (let (;; FIXME: Rebinding *STANDARD-OUTPUT* here seems wrong,
+ ;; violating the principle of least surprise, and making
+ ;; it impossible for the user to do reasonable things
+ ;; like using PRINT at the debugger prompt to send output
+ ;; to the program's ordinary (possibly
+ ;; redirected-to-a-file) *STANDARD-OUTPUT*. (CMU CL
+ ;; used to rebind *STANDARD-INPUT* here too, but that's
+ ;; been fixed already.)
+ (*standard-output* *debug-io*)
+ ;; This seems reasonable: e.g. if the user has redirected
+ ;; *ERROR-OUTPUT* to some log file, it's probably wrong
+ ;; to send errors which occur in interactive debugging to
+ ;; that file, and right to send them to *DEBUG-IO*.
+ (*error-output* *debug-io*))
+ (unless (typep condition 'step-condition)
+ (when *debug-beginner-help-p*
+ (format *debug-io*
+ "~%~@<Within the debugger, you can type HELP for help. ~
At any command prompt (within the debugger or not) you ~
can type (SB-EXT:QUIT) to terminate the SBCL ~
executable. The condition which caused the debugger to ~
be entered is bound to ~S. You can suppress this ~
message by clearing ~S.~:@>~2%"
- '*debug-condition*
- '*debug-beginner-help-p*))
- (show-restarts *debug-restarts* *debug-io*))
- (internal-debug))))))
+ '*debug-condition*
+ '*debug-beginner-help-p*))
+ (show-restarts *debug-restarts* *debug-io*))
+ (internal-debug))
+ (when background-p (background-this-thread *debug-io*)))))))
(defun show-restarts (restarts s)
(cond ((null restarts)
@@ -818,8 +823,7 @@
(*read-suppress* nil))
(unless (typep *debug-condition* 'step-condition)
(clear-input *debug-io*))
- #!-mp (debug-loop)
- #!+mp (sb!mp:without-scheduling (debug-loop))))
+ (debug-loop)))
;;;; DEBUG-LOOP
Index: stream.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/stream.lisp,v
retrieving revision 1.35
retrieving revision 1.35.4.1
diff -u -d -r1.35 -r1.35.4.1
--- stream.lisp 24 Nov 2002 22:40:52 -0000 1.35
+++ stream.lisp 19 Feb 2003 23:13:37 -0000 1.35.4.1
@@ -1807,6 +1807,33 @@
;;;; etc.
+(defun get-underlying-stream (stream direction)
+ (typecase stream
+ (synonym-stream
+ (get-underlying-stream
+ (symbol-value (synonym-stream-symbol stream)) direction))
+ ((or two-way-stream echo-stream)
+ (get-underlying-stream (if (eql direction :input)
+ (two-way-stream-input-stream stream)
+ (two-way-stream-output-stream stream))
+ direction))
+ (concatenated-stream
+ (get-underlying-stream (concatenated-stream-current stream) direction))
+ (broadcast-stream
+ ;; XXX kludgey. we should return all underlying streams. Presently
+ ;; we're only using this function for input though, so this code never
+ ;; runs anyway
+ (get-underlying-stream (car (broadcast-stream-streams stream)) direction))
+ (indenting-stream
+ (get-underlying-stream (indenting-stream-stream stream) direction))
+ (case-frob-stream
+ (get-underlying-stream (case-frob-stream-target stream) direction))
+ ;; leaving us with file-stream, string-stream, ansi-stream, gray-stream
+ ;; etc: the base cases
+ (t stream)))
+
+
;;; (These were inline throughout this file, but that's not appropriate
;;; globally.)
(declaim (maybe-inline read-char unread-char read-byte listen))
+
Index: target-thread.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/Attic/target-thread.lisp,v
retrieving revision 1.1.4.6
retrieving revision 1.1.4.7
diff -u -d -r1.1.4.6 -r1.1.4.7
--- target-thread.lisp 19 Feb 2003 06:16:24 -0000 1.1.4.6
+++ target-thread.lisp 19 Feb 2003 23:13:37 -0000 1.1.4.7
@@ -33,51 +33,6 @@
until (sb!sys:sap= thread (sb!sys:int-sap 0))
collect (funcall function thread))))
-#+nil
-(defun thread-stopped-p (thread)
- (sb!kernel:make-lisp-obj
- (sb!sys:sap-ref-32 thread
- (* 4 sb!vm::thread-stopped-p-slot))))
- ; (declare (optimize (speed 3) (safety 0)))
-; (thread-stopped-p thread))
-
-
-(defvar *foreground-thread-stack* nil)
-
-#+nil
-(defun background-thread (&optional restart)
- (if restart
- (let* ((real-restart (sb!kernel::find-restart-or-lose restart))
- (args (sb!kernel::interactive-restart-arguments real-restart)))
- (thread-to-tty (pop *foreground-thread-stack*))
- (apply (sb!kernel::restart-function real-restart) args))
- (thread-to-tty (pop *foreground-thread-stack*))))
-
-#+nil
-(defun make-listener-thread (tty-name)
- (assert (probe-file tty-name))
- (let* ((in (sb!unix:unix-open (namestring tty-name) sb!unix:o_rdwr #o666))
- (out (sb!unix:unix-dup in))
- (err (sb!unix:unix-dup in)))
- (labels ((thread-repl ()
- ;;; XXX also need to set up new *foreground-thread-stack*
- (let* ((sb!impl::*stdin*
- (sb!sys:make-fd-stream in :input t :buffering :line))
- (sb!impl::*stdout*
- (sb!sys:make-fd-stream out :output t :buffering :line))
- (sb!impl::*stderr*
- (sb!sys:make-fd-stream err :output t :buffering :line))
- (sb!impl::*tty*
- (sb!sys:make-fd-stream err :input t :output t :buffering :line))
- (sb!impl::*descriptor-handlers* nil))
- (sb!impl::handling-end-of-the-world
- (with-simple-restart
- (destroy-thread
- (format nil "~~@<Destroy this thread (~A)~~@:>"
- (current-thread-id)))
- (sb!impl::toplevel-repl nil))))))
- (make-thread #'thread-repl))))
-
;;;; mutex and read/write locks, originally inspired by CMUCL multi-proc.lisp
;;; in true OOAOM style, this is also defined in C. Don't change this
@@ -140,27 +95,44 @@
;;;; job control
(defvar *background-threads-wait-for-debugger* t)
-;;; may be T, NIL, or a function called with sb-sys::*stdin* and thread id
-;;; as its two arguments, returns NIL or T
+;;; may be T, NIL, or a function called with an fd-stream and thread id
+;;; as its two arguments, returning NIl or T
;;; called from top of invoke-debugger
-
-(defun maybe-wait-until-foreground-thread ()
- (when (not (eql (mutex-value
- (sb!impl::fd-stream-owner-thread sb!sys::*stdin*))
- (CURRENT-THREAD-ID)))
- (let* ((wait-p *background-threads-wait-for-debugger*)
- (*background-threads-wait-for-debugger* nil))
+(defun debugger-wait-until-foreground-thread (stream)
+ "Returns T if thread had been running in background, NIL if it was
+already the foreground thread, or transfers control to the first applicable
+restart if *BACKGROUND-THREADS-WAIT-FOR-DEBUGGER* says to do that instead"
+ (let* ((wait-p *background-threads-wait-for-debugger*)
+ (*background-threads-wait-for-debugger* nil)
+ (fd-stream (sb!impl::get-underlying-stream stream :input)))
+ (when (not (eql (mutex-value
+ (sb!impl::fd-stream-owner-thread fd-stream))
+ (CURRENT-THREAD-ID)))
(when (functionp wait-p)
(setf wait-p
- (funcall wait-p sb!sys::*stdin* (CURRENT-THREAD-ID))))
+ (funcall wait-p fd-stream (CURRENT-THREAD-ID))))
(cond (wait-p
- (get-mutex (sb!impl::fd-stream-owner-thread sb!sys::*stdin*))
+ (get-mutex (sb!impl::fd-stream-owner-thread fd-stream))
#+nil
- (sb!sys:enable-interrupt :sigint *sigint-handler*))
+ (sb!sys:enable-interrupt :sigint *sigint-handler*)
+ t)
(t
(invoke-restart (car (compute-restarts))))))))
+(defun thread-repl-prompt-fun (in-stream out-stream)
+ (let* ((stream (sb!impl::get-underlying-stream in-stream :input))
+ (lock (sb!impl::fd-stream-owner-thread stream)))
+ (unless (eql (mutex-value lock) (current-thread-id))
+ (get-mutex lock))
+ (let ((stopped (mutex-queue lock)))
+ (when stopped
+ (format stream "~{~&Thread ~A suspended~}~%" stopped))
+ (sb!impl::repl-prompt-fun in-stream out-stream))))
+
+;;; install this with (setf SB!INT:*REPL-PROMPT-FUN* #'thread-prompt-fun)
+;;; One day it will be default
+
(defstruct rwlock
(name nil :type (or null simple-base-string))
@@ -218,6 +190,8 @@
(:read (%unlock-for-reading lock))
(:write (%unlock-for-writing lock))))
+;;;; beyond this point all is commented.
+
;;; Lock-Wait-With-Timeout -- Internal
;;;
;;; Wait with a timeout for the lock to be free and acquire it for the
@@ -287,4 +261,29 @@
,lock 2 *current-process* nil)
#-i486 (when (eq (lock-process ,lock) *current-process*)
(setf (lock-process ,lock) nil)))))))
+
+#+nil
+(defun make-listener-thread (tty-name)
+ (assert (probe-file tty-name))
+ (let* ((in (sb!unix:unix-open (namestring tty-name) sb!unix:o_rdwr #o666))
+ (out (sb!unix:unix-dup in))
+ (err (sb!unix:unix-dup in)))
+ (labels ((thread-repl ()
+ ;;; XXX also need to set up new *foreground-thread-stack*
+ (let* ((sb!impl::*stdin*
+ (sb!sys:make-fd-stream in :input t :buffering :line))
+ (sb!impl::*stdout*
+ (sb!sys:make-fd-stream out :output t :buffering :line))
+ (sb!impl::*stderr*
+ (sb!sys:make-fd-stream err :output t :buffering :line))
+ (sb!impl::*tty*
+ (sb!sys:make-fd-stream err :input t :output t :buffering :line))
+ (sb!impl::*descriptor-handlers* nil))
+ (sb!impl::handling-end-of-the-world
+ (with-simple-restart
+ (destroy-thread
+ (format nil "~~@<Destroy this thread (~A)~~@:>"
+ (current-thread-id)))
+ (sb!impl::toplevel-repl nil))))))
+ (make-thread #'thread-repl))))
Index: toplevel.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/toplevel.lisp,v
retrieving revision 1.36.2.1
retrieving revision 1.36.2.2
diff -u -d -r1.36.2.1 -r1.36.2.2
--- toplevel.lisp 19 Jan 2003 19:46:20 -0000 1.36.2.1
+++ toplevel.lisp 19 Feb 2003 23:13:38 -0000 1.36.2.2
@@ -441,9 +441,10 @@
(critically-unreachable "after REPL")))))))
;;; Our default REPL prompt is the minimal traditional one.
-(defun repl-prompt-fun (stream)
- (fresh-line stream)
- (write-string "* " stream)) ; arbitrary but customary REPL prompt
+(defun repl-prompt-fun (in out)
+ (declare (type stream in out) (ignore in))
+ (fresh-line out)
+ (write-string "* " out)) ; arbitrary but customary REPL prompt
;;; Our default form reader does relatively little magic, but does
;;; handle the Unix-style EOF-is-end-of-process convention.
@@ -464,8 +465,8 @@
Lisp form). The OUT stream is there to support magic which requires
issuing new prompts.")
(defvar *repl-prompt-fun* #'repl-prompt-fun
- "a function of one argument STREAM for the toplevel REPL to call: Prompt
- the user for input.")
+ "a function of two stream arguments IN and OUT for the toplevel REPL
+to call: Prompt the user for input.")
(defun repl (noprint)
(/show0 "entering REPL")
@@ -474,7 +475,7 @@
;; (See comment preceding the definition of SCRUB-CONTROL-STACK.)
(scrub-control-stack)
(unless noprint
- (funcall *repl-prompt-fun* *standard-output*)
+ (funcall *repl-prompt-fun* *standard-input* *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
|