From: Matt Birkholz Date: Sun, 16 Jan 2011 08:00:35 +0000 (-0700) Subject: Fixed subprocess-wait, without blocking the toolkit. X-Git-Tag: 20110426-Gtk~4 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=2b7327cc0b98202522359dea27385125b8aafb7c;p=mit-scheme.git Fixed subprocess-wait, without blocking the toolkit. * doc/gtk/gtk.texinfo, src/gtk/thread.scm, src/gtk/gtk.pkg: Rename kill-gtk-thread to stop-gtk-thread, and export it to () for easy emergency(!) use. * src/gtk/: fix-demo.scm, gobject.scm, swat.scm: Use detach-thread. * src/gtk/fix-layout.scm: Call gtk_widget_set_size_request; frobbing GtkWidget requisition no longer (as of 2.22) works. Leave the widget geometry undefined until the allocation callback can set it. Added fix-ink-move! methods for image and box inks. These are very simple methods, much like the method for text inks. Factored them into a new generic-fix-ink-move! integrable. * src/gtk/gtk.pkg: Import hook/subprocess-wait and nonblocking/ subprocess-wait, to enable non-blocking "synchronous" subprocesses. * src/gtk/main.scm: Move startup out of initialize-package!, into gtk-start, which is now used by make.scm. Thus startup is delayed from load/compile(!)-time to load-option-time. Use exit- rather than kill-gtk-thread. Fix type of argument to gtk_time_slice_window. * src/gtk/make.scm: Use new gtk-start procedure. * src/gtk/thread.scm: Added exit-gtk-thread and restart-gtk-thread. * src/microcode/uxio.c (OS_test_select_registry): Fixed to return SELECT_PROCESS_STATUS_CHANGE (or SELECT_INTERRUPT) instead of 0 when there is no io (or the registry is empty) BUT pending status changes or interrupts. * src/runtime/process.scm (subprocess-wait): Replaced the call to the process-wait primitive with application of hook/subprocess-wait. Initialized this new binding to normal/subprocess-wait, which simply calls the primitive. Implemented an alternative procedure, nonblocking/subprocess-wait, which uses the new block-on-process- status-change procedure. Added hook/subprocess-status-change. * src/runtime/runtime.pkg: Import block-on-process-status-change from (runtime thread) to (runtime process). * src/runtime/thread-queue.scm: Added thread-queue/dequeue-no-hang and thread-queue/dequeue-until, implementing the former in terms of the latter. Like /peek-until, /dequeue-until does the job, which was factored out into when-non-empty-before. * src/runtime/thread.scm: Added block-on-process-status-change. Like block-on-io-descriptor, it adds current-thread to those waiting on descriptor 'process-status-change. --- diff --git a/doc/gtk/gtk.texinfo b/doc/gtk/gtk.texinfo index f320532aa..e5f060f18 100644 --- a/doc/gtk/gtk.texinfo +++ b/doc/gtk/gtk.texinfo @@ -12,7 +12,7 @@ @copying This manual documents @acronym{Gtk} @value{VERSION}. -Copyright @copyright{} 2008, 2009, 2010 Matthew Birkholz +Copyright @copyright{} 2008, 2009, 2010, 2011 Matthew Birkholz @quotation Permission is granted to copy, distribute and/or modify this document @@ -114,7 +114,7 @@ directory of your build tree. @example ../microcode/scheme --library ../lib - (load-option 'GTK) + (load-option 'Gtk) (make-gtk-event-viewer-demo) @end example @@ -1781,7 +1781,7 @@ The key name (character or symbol) associated with the Gdk @node Debugging Facilities, , Gdk Functions, API Reference @section Debugging Facilities -@deffn Procedure kill-gtk-thread +@deffn Procedure stop-gtk-thread A convenient procedure to call in an emergency. @end deffn diff --git a/src/gtk/fix-demo.scm b/src/gtk/fix-demo.scm index 9a41b375b..e43a66889 100644 --- a/src/gtk/fix-demo.scm +++ b/src/gtk/fix-demo.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -Copyright (C) 2007, 2008, 2009, 2010 Matthew Birkholz +Copyright (C) 2007, 2008, 2009, 2010, 2011 Matthew Birkholz This file is part of MIT/GNU Scheme. @@ -177,6 +177,11 @@ USA. #f) (define (start-spinning drawing) + (let ((thread (create-spinner drawing))) + (detach-thread thread) + thread)) + +(define (create-spinner drawing) (create-thread #f (lambda () @@ -205,6 +210,11 @@ USA. (loop (modulo (fix:1+ frame) frames))))))))) (define (start-blinking drawing) + (let ((thread (create-blinker drawing))) + (detach-thread thread) + thread)) + +(define (create-blinker drawing) (create-thread #f (lambda () diff --git a/src/gtk/fix-layout.scm b/src/gtk/fix-layout.scm index 26ef23cae..20e337da1 100644 --- a/src/gtk/fix-layout.scm +++ b/src/gtk/fix-layout.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -Copyright (C) 2007, 2008, 2009, 2010 Matthew Birkholz +Copyright (C) 2007, 2008, 2009, 2010, 2011 Matthew Birkholz This file is part of MIT/GNU Scheme. @@ -112,13 +112,9 @@ USA. (trace ";((initialize-instance ) "widget" "width" "height")...\n") (call-next-method widget) (let ((alien (gobject-alien widget))) - (let ((geometry (fix-layout-geometry widget)) - (w (->requisition-fixnum width)) + (let ((w (->requisition-fixnum width)) (h (->requisition-fixnum height))) - (C->= alien "GtkWidget requisition width" w) - (C->= alien "GtkWidget requisition height" h) - (set-fix-rect-size! geometry w h)) - + (C-call "gtk_widget_set_size_request" alien w h)) (C-call "gtk_widget_set_has_window" alien 1) (C-call "gtk_widget_set_can_focus" alien 1)) (set-gtk-object-destroy-callback! widget) @@ -297,7 +293,7 @@ USA. (define-generic fix-layout-realize-callback (layout)) (define-method fix-layout-realize-callback ((widget )) - (trace ";fix-layout-realize- "widget"\n") + (trace ";((fix-layout-realize-callback ) "widget")...\n") (let ((geometry (fix-layout-geometry widget)) (attr (malloc (C-sizeof "GdkWindowAttr") '|GdkWindowAttr|)) (main-GdkWindow (fix-layout-window widget)) @@ -814,6 +810,17 @@ USA. ;; For the convenience of SWAT's canvas item group, mostly. (define-generic fix-ink-move! (ink dx dy)) + +;; Use this to define your fix-ink-move! method iff your extent is all +;; that needs to be updated when you move. This is not a default +;; method, else things might (only) appear to work. +(define-integrable (generic-fix-ink-move! ink dx dy) + (without-interrupts + (lambda () + (let ((extent (fix-ink-extent ink))) + (drawing-damage ink) + (fix-rect-move! extent dx dy) + (drawing-damage ink))))) ;; This kind of ink draws (outlines and/or fills) a shape using a ;; gdk_draw_* function with a GdkGC from gtk_gc_get (i.e. using the @@ -1394,18 +1401,12 @@ USA. (drawing-damage ink))))))) (define-method fix-ink-move! ((ink ) dx dy) - (without-interrupts - (lambda () - (let ((extent (fix-ink-extent ink))) - (drawing-damage ink) - (fix-rect-move! extent dx dy) - (drawing-damage ink))))) + (generic-fix-ink-move! ink dx dy)) (define (recache-text-extent! ink) (let ((layout (text-ink-pango-layout ink)) (ink-extent (pango-rectangle)) (logical-extent (pango-rectangle))) - (trace ";recache-text-extent!") (C-call "pango_layout_get_pixel_extents" (gobject-alien layout) 0 logical-extent) (drawing-damage ink) @@ -1612,6 +1613,9 @@ USA. 0 0 ;x_dither, y_dither )))))))) +(define-method fix-ink-move! ((ink ) dx dy) + (generic-fix-ink-move! ink dx dy)) + (define (make-image-ink-from-file filename) (let ((ink (make-image-ink))) (load-pixbuf-from-file (image-ink-loader ink) filename) @@ -1646,6 +1650,9 @@ USA. (fix-rect-width extent) (fix-rect-height extent))))) +(define-method fix-ink-move! ((ink ) dx dy) + (generic-fix-ink-move! ink dx dy)) + (define (set-box-ink! ink x y width height) (guarantee-fixnum x 'set-box-ink!) (guarantee-fixnum y 'set-box-ink!) diff --git a/src/gtk/gobject.scm b/src/gtk/gobject.scm index 65d871bb3..750490e5b 100644 --- a/src/gtk/gobject.scm +++ b/src/gtk/gobject.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -Copyright (C) 2007, 2008, 2009, 2010 Matthew Birkholz +Copyright (C) 2007, 2008, 2009, 2010, 2011 Matthew Birkholz This file is part of MIT/GNU Scheme. @@ -535,7 +535,9 @@ USA. (if (pixbuf-loader-port loader) (error "Pixbuf loader has already started:" loader)) (set-pixbuf-loader-port! loader input-port) - (set-pixbuf-loader-thread! loader (create-pixbuf-loader-thread loader))))) + (let ((thread (create-pixbuf-loader-thread loader))) + (set-pixbuf-loader-thread! loader thread) + (detach-thread thread))))) (define (create-pixbuf-loader-thread loader) (create-thread diff --git a/src/gtk/gtk-new.pkg b/src/gtk/gtk-new.pkg index 29ef555bc..d8ea860b9 100644 --- a/src/gtk/gtk-new.pkg +++ b/src/gtk/gtk-new.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -Copyright (C) 2007, 2008, 2009, 2010 Matthew Birkholz +Copyright (C) 2007, 2008, 2009, 2010, 2011 Matthew Birkholz This file is part of MIT/GNU Scheme. @@ -185,7 +185,8 @@ USA. set-fix-layout-motion-handler! set-fix-layout-button-handler! - make-fix-drawing fix-drawing-widgets + guarantee-fix-drawing + make-fix-drawing fix-drawing-widgets set-fix-drawing-size! fix-drawing-pick-list fix-drawing-add-ink! @@ -244,8 +245,8 @@ USA. (parent (runtime thread)) (files "thread") (depends-on "gtk.ext" "pango.ext") - (export (gtk) - kill-gtk-thread) + (export () + stop-gtk-thread) (import (gtk gobject) run-gc-cleanups) (import (runtime primitive-io) @@ -261,9 +262,11 @@ USA. default/process-command-line) (import (runtime) ucode-primitive) + (import (runtime subprocess) + hook/subprocess-wait nonblocking/subprocess-wait) (import (gtk thread) - create-gtk-thread) - (export (gtk) + create-gtk-thread exit-gtk-thread) + (export () gtk-time-slice-window? gtk-time-slice-window! gtk-select-trace? diff --git a/src/gtk/gtk.pkg b/src/gtk/gtk.pkg index 4d2ff583f..7a28157b3 100644 --- a/src/gtk/gtk.pkg +++ b/src/gtk/gtk.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -Copyright (C) 2007, 2008, 2009, 2010 Matthew Birkholz +Copyright (C) 2007, 2008, 2009, 2010, 2011 Matthew Birkholz This file is part of MIT/GNU Scheme. @@ -176,7 +176,8 @@ USA. set-fix-layout-motion-handler! set-fix-layout-button-handler! - make-fix-drawing fix-drawing-widgets + guarantee-fix-drawing + make-fix-drawing fix-drawing-widgets set-fix-drawing-size! fix-drawing-pick-list fix-drawing-add-ink! @@ -233,8 +234,8 @@ USA. (define-package (gtk thread) (parent (runtime thread)) (files "thread") - (export (gtk) - kill-gtk-thread) + (export () + stop-gtk-thread) (import (gtk gobject) run-gc-cleanups) (import (runtime primitive-io) @@ -249,9 +250,11 @@ USA. default/process-command-line) (import (runtime) ucode-primitive) + (import (runtime subprocess) + hook/subprocess-wait nonblocking/subprocess-wait) (import (gtk thread) - create-gtk-thread) - (export (gtk) + create-gtk-thread exit-gtk-thread) + (export () gtk-time-slice-window? gtk-time-slice-window! gtk-select-trace? diff --git a/src/gtk/main.scm b/src/gtk/main.scm index 199a00a10..3d453f74a 100644 --- a/src/gtk/main.scm +++ b/src/gtk/main.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -Copyright (C) 2008, 2009, 2010 Matthew Birkholz +Copyright (C) 2008, 2009, 2010, 2011 Matthew Birkholz This file is part of MIT/GNU Scheme. @@ -26,6 +26,11 @@ USA. (c-include "gtk") +(define (gtk-start) + (set! hook/subprocess-wait nonblocking/subprocess-wait) + (gtk-init ((ucode-primitive scheme-program-name 0)) *unused-command-line*) + (gtk-main+)) + (define (initialize-package!) (let ((program-name ((ucode-primitive scheme-program-name 0)))) (let ((processor hook/process-command-line)) @@ -34,9 +39,7 @@ USA. (processor (list->vector (gtk-init program-name (vector->list line)))) - (gtk-main+)))) - (gtk-init program-name *unused-command-line*)) - (gtk-main+)) + (gtk-main+)))))) (define (gtk-init name args) ;; Call gtk_init_check. Signals an error if gtk_init_check returns 0. @@ -91,14 +94,14 @@ USA. ;; Sortof does the opposite of gtk-main+. (without-interrupts (lambda () - (kill-gtk-thread) + (exit-gtk-thread) (C-call "gtk_main_plus_quit")))) (define (gtk-time-slice-window?) (C-call "gtk_time_slice_window_p")) (define (gtk-time-slice-window! open?) - (C-call "gtk_time_slice_window" open?)) + (C-call "gtk_time_slice_window" (if open? 1 0))) (define (gtk-select-trace?) (C-call "gtk_select_trace_p")) diff --git a/src/gtk/make.scm b/src/gtk/make.scm index d204511c0..d8a882fe3 100644 --- a/src/gtk/make.scm +++ b/src/gtk/make.scm @@ -6,4 +6,5 @@ Load the Gtk option. |# (with-loader-base-uri (system-library-uri "gtk/") (lambda () (load-package-set "gtk"))) -(add-subsystem-identification! "Gtk" '(0 2)) \ No newline at end of file +(add-subsystem-identification! "Gtk" '(0 2)) +((access gtk-start (->environment '(gtk main)))) \ No newline at end of file diff --git a/src/gtk/swat.scm b/src/gtk/swat.scm index d8dcfa437..c0a71bd26 100644 --- a/src/gtk/swat.scm +++ b/src/gtk/swat.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -Copyright (C) 2010 Matthew Birkholz +Copyright (C) 2010, 2011 Matthew Birkholz This file is part of MIT/GNU Scheme. @@ -364,9 +364,10 @@ USA. (define (initialize-package!) (set! swat-input-queue (make-thread-queue 100)) - (set! swat-thread (make-swat-thread))) + (set! swat-thread (create-swat-thread)) + (detach-thread swat-thread)) -(define (make-swat-thread) +(define (create-swat-thread) (create-thread #f (lambda () @@ -962,13 +963,14 @@ USA. (define (after-delay seconds thunk) (guarantee-index-fixnum seconds 'after-delay) (guarantee-procedure-of-arity thunk 0 'after-delay) - (create-thread - #f - (lambda () - (trace ";after-delay "seconds", sleeping "(current-thread)"\n") - (sleep-current-thread (* seconds 1000)) - (thunk) - (stop-current-thread)))) + (detach-thread + (create-thread + #f + (lambda () + (trace ";after-delay "seconds", sleeping "(current-thread)"\n") + (sleep-current-thread (* seconds 1000)) + (thunk) + (stop-current-thread))))) ;;; * widget-mit ;;; diff --git a/src/gtk/thread.scm b/src/gtk/thread.scm index 74ac3181a..52de604f4 100644 --- a/src/gtk/thread.scm +++ b/src/gtk/thread.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -Copyright (C) 2007, 2008, 2009, 2010 Matthew Birkholz +Copyright (C) 2007, 2008, 2009, 2010, 2011 Matthew Birkholz This file is part of MIT/GNU Scheme. @@ -66,12 +66,13 @@ USA. (trace ";run-gtk done at "(real-time-clock)"\n")) (maybe-signal-io-thread-events))) (yield-current-thread) - (gtk-thread-loop))))))) + (gtk-thread-loop)))))) + (detach-thread gtk-thread)) (define (no-threads-nor-timers) (error "gtk-thread: no threads, no timers: "next-scheduled-timeout)) -(define (kill-gtk-thread) +(define (exit-gtk-thread) (let ((thread gtk-thread)) (set! gtk-thread #f) (if (not thread) (error "A GTk thread was not running.")) @@ -79,6 +80,12 @@ USA. thread (lambda () (exit-current-thread #t))))) +(define (stop-gtk-thread) + (signal-thread-event gtk-thread (lambda () (stop-current-thread)))) + +(define (restart-gtk-thread) + (restart-thread gtk-thread #t #f)) + (define trace? #f) (define-syntax trace diff --git a/src/microcode/uxio.c b/src/microcode/uxio.c index 1e58f9a65..dc776ef90 100644 --- a/src/microcode/uxio.c +++ b/src/microcode/uxio.c @@ -2,7 +2,8 @@ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, - 2006, 2007, 2008, 2009, 2010 Massachusetts Institute of Technology + 2006, 2007, 2008, 2009, 2010, 2011 Massachusetts Institute of + Technology This file is part of MIT/GNU Scheme. @@ -564,14 +565,16 @@ OS_test_select_registry (select_registry_t registry, int blockp) = (poll ((SR_ENTRIES (r)), (SR_N_FDS (r)), (blockp ? INFTIM : 0))); - if (nfds >= 0) + if (nfds > 0) return (nfds); - if (errno != EINTR) + if (nfds < 0 && errno != EINTR) error_system_call (errno, syscall_select); if (OS_process_any_status_change ()) return (SELECT_PROCESS_STATUS_CHANGE); if (pending_interrupts_p ()) return (SELECT_INTERRUPT); + /* nfds == 0, AND no status-change nor interrupts pending */ + return (0); } } @@ -586,14 +589,14 @@ OS_test_select_descriptor (int fd, int blockp, unsigned int mode) int nfds = (poll (pfds, 1, (blockp ? INFTIM : 0))); if (nfds > 0) return (ENCODE_MODE ((pfds [0]) . revents)); - if (nfds == 0) - return (0); - if (errno != EINTR) + if (nfds < 0 && errno != EINTR) error_system_call (errno, syscall_select); if (OS_process_any_status_change ()) return (SELECT_PROCESS_STATUS_CHANGE); if (pending_interrupts_p ()) return (SELECT_INTERRUPT); + /* nfds == 0, AND no status-change nor interrupts pending */ + return (0); } } @@ -731,14 +734,16 @@ OS_test_select_registry (select_registry_t registry, int blockp) (SR_RWRITERS (r)), 0, (blockp ? 0 : (&zero_timeout)))))); - if (nfds >= 0) + if (nfds > 0) return (nfds); - if (errno != EINTR) + if (nfds < 0 && errno != EINTR) error_system_call (errno, syscall_select); if (OS_process_any_status_change ()) return (SELECT_PROCESS_STATUS_CHANGE); if (pending_interrupts_p ()) return (SELECT_INTERRUPT); + /* nfds == 0, AND no status-change nor interrupts pending */ + return (0); } #else error_system_call (ENOSYS, syscall_select); @@ -777,14 +782,14 @@ OS_test_select_descriptor (int fd, int blockp, unsigned int mode) return (((FD_ISSET (fd, (&readable))) ? SELECT_MODE_READ : 0) | ((FD_ISSET (fd, (&writeable))) ? SELECT_MODE_WRITE : 0)); - if (nfds == 0) - return (0); - if (errno != EINTR) + if (nfds < 0 && errno != EINTR) error_system_call (errno, syscall_select); if (OS_process_any_status_change ()) return (SELECT_PROCESS_STATUS_CHANGE); if (pending_interrupts_p ()) return (SELECT_INTERRUPT); + /* nfds == 0, AND no status-change nor interrupts pending */ + return (0); } #else error_system_call (ENOSYS, syscall_select); diff --git a/src/runtime/process.scm b/src/runtime/process.scm index 4ff7e1497..3640cc192 100644 --- a/src/runtime/process.scm +++ b/src/runtime/process.scm @@ -2,7 +2,8 @@ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, - 2006, 2007, 2008, 2009, 2010 Massachusetts Institute of Technology + 2006, 2007, 2008, 2009, 2010, 2011 Massachusetts Institute of + Technology This file is part of MIT/GNU Scheme. @@ -194,12 +195,27 @@ USA. (define (subprocess-wait process) (let loop () - ((ucode-primitive process-wait 1) (subprocess-index process)) + (hook/subprocess-wait process) (let ((status (%subprocess-status process))) (if (eqv? status 0) (loop) (convert-subprocess-status status))))) +(define (normal/subprocess-wait process) + ((ucode-primitive process-wait 1) (subprocess-index process))) + +(define (nonblocking/subprocess-wait process) + (without-interrupts + (lambda () + (let ((status (%subprocess-status process))) + (if (eqv? status 0) + (begin + (block-on-process-status-change) + (subprocess-global-status-tick) + (handle-subprocess-status-change))))))) + +(define hook/subprocess-wait normal/subprocess-wait) + (define (subprocess-continue-foreground process) (let loop () ((ucode-primitive process-continue-foreground 1) @@ -259,12 +275,15 @@ USA. (else (error "Illegal process job-control status:" n))))) (define (handle-subprocess-status-change) + (if hook/subprocess-status-change (hook/subprocess-status-change)) (if (eq? 'NT microcode-id/operating-system) (for-each (lambda (process) (if (memq (subprocess-status process) '(EXITED SIGNALLED)) (close-subprocess-i/o process))) (subprocess-list)))) +(define hook/subprocess-status-change #f) + (define-integrable subprocess-job-control-available? (ucode-primitive os-job-control? 0)) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 68c51f2ec..de0723f20 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -2,7 +2,8 @@ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, - 2006, 2007, 2008, 2009, 2010 Massachusetts Institute of Technology + 2006, 2007, 2008, 2009, 2010, 2011 Massachusetts Institute of + Technology This file is part of MIT/GNU Scheme. @@ -3771,6 +3772,8 @@ USA. handle-subprocess-status-change) (export (runtime socket) handle-subprocess-status-change) + (import (runtime thread) + block-on-process-status-change) (initialization (initialize-package!))) (define-package (runtime synchronous-subprocess) diff --git a/src/runtime/thread-queue.scm b/src/runtime/thread-queue.scm index b9ffa9945..30b2cf3dd 100644 --- a/src/runtime/thread-queue.scm +++ b/src/runtime/thread-queue.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -Copyright (C) 2005, 2009 Matthew Birkholz +Copyright (C) 2005, 2009, 2010 Matthew Birkholz This file is part of MIT/GNU Scheme. @@ -114,6 +114,31 @@ USA. #f) (%queue! queue item)))) +(define (thread-queue/dequeue-no-hang queue timeout) + (guarantee-thread-queue queue 'thread-queue/dequeue-no-hang) + (guarantee-non-negative-fixnum timeout 'thread-queue/dequeue-no-hang) + (thread-queue/dequeue-until queue (+ (real-time-clock) timeout))) + +(define (thread-queue/dequeue-until queue time) + (guarantee-thread-queue queue 'thread-queue/dequeue-until) + (guarantee-integer time 'thread-queue/dequeue-until) + (when-non-empty-before time queue %dequeue!)) + +(declare (integrable-operator when-non-empty-before)) +(define (when-non-empty-before time queue operation) + (without-interrupts + (lambda () + (let loop () + (if (not (%empty? queue)) + (operation queue) + (let ((now (real-time-clock))) + (if (<= time now) + #f + (begin + (register-timer-event (- time now) (lambda () unspecific)) + (suspend-current-thread) + (loop))))))))) + (define (thread-queue/dequeue! queue) (without-interrupts (lambda () @@ -125,41 +150,29 @@ USA. (list (current-thread)))) (suspend-current-thread))))) -(define (thread-queue/peek-no-hang queue #!optional timeout) +(define (thread-queue/peek-no-hang queue timeout) (guarantee-thread-queue queue 'thread-queue/peek-no-hang) - (if (not (default-object? timeout)) - (guarantee-non-negative-fixnum timeout 'thread-queue/peek-no-hang)) - (let ((timeout (if (default-object? timeout) 0 timeout)) - (time (real-time-clock))) - (thread-queue/peek-until queue (+ time timeout)))) + (guarantee-non-negative-fixnum timeout 'thread-queue/peek-no-hang) + (thread-queue/peek-until queue (+ (real-time-clock) timeout))) (define (thread-queue/peek-until queue time) (guarantee-thread-queue queue 'thread-queue/peek-until) (guarantee-integer time 'thread-queue/peek-until) - (without-interrupts - (lambda () - (let loop () - (if (not (%empty? queue)) - (car (%thread-queue/first-pair queue)) - (let ((now (real-time-clock))) - (if (<= time now) - #f - (begin - (register-timer-event (- time now) (lambda () unspecific)) - (suspend-current-thread) - (loop))))))))) + (when-non-empty-before time queue %peek)) (define (thread-queue/peek queue) (without-interrupts (lambda () (do () ((and (not (%empty? queue)) - (car (%thread-queue/first-pair queue)))) + (%peek queue))) (set-%thread-queue/waiting-dequeuers! queue (append! (%thread-queue/waiting-dequeuers queue) (list (current-thread)))) (suspend-current-thread))))) +(define-integrable (%peek queue) + (car (%thread-queue/first-pair queue))) (define (%queue! queue item) (let ((last (%thread-queue/last-pair queue)) diff --git a/src/runtime/thread.scm b/src/runtime/thread.scm index ee209f48f..6f0f0fb94 100644 --- a/src/runtime/thread.scm +++ b/src/runtime/thread.scm @@ -2,7 +2,8 @@ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, - 2006, 2007, 2008, 2009, 2010 Massachusetts Institute of Technology + 2006, 2007, 2008, 2009, 2010, 2011 Massachusetts Institute of + Technology This file is part of MIT/GNU Scheme. @@ -514,7 +515,9 @@ USA. (define (maybe-signal-io-thread-events) (if io-registrations - (signal-select-result (test-select-registry io-registry #f)))) + (let ((result (test-select-registry io-registry #f))) + (trace "maybe-signal-io-thread-events: "result" "io-registry"\n") + (signal-select-result result)))) (define (block-on-io-descriptor descriptor mode) (without-interrupts @@ -552,6 +555,29 @@ USA. (%deregister-io-thread-event registration-2) (%deregister-io-thread-event registration-1) (%maybe-toggle-thread-timer))))))) + +(define (block-on-process-status-change) + (without-interrupts + (lambda () + (let ((registration)) + (dynamic-wind + (lambda () + (let ((thread (current-thread))) + (set! registration + (%register-io-thread-event + 'PROCESS-STATUS-CHANGE + 'READ + thread + (lambda (mode) + (declare (ignore mode)) + unspecific) + #f #t))) + (%maybe-toggle-thread-timer)) + (lambda () + (%suspend-current-thread)) + (lambda () + (%deregister-io-thread-event registration) + (%maybe-toggle-thread-timer))))))) (define (permanently-register-io-thread-event descriptor mode thread event) (register-io-thread-event-1 descriptor mode thread event