(values
(named-lambda (halt-update?)
(or (fix:< start end)
- (read-more? #f)))
+ (read-more? #f #f)))
- (named-lambda (peek-no-hang)
- (let ((event (->event (match-event #f))))
- (if (input-event? event)
- (begin
- (apply-input-event event)
- #f)
- event)))
+ (named-lambda (peek-no-hang msec)
+ (keyboard-peek-busy-no-hang
+ (lambda ()
+ (let ((event (->event (match-event #f))))
+ (if (input-event? event)
+ (begin
+ (apply-input-event event)
+ #f)
+ event)))
+ msec))
(named-lambda (peek)
(->event (match-event #t)))
(named-lambda (read)
(select_registry_t registry, int blockp);
extern int OS_test_select_descriptor
(int fd, int blockp, unsigned int mode);
- extern int OS_pause (void);
+#ifdef ENABLE_SMP
+extern void OS_copy_select_registry
+ (select_registry_t from, select_registry_t to);
+#endif
+ extern int OS_pause (int blockp);
#endif /* SCM_OSIO_H */
return (SR_N_FDS (r));
}
+#ifdef ENABLE_SMP
+void
+OS_copy_select_registry (select_registry_t from, select_registry_t to)
+{
+ struct select_registry_s * f = from;
+ struct select_registry_s * t = to;
+ int fl = SR_LENGTH (f);
+ int tl = SR_LENGTH (t);
+ if (tl < fl)
+ {
+ free (SR_ENTRIES (t));
+ (SR_ENTRIES (t)) = (UX_malloc (SR_BYTES (fl)));
+ (SR_LENGTH (t)) = fl;
+ }
+ memcpy ((SR_ENTRIES (t)), (SR_ENTRIES (f)), (SR_BYTES (SR_N_FDS (f))));
+ (SR_N_FDS (t)) = (SR_N_FDS (f));
+}
+#endif
+
+ void
+ OS_select_registry_entry (select_registry_t registry,
+ unsigned int index,
+ int * fd_r,
+ unsigned int * mode_r)
+ {
+ struct select_registry_s * r = registry;
+ (*fd_r) = ((SR_ENTRY (r, index)) -> fd);
+ (*mode_r) = (ENCODE_MODE ((SR_ENTRY (r, index)) -> events));
+ }
+
void
OS_select_registry_result (select_registry_t registry,
unsigned int index,
n = SELECT_INTERRUPT;
}
UX_sigprocmask (SIG_SETMASK, &old, NULL);
- return (n);
-#else
- /* Wait-for-io must spin. */
- return
- ((OS_process_any_status_change ())
- ? SELECT_PROCESS_STATUS_CHANGE
- : SELECT_INTERRUPT);
+
+#else /* not HAVE_SIGSUSPEND */
+ INTERRUPTABLE_EXTENT
+ (n, (((OS_process_any_status_change ())
+ || (pending_interrupts_p ()))
+ ? ((errno = EINTR), (-1))
+ : ((UX_pause ()), (0))));
+ if (OS_process_any_status_change())
+ n = SELECT_PROCESS_STATUS_CHANGE;
+ else
+ n = SELECT_INTERRUPT;
+
#endif
+ return (n);
}
+
+ int
+ OS_pause (int blockp)
+ {
+ if (!blockp)
+ {
+ return ((OS_process_any_status_change ())
+ ? SELECT_PROCESS_STATUS_CHANGE
+ : SELECT_INTERRUPT);
+ }
+ else
+ return (safe_pause ());
+ }
(else (next-id (1+ id)))))))
(define (de-register-c-callback id)
- (vector-set! registered-callbacks id #f)
- (if (< id first-free-id)
- (set! first-free-id id)))
+ (with-thread-mutex-locked registered-callbacks-mutex
+ (lambda ()
+ (vector-set! registered-callbacks id #f)
- ;; Uncomment to recycle ids.
+ (if (< id first-free-id)
- (set! first-free-id id))
- )))
++ (set! first-free-id id)))))
(define (normalize-aliens! args)
;; Any vectors among ARGS are assumed to be freshly-consed aliens
(syntax-rules ()
((_ MSG ...)
(if %trace?
- (outf-error MSG ...)))))
+ (outf-error MSG ... "\n")))))
-(define (tindent)
- (make-string (* 2 (length calloutback-stack)) #\space))
+(define (tindent id)
- (make-string (* 2 (length (vector-ref calloutback-stacks id))) #\space))
++ (make-string (* 2 (length (vector-ref calloutback-stacks id))) #\space))
(pathname=? pathname* pathname))))))
(define (find-dld-handle predicate)
- (find-matching-item dld-handles predicate))
+ (with-thread-mutex-locked dld-handles-mutex
+ (lambda ()
+ (find-matching-item dld-handles predicate))))
(define (all-dld-handles)
- (list-copy dld-handles))
-
-(define (unload-all-dld-object-files)
- (without-interrupts
- (lambda ()
- (let loop ()
- (if (pair? dld-handles)
- (let ((handle (car dld-handles)))
- (set! dld-handles (cdr dld-handles))
- (%dld-unload-file handle)
- (loop)))))))
+ (with-thread-mutex-locked dld-handles-mutex
+ (lambda ()
- (list-copy dld-handles))))
++ (list-copy dld-handles))))
((3) 'JOB-CONTROL)
(else (error "Illegal process job-control status:" n)))))
\f
+ (define last-global-tick '())
+
(define (handle-subprocess-status-change)
- (let ((latest-tick (subprocess-global-status-tick)))
- (if (not (eq? latest-tick last-global-tick))
- (begin
- (signal-subprocess-status-change)
- (set! last-global-tick latest-tick))))
+ (with-threads-locked %handle-subprocess-status-change)
(if (eq? 'NT microcode-id/operating-system)
(for-each (lambda (process)
(if (memq (subprocess-status process) '(EXITED SIGNALLED))
(define (%maybe-deregister-io-thread-event tentry)
;; Ensure that another thread does not unwind our registration.
- (if (eq? (current-thread) (tentry/thread tentry))
+ (assert-locked '%maybe-deregister-io-thread-event)
+ (if (and (tentry/dentry tentry)
+ (eq? (%current-thread (%id)) (tentry/thread tentry)))
(delete-tentry! tentry)))
+
+ (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 (register-subprocess-status-change-event event)
+ (guarantee-procedure-of-arity event 1 'register-subprocess-status-change-event)
+ (without-interrupts
+ (lambda ()
+ (%register-io-thread-event
+ 'PROCESS-STATUS-CHANGE
+ 'READ
+ (current-thread)
+ event
+ #t ;permanent?
+ #f ;front?
+ ))))
\f
(define (permanently-register-io-thread-event descriptor mode thread event)
- (register-io-thread-event-1 descriptor mode thread event
- #t 'PERMANENTLY-REGISTER-IO-THREAD-EVENT))
+ (guarantee-select-mode mode 'permanently-register-io-thread-event)
+ (guarantee-thread thread 'permanently-register-io-thread-event)
+ (let ((registration))
+ (set! registration
+ (make-tentry thread
+ (lambda (mode*)
+ (event mode*)
+ (with-threads-locked
+ (lambda ()
+ (%register-io-thread-event descriptor mode
+ registration #f)
+ (%maybe-toggle-thread-timer)
+ (%maybe-wake-io-waiter))))))
+ (with-threads-locked
+ (lambda ()
+ (%register-io-thread-event descriptor mode registration #f)
+ (%maybe-toggle-thread-timer)
+ (%maybe-wake-io-waiter)))
+ registration))
(define (register-io-thread-event descriptor mode thread event)
- (register-io-thread-event-1 descriptor mode thread event
- #f 'REGISTER-IO-THREAD-EVENT))
-
-(define (register-io-thread-event-1 descriptor mode thread event
- permanent? caller)
- (guarantee-select-mode mode caller)
- (guarantee-thread thread caller)
- (without-interrupts
- (lambda ()
- (let ((registration
- (%register-io-thread-event descriptor mode thread event
- permanent? #f)))
+ (guarantee-select-mode mode 'register-io-thread-event)
+ (guarantee-thread thread 'register-io-thread-event)
+ (let ((registration (make-tentry thread event)))
+ (with-threads-locked
+ (lambda ()
+ (%register-io-thread-event descriptor mode registration #f)
(%maybe-toggle-thread-timer)
- registration))))
+ (%maybe-wake-io-waiter)))
+ registration))
(define (deregister-io-thread-event tentry)
(if (not (tentry? tentry))
projects / mit-scheme.git / commitdiff