srfi-18.scm

Scheme跨平台编译器

		    (list '(uncaught-exception . reason) (##sys#slot thread 7)) ) ) ) ]
		[else
		 (return
		  (if tosupplied
		      toval
		      (##sys#signal
		       (##sys#make-structure 'condition '(join-timeout-exception) '())) ) ) ] ) ) )
	   (##sys#thread-block-for-termination! ct thread) 
	   (##sys#schedule) ) ) ) ) ) )
	   
(define (thread-terminate! thread)
  (##sys#check-structure thread 'thread 'thread-terminate!)
  (when (eq? thread ##sys#primordial-thread)
    ((##sys#exit-handler)) )
  (##sys#setslot thread 2 (list (##core#undefined)))
  (##sys#setslot thread 7 (##sys#make-structure 'condition '(terminated-thread-exception) '()))
  (##sys#thread-kill! thread 'terminated)
  (when (eq? thread ##sys#current-thread) (##sys#schedule)) )

(define (thread-suspend! thread)
  (##sys#check-structure thread 'thread 'thread-suspend!)
  (##sys#setslot thread 3 'suspended)
  (when (eq? thread ##sys#current-thread)
    (##sys#call-with-current-continuation
     (lambda (return)
       (##sys#setslot thread 1 (lambda () (return (##core#undefined))))
       (##sys#schedule) ) ) ) )

(define (thread-resume! thread)
  (##sys#check-structure thread 'thread 'thread-resume!)
  (when (eq? (##sys#slot thread 3) 'suspended)
    (##sys#setslot thread 3 'ready)
    (##sys#add-to-ready-queue thread) ) )

(define (thread-sleep! tm)
  (define (sleep limit loc)
    (##sys#call-with-current-continuation
     (lambda (return)
       (let ((ct ##sys#current-thread))
	 (##sys#setslot ct 1 (lambda () (return (##core#undefined))))
	 (##sys#thread-block-for-timeout! ct limit)
	 (##sys#schedule) ) ) ) )
  (unless tm (##sys#signal-hook #:type-error 'thread-sleep! "invalid timeout argument" tm))
  (sleep (##sys#compute-time-limit tm) 'thread-sleep!) )


;;; Mutexes:

(define (mutex? x) (##sys#structure? x 'mutex))

(define make-mutex
  (let ((gensym gensym))
    (lambda id
      (let* ((id (if (pair? id) (car id) (gensym 'mutex)))
	     (m (##sys#make-mutex id ##sys#current-thread)) )
	m) ) ) )

(define (mutex-name x)
  (##sys#check-structure x 'mutex 'mutex-name) 
  (##sys#slot x 1) )

(define (mutex-specific mutex)
  (##sys#check-structure mutex 'mutex 'mutex-specific)
  (##sys#slot mutex 6) )

(define (mutex-specific-set! mutex x)
  (##sys#check-structure mutex 'mutex 'mutex-specific-set!)
  (##sys#setslot mutex 6 x) )

(define (mutex-state mutex)
  (##sys#check-structure mutex 'mutex 'mutex-state)
  (cond [(##sys#slot mutex 5) (or (##sys#slot mutex 2) 'not-owned)]
	[(##sys#slot mutex 4) 'abandoned]
	[else 'not-abandoned] ) )

(define mutex-lock! 
  (lambda (mutex . ms-and-t)
    (##sys#check-structure mutex 'mutex 'mutex-lock!)
    (let* ([limitsup (pair? ms-and-t)]
	   [limit (and limitsup (##sys#compute-time-limit (car ms-and-t)))]
	   [threadsup (fx> (length ms-and-t) 1)]
	   [thread (and threadsup (cadr ms-and-t))] 
	   [abd (##sys#slot mutex 4)] )
      (when thread (##sys#check-structure thread 'thread 'mutex-lock!))
      (##sys#call-with-current-continuation
       (lambda (return)
	 (let ([ct ##sys#current-thread])
	   (define (switch)
	     (##sys#setslot mutex 3 (##sys#append (##sys#slot mutex 3) (list ct)))
	     (##sys#schedule) )
	   (define (check)
	     (when abd
	       (return (##sys#signal (##sys#make-structure 'condition '(abandoned-mutex-exception) '()))) ) )
	   (dbg ct ": locking " mutex)
	   (cond [(not (##sys#slot mutex 5))
		  (if (and threadsup (not thread))
		      (begin
			(##sys#setislot mutex 2 #f)
			(##sys#setislot mutex 5 #t) )
		      (let* ([t (or thread ct)]
			     [ts (##sys#slot t 3)] )
			(if (or (eq? 'terminated ts) (eq? 'dead ts))
			    (##sys#setislot mutex 4 #t)
			    (begin
			      (##sys#setislot mutex 5 #t)
			      (##sys#setslot t 8 (cons mutex (##sys#slot t 8)))
			      (##sys#setslot mutex 2 t) ) ) ) )
		  (check)
		  (return #t) ]
		 [limit
		  (check)
		  (##sys#setslot
		   ct 1 
		   (lambda ()
		     (##sys#setslot mutex 3 (##sys#delq ct (##sys#slot mutex 3)))
		     (##sys#setslot ##sys#current-thread 8 (cons mutex (##sys#slot ##sys#current-thread 8)))
		     (##sys#setslot mutex 2 thread)
		     #f) )
		  (##sys#thread-block-for-timeout! ct limit)
		  (switch) ]
		 [else
		  (##sys#setslot ct 3 'sleeping)
		  (##sys#setslot ct 1 (lambda () (return #t)))
		  (switch) ] ) ) ) ) ) ) )

(define mutex-unlock!
  (lambda (mutex . cvar-and-to)
    (##sys#check-structure mutex 'mutex 'mutex-unlock!)
    (let ([ct ##sys#current-thread]
	  [cvar (and (pair? cvar-and-to) (car cvar-and-to))]
	  [timeout (and (fx> (length cvar-and-to) 1) (cadr cvar-and-to))] )
      (dbg ct ": unlocking " mutex)
      (when cvar (##sys#check-structure cvar 'condition-variable 'mutex-unlock!))
      (##sys#call-with-current-continuation
       (lambda (return)
	 (let ([waiting (##sys#slot mutex 3)]
	       [limit (and timeout (##sys#compute-time-limit timeout))] 
	       [result #t] )
	   (##sys#setislot mutex 4 #f)
	   (##sys#setislot mutex 5 #f)
	   (##sys#setslot ct 8 (##sys#delq mutex (##sys#slot ct 8)))
	   (##sys#setslot ct 1 (lambda () (return result)))
	   (when cvar
	     (##sys#setslot cvar 2 (##sys#append (##sys#slot cvar 2) (##sys#list ct)))
	     (cond [limit
		    (##sys#setslot 
		     ct 1
		     (lambda () 
		       (##sys#setslot cvar 2 (##sys#delq ct (##sys#slot cvar 2)))
		       (return #f) ) )
		    (##sys#thread-block-for-timeout! ct limit) ]
		   [else 
		    (##sys#setslot ct 3 'sleeping)] ) )
	   (unless (null? waiting)
	     (let* ([wt (##sys#slot waiting 0)]
		    [wts (##sys#slot wt 3)] )
	       (##sys#setslot mutex 3 (##sys#slot waiting 1))
	       (##sys#setislot mutex 5 #t)
	       (when (or (eq? wts 'blocked) (eq? wts 'sleeping))
		 (##sys#setslot mutex 2 wt)
		 (##sys#setslot wt 8 (cons mutex (##sys#slot wt 8)))
		 (when (eq? wts 'sleeping) (##sys#add-to-ready-queue wt) ) ) ) )
	   (##sys#schedule) ) ) ) ) ) )


;;; Condition variables:

(define make-condition-variable
  (let ([gensym gensym])
    (lambda name
      (##sys#make-structure
       'condition-variable 
       (if (pair? name)			; #1 name
	   (car name)
	   (gensym 'condition-variable) )
       '()				; #2 list of waiting threads
       (##core#undefined) ) ) ) )	; #3 specific

(define (condition-variable? x)
  (##sys#structure? x 'condition-variable) )

(define (condition-variable-specific cv)
  (##sys#check-structure cv 'condition-variable 'condition-variable-specific)
  (##sys#slot cv 3) )

(define (condition-variable-specific-set! cv x)
  (##sys#check-structure cv 'condition-variable 'condition-variable-specific-set!)
  (##sys#setslot cv 3 x) )

(define (condition-variable-signal! cvar)
  (##sys#check-structure cvar 'condition-variable 'condition-variable-signal!)
  (dbg "signalling " cvar)
  (let ([ts (##sys#slot cvar 2)])
    (unless (null? ts)
      (let* ([t0 (##sys#slot ts 0)]
	     [t0s (##sys#slot t0 3)] )
	(##sys#setslot cvar 2 (##sys#slot ts 1))
	(when (or (eq? t0s 'blocked) (eq? t0s 'sleeping))
	  (##sys#thread-basic-unblock! t0) ) ) ) ) )

(define (condition-variable-broadcast! cvar)
  (##sys#check-structure cvar 'condition-variable 'condition-variable-broadcast!)
  (dbg "broadcasting " cvar)
  (##sys#for-each
   (lambda (ti)
     (let ([tis (##sys#slot ti 3)])
       (when (or (eq? tis 'blocked) (eq? tis 'sleeping))
	 (##sys#thread-basic-unblock! ti) ) ) )
   (##sys#slot cvar 2) )
  (##sys#setislot cvar 2 '()) )


;;; Change continuation of thread to signal an exception:

(define (thread-signal! thread exn)
  (##sys#check-structure thread 'thread 'thread-signal!)
  (if (eq? thread ##sys#current-thread)
      (##sys#signal exn)
      (let ([old (##sys#slot thread 1)])
	(##sys#setslot
	 thread 1
	 (lambda ()
	   (##sys#signal exn)
	   (old) ) )
	(##sys#thread-unblock! thread) ) ) )


;;; Don't block in the repl: (by Chris Double)

(unless (eq? (build-platform) 'msvc)
  (set! ##sys#read-prompt-hook
    (let ([old ##sys#read-prompt-hook]
	  [thread-yield! thread-yield!] )
      (lambda ()
	(when (or (##sys#fudge 12) (##sys#tty-port? ##sys#standard-input))
	  (old)
	  (##sys#thread-block-for-i/o! ##sys#current-thread 0 #t)
	  (thread-yield!)))) ) )


;;; Waiting for I/O on file-descriptor

(define (thread-wait-for-i/o! fd #!optional (mode #:all))
  (##sys#check-exact fd 'thread-wait-for-i/o!)
  (##sys#thread-block-for-i/o! ##sys#current-thread fd mode) 
  (thread-yield!) )