srfi-18.scm

Scheme跨平台编译器

;;;; srfi-18.scm - Simple thread unit - felix
;
; Copyright (c) 2000-2007, Felix L. Winkelmann
; Copyright (c) 2008, The Chicken Team
; All rights reserved.
;
; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
; conditions are met:
;
;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
;     disclaimer. 
;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
;     disclaimer in the documentation and/or other materials provided with the distribution. 
;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
;     products derived from this software without specific prior written permission. 
;
; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
; POSSIBILITY OF SUCH DAMAGE.


(declare
 (unit srfi-18)
 (uses scheduler)
 (disable-warning redef)
 (disable-interrupts)
 (usual-integrations)
 (hide ##sys#compute-time-limit) )

(cond-expand
 [paranoia]
 [else
  (declare
    (no-bound-checks)
    (no-procedure-checks-for-usual-bindings)
    (bound-to-procedure
     ##sys#thread-yield!
     condition-property-accessor ##sys#tty-port? ##sys#thread-block-for-i/o thread-yield! ##sys#thread-unblock!
     ##sys#thread-basic-unblock! gensym ##sys#thread-block-for-timeout! ##sys#thread-kill!
     ##sys#thread-block-for-termination! make-thread ##sys#exact->inexact ##sys#flonum-fraction truncate
     ##sys#add-to-ready-queue
     ##sys#schedule ##sys#make-thread
     ##sys#check-number ##sys#error ##sys#signal-hook ##sys#signal
     ##sys#current-exception-handler ##sys#abandon-mutexes ##sys#check-structure ##sys#structure? ##sys#make-mutex
     ##sys#delq ##sys#compute-time-limit ##sys#fudge) ) ] )

(cond-expand
 [unsafe
  (eval-when (compile)
    (define-macro (##sys#check-structure . _) '(##core#undefined))
    (define-macro (##sys#check-range . _) '(##core#undefined))
    (define-macro (##sys#check-pair . _) '(##core#undefined))
    (define-macro (##sys#check-list . _) '(##core#undefined))
    (define-macro (##sys#check-symbol . _) '(##core#undefined))
    (define-macro (##sys#check-string . _) '(##core#undefined))
    (define-macro (##sys#check-char . _) '(##core#undefined))
    (define-macro (##sys#check-exact . _) '(##core#undefined))
    (define-macro (##sys#check-port . _) '(##core#undefined))
    (define-macro (##sys#check-number . _) '(##core#undefined))
    (define-macro (##sys#check-byte-vector . _) '(##core#undefined)) ) ]
 [else
  (declare (emit-exports "srfi-18.exports"))] )

(register-feature! 'srfi-18)

(define-macro (dbg . args) #f)
#;(define-macro (dbg . args)
  `(print "DBG: " ,@args) )


;;; Helper routines:

(define ##sys#compute-time-limit
  (let ([truncate truncate])
    (lambda (tm)
      (and tm
	   (cond [(##sys#structure? tm 'time) (##sys#slot tm 1)]
		 [(number? tm) (fx+ (##sys#fudge 16) (inexact->exact (truncate (* tm 1000))))]
		 [else (##sys#signal-hook #:type-error "invalid timeout argument" tm)] ) ) ) ) )


;;; Time objects:

(declare
  (foreign-declare #<<EOF
static C_TLS long C_ms;
#define C_get_seconds   C_seconds(&C_ms)
EOF
) )

(define-foreign-variable C_get_seconds double)
(define-foreign-variable C_startup_time_seconds double)
(define-foreign-variable C_ms long)

(define (current-time)
  (let* ([s C_get_seconds]
	 [ss C_startup_time_seconds] 
	 [ms C_ms] )
    (##sys#make-structure
     'time
     (inexact->exact (truncate (+ (* (- s ss) 1000) C_ms)))
     s
     C_ms) ) )

(define srfi-18:current-time current-time)

(define (time->seconds tm)
  (##sys#check-structure tm 'time 'time->seconds)
  (+ (##sys#slot tm 2) (/ (##sys#slot tm 3) 1000)) )

(define (time->milliseconds tm)
  (##sys#check-structure tm 'time 'time->milliseconds)
  (+ (inexact->exact (* (- (##sys#slot tm 2) C_startup_time_seconds) 1000))
     (##sys#slot tm 3) ) )

(define (seconds->time n)
  (##sys#check-number n 'seconds->time)
  (let* ([n2 (max 0 (- n C_startup_time_seconds))] ; seconds since startup
	 [ms (truncate (* 1000 (##sys#flonum-fraction (##sys#exact->inexact n))))] ; milliseconds
	 [n3 (inexact->exact (truncate (+ (* n2 1000) ms)))] ) ; milliseconds since startup
    (##sys#make-structure 'time n3 (truncate n) (inexact->exact ms)) ) )

(define (milliseconds->time nms)
  (##sys#check-exact nms 'milliseconds->time)
  (let ((s (+ C_startup_time_seconds (/ nms 1000))))
    (##sys#make-structure 'time nms s 0) ) )

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

(define srfi-18:time? time?)


;;; Exception handling:

(define raise ##sys#signal)

(define (join-timeout-exception? x) 
  (and (##sys#structure? x 'condition)
       (memq 'join-timeout-exception (##sys#slot x 1)) ) )

(define (abandoned-mutex-exception? x)
  (and (##sys#structure? x 'condition)
       (memq 'abandoned-mutex-exception (##sys#slot x 1)) ) )

(define (terminated-thread-exception? x)
  (and (##sys#structure? x 'condition)
       (memq 'terminated-thread-exception (##sys#slot x 1)) ) )

(define (uncaught-exception? x)
  (and (##sys#structure? x 'condition)
       (memq 'uncaught-exception (##sys#slot x 1)) ) )

(define uncaught-exception-reason
  (condition-property-accessor 'uncaught-exception 'reason) )


;;; Threads:

(define make-thread
  (let ((gensym gensym))
    (lambda (thunk . name)
      (let ((thread
	     (##sys#make-thread
	      #f
	      'created
	      (if (pair? name) (##sys#slot name 0) (gensym 'thread))
	      (##sys#slot ##sys#current-thread 9) ) ) )
	(##sys#setslot 
	 thread 1 
	 (lambda () 
	   (##sys#call-with-values
	    thunk
	    (lambda results
	      (##sys#setslot thread 2 results)
	      (##sys#thread-kill! thread 'dead)
	      (##sys#schedule) ) ) ) )
	thread) ) ) )

(define (thread? x) (##sys#structure? x 'thread))
(define (current-thread) ##sys#current-thread)

(define (thread-state thread)
  (##sys#check-structure thread 'thread 'thread-state)
  (##sys#slot thread 3) )

(define (thread-specific thread)
  (##sys#check-structure thread 'thread 'thread-specific)
  (##sys#slot thread 10) )

(define (thread-specific-set! thread x)
  (##sys#check-structure thread 'thread 'thread-specific-set!)
  (##sys#setslot thread 10 x) )

(define (thread-quantum thread)
  (##sys#check-structure thread 'thread 'thread-quantum)
  (##sys#slot thread 9) )

(define (thread-quantum-set! thread q)
  (##sys#check-structure thread 'thread 'thread-quantum-set!)
  (##sys#check-exact q 'thread-quantum-set!)
  (##sys#setislot thread 9 (fxmax q 10)) )

(define (thread-name x)
  (##sys#check-structure x 'thread 'thread-name)
  (##sys#slot x 6) )

(define thread-start!
  (let ([make-thread make-thread])
    (lambda (thread)
      (if (procedure? thread)
	  (set! thread (make-thread thread))
	  (##sys#check-structure thread 'thread 'thread-start!) )
      (unless (eq? 'created (##sys#slot thread 3))
	(##sys#error 'thread-start! "thread can not be started a second time" thread) )
      (##sys#setslot thread 3 'ready)
      (##sys#add-to-ready-queue thread) 
      thread) ) )

(define thread-yield! ##sys#thread-yield!) ;In library.scm

(define thread-join!
  (lambda (thread . timeout)
    (##sys#check-structure thread 'thread 'thread-join!)
    (let* ((limit (and (pair? timeout) (##sys#compute-time-limit (##sys#slot timeout 0))))
	   (rest (and (pair? timeout) (##sys#slot timeout 1)))
	   (tosupplied (and rest (pair? rest)))
	   (toval (and tosupplied (##sys#slot rest 0))) )
      (##sys#call-with-current-continuation
       (lambda (return)
	 (let ([ct ##sys#current-thread])
	   (when limit (##sys#thread-block-for-timeout! ct limit))
	   (##sys#setslot
	    ct 1
	    (lambda ()
	      (case (##sys#slot thread 3)
		[(dead) (apply return (##sys#slot thread 2))]
		[(terminated)
		 (return 
		  (##sys#signal
		   (##sys#make-structure 
		    'condition '(uncaught-exception)