Changeset 13413 in project


Ignore:
Timestamp:
02/26/09 09:10:40 (11 years ago)
Author:
Jim Ursetto
Message:

Restored srfi-18.scm to the latest revision, after fixing unbound variable references and %seconds->milliseconds bug.

Location:
chicken/branches/chicken-3
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • chicken/branches/chicken-3/NEWS

    r13411 r13413  
     13.5.2
     2
     3- Restored srfi-18.scm after fixing unbound variable references and
     4  %seconds->milliseconds bug. [Jim Ursetto]
     5
    163.5.1
    27
    3 - Reverted srfi-18 to that Chicken 3.4.0
     8- Reverted srfi-18 to that of Chicken 3.4.0
     9- Use unsetenv instead of putenv when available; fixes behavior
     10  on OS X [Jim Ursetto, reported by Drew Hess]
    411
    5123.5.0
  • chicken/branches/chicken-3/srfi-18.scm

    r13411 r13413  
    99;
    1010;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
    11 ;     disclaimer. 
     11;     disclaimer.
    1212;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
    13 ;     disclaimer in the documentation and/or other materials provided with the distribution. 
     13;     disclaimer in the documentation and/or other materials provided with the distribution.
    1414;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
    15 ;     products derived from this software without specific prior written permission. 
     15;     products derived from this software without specific prior written permission.
    1616;
    1717; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
     
    3232 (disable-interrupts)
    3333 (usual-integrations)
    34  (hide ##sys#compute-time-limit) )
     34 (hide ##sys#timeout->limit ##sys#sleep-current-thread) )
    3535
    3636(cond-expand
     
    4141    (no-procedure-checks-for-usual-bindings)
    4242    (bound-to-procedure
     43     condition? condition-predicate signal
    4344     ##sys#thread-yield!
    4445     condition-property-accessor ##sys#tty-port? ##sys#thread-block-for-i/o thread-yield! ##sys#thread-unblock!
     
    4849     ##sys#schedule ##sys#make-thread
    4950     ##sys#check-number ##sys#error ##sys#signal-hook ##sys#signal
    50      ##sys#current-exception-handler ##sys#abandon-mutexes ##sys#check-structure ##sys#structure? ##sys#make-mutex
    51      ##sys#delq ##sys#compute-time-limit ##sys#fudge) ) ] )
     51     ##sys#current-exception-handler ##sys#check-structure ##sys#structure? ##sys#make-mutex
     52     ##sys#delq ##sys#timeout->limit ##sys#fudge) ) ] )
    5253
    5354(cond-expand
     
    6364    (define-macro (##sys#check-exact . _) '(##core#undefined))
    6465    (define-macro (##sys#check-port . _) '(##core#undefined))
    65     (define-macro (##sys#check-number . _) '(##core#undefined))
    66     (define-macro (##sys#check-byte-vector . _) '(##core#undefined)) ) ]
     66    (define-macro (##sys#check-number . _) '(##core#undefined)) ) ]
    6767 [else
    6868  (declare (emit-exports "srfi-18.exports"))] )
     
    7575
    7676
    77 ;;; Helper routines:
    78 
    79 (define ##sys#compute-time-limit
    80   (let ([truncate truncate])
    81     (lambda (tm)
    82       (and tm
    83            (cond [(##sys#structure? tm 'time) (##sys#slot tm 1)]
    84                  [(number? tm) (fx+ (##sys#fudge 16) (inexact->exact (truncate (* tm 1000))))]
    85                  [else (##sys#signal-hook #:type-error "invalid timeout argument" tm)] ) ) ) ) )
     77;;; Helpers
     78
     79(define-inline (%append-item ls x)
     80  (##sys#append ls (list x)) )
     81
     82
     83;;; Time object helpers:
     84
     85;; Time layout:
     86;
     87; Clock time is since Unix-epoch (Jan 1, 1970 00:00 am) since C Library routines are used.
     88;
     89; 0     Tag - 'time (symbol)
     90; 1     Milliseconds since startup (fixnum)
     91; 2     Seconds (integer)
     92; 3     Milliseconds (fixnum)
     93
     94(define-inline (%time? x)
     95  (##sys#structure? x 'time) )
     96
     97(define-inline (%time-timeout tm)
     98  (##sys#slot tm 1) )
     99
     100(define-inline (%time-seconds tm)
     101  (##sys#slot tm 2) )
     102
     103(define-inline (%time-milliseconds tm)
     104  (##sys#slot tm 3) )
     105
     106(define-inline (%check-time x loc)
     107  (##sys#check-structure x 'time loc) )
     108
     109; Enforces the representation constraints
     110(define-inline (%make-time nms s ms)
     111  (##sys#make-structure 'time
     112   (inexact->exact (truncate nms))
     113   (truncate s)
     114   (inexact->exact (truncate ms))) )
     115
     116
     117;;; Thread object helpers:
     118
     119;; Thread layout:
     120;
     121; 0     Tag - 'thread
     122; 1     Thunk (procedure)
     123; 2     Results (list-of object)
     124; 3     State (symbol)
     125; 4     Block-timeout (fixnum or #f)
     126; 5     State buffer (vector)
     127;       0       Dynamic winds (list)
     128;       1       Standard input (port)
     129;       2       Standard output (port)
     130;       3       Standard error (port)
     131;       4       Exception handler (procedure)
     132;       5       Parameters (vector)
     133; 6     Name (object)
     134; 7     Reason (condition of #f)
     135; 8     Mutexes (list-of mutex)
     136; 9     Quantum (fixnum)
     137; 10    Specific (object)
     138; 11    Block object (thread or (pair-of fd io-mode))
     139; 12    Recipients (list-of thread)
     140; 13    Unblocked by timeout? (boolean)
     141
     142(define-inline (%thread? x)
     143  (##sys#structure? x 'thread) )
     144
     145(define-inline (%thread-thunk th)
     146  (##sys#slot th 1) )
     147
     148(define-inline (%thread-thunk-set! th tk)
     149  (##sys#setslot th 1 tk) )
     150
     151(define-inline (%thread-results th)
     152  (##sys#slot th 2) )
     153
     154(define-inline (%thread-results-set! th rs)
     155  (##sys#setslot th 2 rs) )
     156
     157(define-inline (%thread-state th)
     158  (##sys#slot th 3) )
     159
     160(define-inline (%thread-state-set! th st)
     161  (##sys#setslot th 3 st) )
     162
     163(define-inline (%thread-block-timeout th)
     164  (##sys#slot th 4) )
     165
     166(define-inline (%thread-block-timeout-set! th to)
     167  (##sys#setislot th 4 to) )
     168
     169(define-inline (%thread-block-timeout-clear! th)
     170  (%thread-block-timeout-set! th #f) )
     171
     172(define-inline (%thread-state-buffer th)
     173  (##sys#slot th 5) )
     174
     175(define-inline (%thread-state-buffer-set! th v)
     176  (##sys#setslot th 5 v) )
     177
     178(define-inline (%thread-name th)
     179  (##sys#slot th 6) )
     180
     181(define-inline (%thread-reason th)
     182  (##sys#slot th 7) )
     183
     184(define-inline (%thread-reason-set! th cd)
     185  (##sys#setslot th 7 cd) )
     186
     187(define-inline (%thread-mutexes th)
     188  (##sys#slot th 8) )
     189
     190(define-inline (%thread-mutexes-set! th wt)
     191  (##sys#setslot th 8 wt) )
     192
     193(define-inline (%thread-mutexes-empty? th)
     194  (null? (%thread-mutexes th)) )
     195
     196(define-inline (%thread-mutexes-empty! th)
     197  (##sys#setislot th 8 '()) )
     198
     199(define-inline (%thread-mutexes-add! th mx)
     200  (%thread-mutexes-set! th (cons mx (%thread-mutexes th))) )
     201
     202(define-inline (%thread-mutexes-delete! th mx)
     203  (%thread-mutexes-set! th (##sys#delq mx (%thread-mutexes th))) )
     204
     205(define-inline (%thread-quantum th)
     206  (##sys#slot th 9) )
     207
     208(define-inline (%thread-quantum-set! th qt)
     209  (##sys#setislot th 9 qt) )
     210
     211(define-inline (%thread-specific th)
     212  (##sys#slot th 10) )
     213
     214(define-inline (%thread-specific-set! th x)
     215  (##sys#setslot th 10 x) )
     216
     217(define-inline (%thread-block-object th)
     218  (##sys#slot th 11) )
     219
     220(define-inline (%thread-block-object-set! th x)
     221  (##sys#setslot th 11 x) )
     222
     223(define-inline (%thread-block-object-clear! th)
     224  (##sys#setislot th 11 #f) )
     225
     226(define-inline (%thread-recipients th)
     227  (##sys#slot th 12) )
     228
     229(define-inline (%thread-recipients-set! th x)
     230  (##sys#setslot th 12 x) )
     231
     232(define-inline (%thread-recipients-empty! th)
     233  (##sys#setislot th 12 '()) )
     234
     235(define-inline (%thread-recipients-add! th rth)
     236  (%thread-recipients-set! t (cons rth (%thread-recipients t))) )
     237
     238(define-inline (%thread-recipients-process! th tk)
     239  (let ([rs (%thread-recipients t)])
     240    (unless (null? rs) (for-each tk rs) ) )
     241  (thread-recipients-empty! t) )
     242
     243(define-inline (%thread-unblocked-by-timeout? th)
     244  (##sys#slot th 13) )
     245
     246(define-inline (%thread-unblocked-by-timeout-set! th f)
     247  (##sys#setislot th 13 f) )
     248
     249(define-inline (%make-thread nm tk #!optional (qt (%thread-quantum ##sys#current-thread)))
     250  (##sys#make-thread tk 'created nm qt) )
     251
     252(define-inline (%check-thread x loc)
     253  (##sys#check-structure x 'thread loc) )
     254
     255
     256;;; Mutex object helpers:
     257
     258;; Mutex layout:
     259;
     260; 0     Tag - 'mutex
     261; 1     Name (object)
     262; 2     Thread (thread or #f)
     263; 3     Waiting threads (FIFO list)
     264; 4     Abandoned? (boolean)
     265; 5     Locked? (boolean)
     266; 6     Specific (object)
     267
     268(define-inline (%mutex? x)
     269  (##sys#structure? x 'mutex) )
     270
     271(define-inline (%mutex-name mx)
     272  (##sys#slot mx 1) )
     273
     274(define-inline (%mutex-thread mx)
     275  (##sys#slot mx 2) )
     276
     277(define-inline (%mutex-thread-set! mx th)
     278  (##sys#setslot mx 2 th) )
     279
     280(define-inline (%mutex-thread-clear! mx)
     281  (##sys#setislot mx 2 #f) )
     282
     283(define-inline (%mutex-waiters mx)
     284  (##sys#slot mx 3) )
     285
     286(define-inline (%mutex-waiters-set! mx wt)
     287  (##sys#setslot mx 3 wt) )
     288
     289(define-inline (%mutex-waiters-add! mx th)
     290  (%mutex-waiters-set! mx (%append-item (%mutex-waiters mx) th)) )
     291
     292(define-inline (%mutex-waiters-delete! mx th)
     293  (%mutex-waiters-set! mx (##sys#delq th (%mutex-waiters mx))) )
     294
     295(define-inline (%mutex-waiters-empty? mx)
     296  (null? (%mutex-waiters mx)) )
     297
     298(define-inline (%mutex-waiters-empty! mx)
     299  (##sys#setislot mx 3 '()) )
     300
     301(define-inline (%mutex-waiters-pop! mx)
     302  (let* ([wt (%mutex-waiters mx)]
     303         [top (car wt)])
     304    (%mutex-waiters-set! mx (cdr wt))
     305    top ) )
     306
     307(define-inline (%mutex-abandoned? mx)
     308  (##sys#slot mx 4) )
     309
     310(define-inline (%mutex-abandoned-set! mx f)
     311  (##sys#setislot mx 4 f) )
     312
     313(define-inline (%mutex-locked? mx)
     314  (##sys#slot mx 5) )
     315
     316(define-inline (%mutex-locked-set! mx f)
     317  (##sys#setislot mx 5 f) )
     318
     319(define-inline (%mutex-specific mx)
     320  (##sys#slot mx 6) )
     321
     322(define-inline (%mutex-specific-set! mx x)
     323  (##sys#setslot mx 6 x) )
     324
     325(define-inline (%make-mutex id)
     326  (##sys#make-mutex id ##sys#current-thread) )
     327
     328(define-inline (%check-mutex x loc)
     329  (##sys#check-structure x 'mutex loc) )
     330
     331
     332;;; Condition-variable object:
     333
     334;; Condition-variable layout:
     335;
     336; 0     Tag - 'condition-variable
     337; 1     Name (object)
     338; 2     Waiting threads (FIFO list)
     339; 3     Specific (object)
     340
     341(define-inline (%condition-variable? x)
     342  (##sys#structure? x 'condition-variable) )
     343
     344(define-inline (%condition-variable-name cv)
     345  (##sys#slot cv 1) )
     346
     347(define-inline (%condition-variable-waiters cv)
     348  (##sys#slot cv 2) )
     349
     350(define-inline (%condition-variable-waiters-set! cv x)
     351  (##sys#setslot cv 2 x) )
     352
     353(define-inline (%condition-variable-waiters-add! cv th)
     354  (%condition-variable-waiters-set! cv (%append-item (%condition-variable-waiters cv) th)) )
     355
     356(define-inline (%condition-variable-waiters-delete! cv th)
     357  (%condition-variable-waiters-set! cv (##sys#delq th (%condition-variable-waiters cv))) )
     358
     359(define-inline (%condition-variable-waiters-empty? mx)
     360  (null? (%condition-variable-waiters mx)) )
     361
     362(define-inline (%condition-variable-waiters-pop! mx)
     363  (let* ([wt (%condition-variable-waiters mx)]
     364         [top (car wt)])
     365    (%condition-variable-waiters-set! mx (cdr wt))
     366    top ) )
     367
     368(define-inline (%condition-variable-waiters-clear! cv)
     369  (##sys#setislot cv 2 '()) )
     370
     371(define-inline (%condition-variable-specific cv)
     372  (##sys#slot cv 3) )
     373
     374(define-inline (%condition-variable-specific-set! cv x)
     375  (##sys#setslot cv 3 x) )
     376
     377(define-inline (%make-condition-variable nm #!optional (wt '()) (sp (void)))
     378  (##sys#make-structure 'condition-variable nm wt sp) )
     379
     380(define-inline (%check-condition-variable x loc)
     381    (##sys#check-structure x 'condition-variable loc) )
    86382
    87383
    88384;;; Time objects:
    89385
    90 (declare
    91   (foreign-declare #<<EOF
     386#>
    92387static C_TLS long C_ms;
    93388#define C_get_seconds   C_seconds(&C_ms)
    94 EOF
    95 ) )
    96 
     389<#
     390
     391(define-foreign-variable C_startup_time_seconds double)
    97392(define-foreign-variable C_get_seconds double)
    98 (define-foreign-variable C_startup_time_seconds double)
    99393(define-foreign-variable C_ms long)
     394
     395(define-inline (%seconds-since-startup s)
     396  (max 0 (- s C_startup_time_seconds)) )
     397
     398(define-inline (%seconds-after-startup s)
     399  (max 0 (+ s C_startup_time_seconds)) )
     400
     401(define-inline (%seconds->milliseconds s)
     402  (* s 1000) )
     403
     404(define-inline (%milliseconds->seconds ms)
     405  (/ ms 1000) )
     406
     407(define-inline (%milliseconds-since-startup s)
     408  (%seconds->milliseconds (%seconds-since-startup s)) )
     409
     410(define ##sys#timeout->limit
     411  (let ([truncate truncate])
     412    (lambda (tm loc)
     413      (and tm
     414           (cond [(%time? tm)
     415                  (%time-timeout tm) ]
     416                 [(number? tm)
     417                  (fx+ (##sys#fudge 16)
     418                       (inexact->exact (truncate (%seconds->milliseconds tm)))) ]
     419                 [else
     420                  (##sys#signal-hook
     421                   #:type-error loc "bad argument type - invalid timeout object" tm) ] ) ) ) ) )
    100422
    101423(define (current-time)
    102424  (let* ([s C_get_seconds]
    103          [ss C_startup_time_seconds]
    104          [ms C_ms] )
    105     (##sys#make-structure
    106      'time
    107      (inexact->exact (truncate (+ (* (- s ss) 1000) C_ms)))
    108      s
    109      C_ms) ) )
     425         [ms C_ms])
     426    (%make-time (+ (%milliseconds-since-startup s) ms) s ms) ) )
     427
     428(define (time->seconds tm)
     429  (%check-time tm 'time->seconds)
     430  (+ (%time-seconds tm) (%milliseconds->seconds (%time-milliseconds tm))) )
     431
     432(define (seconds->time s)
     433  (##sys#check-number s 'seconds->time)
     434  (let ([ms (%seconds->milliseconds s)]) ; milliseconds since startup
     435    (%make-time (+ (%milliseconds-since-startup s) ms) s ms) ) )
     436
     437(define (time->milliseconds tm)
     438  (%check-time tm 'time->milliseconds)
     439  (+ (%milliseconds-since-startup (%time-seconds tm)) (%time-milliseconds tm)) )
     440
     441(define (milliseconds->time nms)
     442  (##sys#check-integer nms 'milliseconds->time)
     443  (let ([s (%milliseconds->seconds nms)])
     444    (%make-time nms (%seconds-after-startup s) (%seconds->milliseconds s)) ) )
     445
     446(define (time? x) (%time? x))
     447
     448;; For SRFI-19 identifier conflict
    110449
    111450(define srfi-18:current-time current-time)
    112 
    113 (define (time->seconds tm)
    114   (##sys#check-structure tm 'time 'time->seconds)
    115   (+ (##sys#slot tm 2) (/ (##sys#slot tm 3) 1000)) )
    116 
    117 (define (time->milliseconds tm)
    118   (##sys#check-structure tm 'time 'time->milliseconds)
    119   (+ (inexact->exact (* (- (##sys#slot tm 2) C_startup_time_seconds) 1000))
    120      (##sys#slot tm 3) ) )
    121 
    122 (define (seconds->time n)
    123   (##sys#check-number n 'seconds->time)
    124   (let* ([n2 (max 0 (- n C_startup_time_seconds))] ; seconds since startup
    125          [ms (truncate (* 1000 (##sys#flonum-fraction (##sys#exact->inexact n))))] ; milliseconds
    126          [n3 (inexact->exact (truncate (+ (* n2 1000) ms)))] ) ; milliseconds since startup
    127     (##sys#make-structure 'time n3 (truncate n) (inexact->exact ms)) ) )
    128 
    129 (define (milliseconds->time nms)
    130   (##sys#check-exact nms 'milliseconds->time)
    131   (let ((s (+ C_startup_time_seconds (/ nms 1000))))
    132     (##sys#make-structure 'time nms s 0) ) )
    133 
    134 (define (time? x) (##sys#structure? x 'time))
    135 
    136451(define srfi-18:time? time?)
    137452
     
    139454;;; Exception handling:
    140455
    141 (define raise ##sys#signal)
    142 
    143 (define (join-timeout-exception? x)
    144   (and (##sys#structure? x 'condition)
    145        (memq 'join-timeout-exception (##sys#slot x 1)) ) )
    146 
    147 (define (abandoned-mutex-exception? x)
    148   (and (##sys#structure? x 'condition)
    149        (memq 'abandoned-mutex-exception (##sys#slot x 1)) ) )
    150 
    151 (define (terminated-thread-exception? x)
    152   (and (##sys#structure? x 'condition)
    153        (memq 'terminated-thread-exception (##sys#slot x 1)) ) )
    154 
    155 (define (uncaught-exception? x)
    156   (and (##sys#structure? x 'condition)
    157        (memq 'uncaught-exception (##sys#slot x 1)) ) )
    158 
    159 (define uncaught-exception-reason
    160   (condition-property-accessor 'uncaught-exception 'reason) )
     456(define raise signal)
     457
     458(define join-timeout-exception? (condition-predicate 'join-timeout-exception))
     459
     460(define abandoned-mutex-exception? (condition-predicate 'join-timeout-exception))
     461
     462(define terminated-thread-exception? (condition-predicate 'terminated-thread-exception))
     463
     464(define uncaught-exception? (condition-predicate 'uncaught-exception))
     465
     466(define uncaught-exception-reason (condition-property-accessor 'uncaught-exception 'reason))
    161467
    162468
    163469;;; Threads:
    164470
    165 (define make-thread
    166   (let ((gensym gensym))
    167     (lambda (thunk . name)
    168       (let ((thread
    169              (##sys#make-thread
    170               #f
    171               'created
    172               (if (pair? name) (##sys#slot name 0) (gensym 'thread))
    173               (##sys#slot ##sys#current-thread 9) ) ) )
    174         (##sys#setslot
    175          thread 1
    176          (lambda ()
    177            (##sys#call-with-values
    178             thunk
    179             (lambda results
    180               (##sys#setslot thread 2 results)
    181               (##sys#thread-kill! thread 'dead)
    182               (##sys#schedule) ) ) ) )
    183         thread) ) ) )
    184 
    185 (define (thread? x) (##sys#structure? x 'thread))
     471(define make-thread)
     472(let ([gensym gensym])
     473  (set! make-thread
     474    (lambda (thunk #!optional (name (gensym 'thread)))
     475      (##sys#check-closure thunk 'make-thread)
     476      (let ((thread (%make-thread name #f)))
     477        (%thread-thunk-set!
     478         thread
     479         (lambda ()
     480           (##sys#call-with-values
     481            thunk
     482            (lambda results
     483              (%thread-results-set! thread results)
     484              (##sys#thread-kill! thread 'dead)
     485              (##sys#schedule)))))
     486        thread))) )
     487
     488(define (thread? x) (%thread? x))
     489
    186490(define (current-thread) ##sys#current-thread)
    187491
    188492(define (thread-state thread)
    189   (##sys#check-structure thread 'thread 'thread-state)
    190   (##sys#slot thread 3) )
     493  (%check-thread thread 'thread-state)
     494  (%thread-state thread) )
    191495
    192496(define (thread-specific thread)
    193   (##sys#check-structure thread 'thread 'thread-specific)
    194   (##sys#slot thread 10) )
     497  (%check-thread thread 'thread-specific)
     498  (%thread-specific thread) )
    195499
    196500(define (thread-specific-set! thread x)
    197   (##sys#check-structure thread 'thread 'thread-specific-set!)
    198   (##sys#setslot thread 10 x) )
     501  (%check-thread thread 'thread-specific-set!)
     502  (%thread-specific-set! thread x) )
    199503
    200504(define (thread-quantum thread)
    201   (##sys#check-structure thread 'thread 'thread-quantum)
    202   (##sys#slot thread 9) )
     505  (%check-thread thread 'thread-quantum)
     506  (%thread-quantum thread) )
    203507
    204508(define (thread-quantum-set! thread q)
    205   (##sys#check-structure thread 'thread 'thread-quantum-set!)
     509  (%check-thread thread 'thread-quantum-set!)
    206510  (##sys#check-exact q 'thread-quantum-set!)
    207   (##sys#setislot thread 9 (fxmax q 10)) )
     511  (%thread-quantum-set! thread (fxmax q 10)) )
    208512
    209513(define (thread-name x)
    210   (##sys#check-structure x 'thread 'thread-name)
    211   (##sys#slot x 6) )
     514  (%check-thread x 'thread-name)
     515  (%thread-name x) )
    212516
    213517(define thread-start!
     
    216520      (if (procedure? thread)
    217521          (set! thread (make-thread thread))
    218           (##sys#check-structure thread 'thread 'thread-start!) )
    219       (unless (eq? 'created (##sys#slot thread 3))
    220         (##sys#error 'thread-start! "thread can not be started a second time" thread) )
    221       (##sys#setslot thread 3 'ready)
    222       (##sys#add-to-ready-queue thread) 
    223       thread) ) )
     522          (%check-thread thread 'thread-start!) )
     523      (unless (eq? 'created (%thread-state thread))
     524        (##sys#error 'thread-start! "thread already started" thread) )
     525      (%thread-state-set! thread 'ready)
     526      (##sys#add-to-ready-queue thread)
     527      thread ) ) )
    224528
    225529(define thread-yield! ##sys#thread-yield!) ;In library.scm
    226530
    227 (define thread-join!
    228   (lambda (thread . timeout)
    229     (##sys#check-structure thread 'thread 'thread-join!)
    230     (let* ((limit (and (pair? timeout) (##sys#compute-time-limit (##sys#slot timeout 0))))
    231            (rest (and (pair? timeout) (##sys#slot timeout 1)))
    232            (tosupplied (and rest (pair? rest)))
    233            (toval (and tosupplied (##sys#slot rest 0))) )
    234       (##sys#call-with-current-continuation
    235        (lambda (return)
    236          (let ([ct ##sys#current-thread])
    237            (when limit (##sys#thread-block-for-timeout! ct limit))
    238            (##sys#setslot
    239             ct 1
    240             (lambda ()
    241               (case (##sys#slot thread 3)
    242                 [(dead) (apply return (##sys#slot thread 2))]
    243                 [(terminated)
    244                  (return
    245                   (##sys#signal
    246                    (##sys#make-structure
    247                     'condition '(uncaught-exception)
    248                     (list '(uncaught-exception . reason) (##sys#slot thread 7)) ) ) ) ]
    249                 [else
    250                  (return
    251                   (if tosupplied
    252                       toval
    253                       (##sys#signal
    254                        (##sys#make-structure 'condition '(join-timeout-exception) '())) ) ) ] ) ) )
    255            (##sys#thread-block-for-termination! ct thread)
    256            (##sys#schedule) ) ) ) ) ) )
    257            
    258 (define (thread-terminate! thread)
    259   (##sys#check-structure thread 'thread 'thread-terminate!)
    260   (when (eq? thread ##sys#primordial-thread)
    261     ((##sys#exit-handler)) )
    262   (##sys#setslot thread 2 (list (##core#undefined)))
    263   (##sys#setslot thread 7 (##sys#make-structure 'condition '(terminated-thread-exception) '()))
    264   (##sys#thread-kill! thread 'terminated)
    265   (when (eq? thread ##sys#current-thread) (##sys#schedule)) )
    266 
    267 (define (thread-suspend! thread)
    268   (##sys#check-structure thread 'thread 'thread-suspend!)
    269   (##sys#setslot thread 3 'suspended)
    270   (when (eq? thread ##sys#current-thread)
     531(define (thread-join! thread #!optional timeout timeout-val)
     532  (%check-thread thread 'thread-join!)
     533  (let ([limit (and timeout (##sys#timeout->limit timeout 'thread-join!))])
    271534    (##sys#call-with-current-continuation
    272535     (lambda (return)
    273        (##sys#setslot thread 1 (lambda () (return (##core#undefined))))
    274        (##sys#schedule) ) ) ) )
    275 
    276 (define (thread-resume! thread)
    277   (##sys#check-structure thread 'thread 'thread-resume!)
    278   (when (eq? (##sys#slot thread 3) 'suspended)
    279     (##sys#setslot thread 3 'ready)
    280     (##sys#add-to-ready-queue thread) ) )
    281 
    282 (define (thread-sleep! tm)
    283   (define (sleep limit loc)
     536       (let ([ct ##sys#current-thread])
     537         (when limit (##sys#thread-block-for-timeout! ct limit))
     538         (%thread-thunk-set! ct
     539          (lambda ()
     540            (case (%thread-state thread)
     541              [(dead)
     542               (apply return (%thread-results thread))]
     543              [(terminated)
     544               (return
     545                (signal
     546                 (make-property-condition 'uncaught-exception 'reason (%thread-reason thread)))) ]
     547              [else
     548               (return
     549                (or timeout-val
     550                    (signal (make-property-condition 'join-timeout-exception)))) ] ) ) )
     551         (##sys#thread-block-for-termination! ct thread)
     552         (##sys#schedule) ) ) ) ) )
     553
     554(define (thread-terminate! thread)
     555  (%check-thread thread 'thread-terminate!)
     556  (when (eq? ##sys#primordial-thread thread) ((##sys#exit-handler)) )
     557  (%thread-results-set! thread (list (void)))
     558  (%thread-reason-set! thread (make-property-condition 'terminated-thread-exception))
     559  (##sys#thread-kill! thread 'terminated)
     560  (when (eq? ##sys#current-thread thread) (##sys#schedule)) )
     561
     562(define (thread-suspend! thread)
     563  (%check-thread thread 'thread-suspend!)
     564  (%thread-state-set! thread 'suspended)
     565  (when (eq? ##sys#current-thread thread)
    284566    (##sys#call-with-current-continuation
    285567     (lambda (return)
    286        (let ((ct ##sys#current-thread))
    287          (##sys#setslot ct 1 (lambda () (return (##core#undefined))))
    288          (##sys#thread-block-for-timeout! ct limit)
    289          (##sys#schedule) ) ) ) )
    290   (unless tm (##sys#signal-hook #:type-error 'thread-sleep! "invalid timeout argument" tm))
    291   (sleep (##sys#compute-time-limit tm) 'thread-sleep!) )
     568       (%thread-thunk-set! thread (lambda () (return (void))))
     569       (##sys#schedule) ) ) ) )
     570
     571(define (thread-resume! thread)
     572  (%check-thread thread 'thread-resume!)
     573  (when (eq? 'suspended (%thread-state thread))
     574    (%thread-state-set! thread 'ready)
     575    (##sys#add-to-ready-queue thread) ) )
     576
     577(define (##sys#sleep-current-thread limit)
     578  (##sys#call-with-current-continuation
     579   (lambda (return)
     580     (let ([ct ##sys#current-thread])
     581       (%thread-thunk-set! ct (lambda () (return (void))))
     582       (##sys#thread-block-for-timeout! ct limit)
     583       (##sys#schedule) ) ) ) )
     584
     585(define (thread-sleep! timeout)
     586  (##sys#sleep-current-thread (##sys#timeout->limit timeout 'thread-sleep!)) )
     587
     588
     589;;; Change continuation of thread to signal an exception:
     590
     591(define (thread-signal! thread exn)
     592  (%check-thread thread 'thread-signal!)
     593  (if (eq? ##sys#current-thread thread)
     594      (signal exn)
     595      (let ([old (%thread-thunk thread)])
     596        (%thread-thunk-set! thread (lambda () (signal exn) (old)))
     597        (##sys#thread-unblock! thread) ) ) )
     598
     599
     600;;; Waiting for I/O on file-descriptor
     601
     602(define (thread-wait-for-i/o! fd #!optional (mode #:all))
     603  (##sys#check-exact fd 'thread-wait-for-i/o!)
     604  (##sys#thread-block-for-i/o! ##sys#current-thread fd mode)
     605  (thread-yield!) )
    292606
    293607
    294608;;; Mutexes:
    295609
    296 (define (mutex? x) (##sys#structure? x 'mutex))
    297 
    298 (define make-mutex
    299   (let ((gensym gensym))
    300     (lambda id
    301       (let* ((id (if (pair? id) (car id) (gensym 'mutex)))
    302              (m (##sys#make-mutex id ##sys#current-thread)) )
    303         m) ) ) )
    304 
    305 (define (mutex-name x)
    306   (##sys#check-structure x 'mutex 'mutex-name)
    307   (##sys#slot x 1) )
     610(define make-mutex)
     611(let ([gensym gensym])
     612  (set! make-mutex
     613    (lambda (#!optional (id (gensym 'mutex)))
     614      (%make-mutex id) ) ) )
     615
     616(define (mutex? x) (%mutex? x))
     617
     618(define (mutex-name mutex)
     619  (%check-mutex mutex 'mutex-specific)
     620  (%mutex-name mutex) )
    308621
    309622(define (mutex-specific mutex)
    310   (##sys#check-structure mutex 'mutex 'mutex-specific)
    311   (##sys#slot mutex 6) )
     623  (%check-mutex mutex 'mutex-specific)
     624  (%mutex-specific mutex) )
    312625
    313626(define (mutex-specific-set! mutex x)
    314   (##sys#check-structure mutex 'mutex 'mutex-specific-set!)
    315   (##sys#setslot mutex 6 x) )
     627  (%check-mutex mutex 'mutex-specific-set!)
     628  (%mutex-specific-set! mutex x) )
    316629
    317630(define (mutex-state mutex)
    318   (##sys#check-structure mutex 'mutex 'mutex-state)
    319   (cond [(##sys#slot mutex 5) (or (##sys#slot mutex 2) 'not-owned)]
    320         [(##sys#slot mutex 4) 'abandoned]
    321         [else 'not-abandoned] ) )
    322 
    323 (define mutex-lock!
    324   (lambda (mutex . ms-and-t)
    325     (##sys#check-structure mutex 'mutex 'mutex-lock!)
    326     (let* ([limitsup (pair? ms-and-t)]
    327            [limit (and limitsup (##sys#compute-time-limit (car ms-and-t)))]
    328            [threadsup (fx> (length ms-and-t) 1)]
    329            [thread (and threadsup (cadr ms-and-t))]
    330            [abd (##sys#slot mutex 4)] )
    331       (when thread (##sys#check-structure thread 'thread 'mutex-lock!))
    332       (##sys#call-with-current-continuation
    333        (lambda (return)
    334          (let ([ct ##sys#current-thread])
    335            (define (switch)
    336              (##sys#setslot mutex 3 (##sys#append (##sys#slot mutex 3) (list ct)))
    337              (##sys#schedule) )
    338            (define (check)
    339              (when abd
    340                (return (##sys#signal (##sys#make-structure 'condition '(abandoned-mutex-exception) '()))) ) )
    341            (dbg ct ": locking " mutex)
    342            (cond [(not (##sys#slot mutex 5))
    343                   (if (and threadsup (not thread))
    344                       (begin
    345                         (##sys#setislot mutex 2 #f)
    346                         (##sys#setislot mutex 5 #t) )
    347                       (let* ([t (or thread ct)]
    348                              [ts (##sys#slot t 3)] )
    349                         (if (or (eq? 'terminated ts) (eq? 'dead ts))
    350                             (##sys#setislot mutex 4 #t)
    351                             (begin
    352                               (##sys#setislot mutex 5 #t)
    353                               (##sys#setslot t 8 (cons mutex (##sys#slot t 8)))
    354                               (##sys#setslot mutex 2 t) ) ) ) )
    355                   (check)
    356                   (return #t) ]
    357                  [limit
    358                   (check)
    359                   (##sys#setslot
    360                    ct 1
    361                    (lambda ()
    362                      (##sys#setslot mutex 3 (##sys#delq ct (##sys#slot mutex 3)))
    363                      (##sys#setslot ##sys#current-thread 8 (cons mutex (##sys#slot ##sys#current-thread 8)))
    364                      (##sys#setslot mutex 2 thread)
    365                      #f) )
    366                   (##sys#thread-block-for-timeout! ct limit)
    367                   (switch) ]
    368                  [else
    369                   (##sys#setslot ct 3 'sleeping)
    370                   (##sys#setslot ct 1 (lambda () (return #t)))
    371                   (switch) ] ) ) ) ) ) ) )
    372 
    373 (define mutex-unlock!
    374   (lambda (mutex . cvar-and-to)
    375     (##sys#check-structure mutex 'mutex 'mutex-unlock!)
    376     (let ([ct ##sys#current-thread]
    377           [cvar (and (pair? cvar-and-to) (car cvar-and-to))]
    378           [timeout (and (fx> (length cvar-and-to) 1) (cadr cvar-and-to))] )
    379       (dbg ct ": unlocking " mutex)
    380       (when cvar (##sys#check-structure cvar 'condition-variable 'mutex-unlock!))
    381       (##sys#call-with-current-continuation
    382        (lambda (return)
    383          (let ([waiting (##sys#slot mutex 3)]
    384                [limit (and timeout (##sys#compute-time-limit timeout))]
    385                [result #t] )
    386            (##sys#setislot mutex 4 #f)
    387            (##sys#setislot mutex 5 #f)
    388            (##sys#setslot ct 8 (##sys#delq mutex (##sys#slot ct 8)))
    389            (##sys#setslot ct 1 (lambda () (return result)))
    390            (when cvar
    391              (##sys#setslot cvar 2 (##sys#append (##sys#slot cvar 2) (##sys#list ct)))
    392              (cond [limit
    393                     (##sys#setslot
    394                      ct 1
    395                      (lambda ()
    396                        (##sys#setslot cvar 2 (##sys#delq ct (##sys#slot cvar 2)))
    397                        (return #f) ) )
    398                     (##sys#thread-block-for-timeout! ct limit) ]
    399                    [else
    400                     (##sys#setslot ct 3 'sleeping)] ) )
    401            (unless (null? waiting)
    402              (let* ([wt (##sys#slot waiting 0)]
    403                     [wts (##sys#slot wt 3)] )
    404                (##sys#setslot mutex 3 (##sys#slot waiting 1))
    405                (##sys#setislot mutex 5 #t)
    406                (when (or (eq? wts 'blocked) (eq? wts 'sleeping))
    407                  (##sys#setslot mutex 2 wt)
    408                  (##sys#setslot wt 8 (cons mutex (##sys#slot wt 8)))
    409                  (when (eq? wts 'sleeping) (##sys#add-to-ready-queue wt) ) ) ) )
    410            (##sys#schedule) ) ) ) ) ) )
     631  (%check-mutex mutex 'mutex-state)
     632  (cond [(%mutex-locked? mutex)    (or (%mutex-thread mutex) 'not-owned)]
     633        [(%mutex-abandoned? mutex) 'abandoned]
     634        [else                      'not-abandoned] ) )
     635
     636(define (mutex-lock! mutex #!optional timeout (thread (void)))
     637  (%check-mutex mutex 'mutex-lock!)
     638  (let* ([limit (and timeout (##sys#timeout->limit timeout 'mutex-lock!))]
     639         [threadsup (not (eq? (void) thread))]
     640         [thread (and threadsup thread)]
     641         [abd (%mutex-abandoned? mutex)] )
     642    (when thread (%check-thread thread 'mutex-lock!))
     643    (##sys#call-with-current-continuation
     644     (lambda (return)
     645       (let ([ct ##sys#current-thread])
     646         (define (switch)
     647           (%mutex-waiters-add! mutex ct)
     648           (##sys#schedule) )
     649         (define (check)
     650           (when abd
     651             (return (signal (make-property-condition 'abandoned-mutex-exception))) ) )
     652         (dbg ct ": locking " mutex)
     653         (cond [(not (%mutex-locked? mutex))
     654                (if (and threadsup (not thread))
     655                    (begin
     656                      (%mutex-thread-clear! mutex)
     657                      (%mutex-locked-set! mutex #t) )
     658                    (let* ([th (or thread ct)]
     659                           [ts (%thread-state th)] )
     660                      (if (or (eq?'terminated ts) (eq? 'dead ts))
     661                          (%mutex-abandoned-set! mutex #t)
     662                          (begin
     663                            (%mutex-locked-set! mutex #t)
     664                            (%thread-mutexes-add! th mutex)
     665                            (%mutex-thread-set! mutex th) ) ) ) )
     666                (check)
     667                (return #t) ]
     668               [limit
     669                (check)
     670                (%thread-thunk-set! ct
     671                 (lambda ()
     672                   (%mutex-waiters-delete! mutex ct)
     673                   (%thread-mutexes-add! ##sys#current-thread mutex)
     674                   (%mutex-thread-set! mutex thread)
     675                   #f))
     676                (##sys#thread-block-for-timeout! ct limit)
     677                (switch) ]
     678               [else
     679                (%thread-state-set! ct 'sleeping)
     680                (%thread-thunk-set! ct (lambda () (return #t)))
     681                (switch) ] ) ) ) ) ) )
     682
     683(define (mutex-unlock! mutex #!optional cv timeout)
     684  (%check-mutex mutex 'mutex-unlock!)
     685  (let ([ct ##sys#current-thread])
     686    (dbg ct ": unlocking " mutex)
     687    (##sys#call-with-current-continuation
     688     (lambda (return)
     689       (let ([limit (and timeout (##sys#timeout->limit timeout 'mutex-unlock!))]
     690             [result #t] )
     691         (%mutex-abandoned-set! mutex #f)
     692         (%mutex-locked-set! mutex #f)
     693         (%thread-mutexes-delete! ct mutex)
     694         (%thread-thunk-set! ct (lambda () (return result)))
     695         (when cv
     696           (%check-condition-variable cv 'mutex-unlock!)
     697           (%condition-variable-waiters-add! cv ct)
     698           (cond [limit
     699                  (%thread-thunk-set! ct
     700                   (lambda ()
     701                     (%condition-variable-waiters-delete! cv ct)
     702                     (return #f)))
     703                  (##sys#thread-block-for-timeout! ct limit) ]
     704                 [else
     705                  (%thread-state-set! ct 'sleeping) ] ) )
     706         (unless (%mutex-waiters-empty? mutex)
     707           (let* ([wt (%mutex-waiters-pop! mutex)]
     708                  [wts (%thread-state wt)] )
     709             (%mutex-locked-set! mutex #t)
     710             (when (or (eq? 'blocked wts) (eq? 'sleeping wts))
     711               (%mutex-thread-set! mutex wt)
     712               (%thread-mutexes-add! wt mutex)
     713               (when (eq? 'sleeping wts) (##sys#add-to-ready-queue wt) ) ) ) )
     714         (##sys#schedule) ) ) ) ) )
    411715
    412716
    413717;;; Condition variables:
    414718
    415 (define make-condition-variable
    416   (let ([gensym gensym])
    417     (lambda name
    418       (##sys#make-structure
    419        'condition-variable
    420        (if (pair? name)                 ; #1 name
    421            (car name)
    422            (gensym 'condition-variable) )
    423        '()                              ; #2 list of waiting threads
    424        (##core#undefined) ) ) ) )       ; #3 specific
    425 
    426 (define (condition-variable? x)
    427   (##sys#structure? x 'condition-variable) )
     719(define make-condition-variable)
     720(let ([gensym gensym])
     721  (set! make-condition-variable
     722    (lambda (#!optional (name (gensym 'condition-variable)))
     723      (%make-condition-variable name))) )
     724
     725(define (condition-variable? x) (%condition-variable? x) )
     726
     727(define (condition-variable-name cv)
     728  (%check-condition-variable cv 'condition-variable-name)
     729  (%condition-variable-name cv) )
    428730
    429731(define (condition-variable-specific cv)
    430   (##sys#check-structure cv 'condition-variable 'condition-variable-specific)
    431   (##sys#slot cv 3) )
     732  (%check-condition-variable cv 'condition-variable-specific)
     733  (%condition-variable-specific cv) )
    432734
    433735(define (condition-variable-specific-set! cv x)
    434   (##sys#check-structure cv 'condition-variable 'condition-variable-specific-set!)
    435   (##sys#setslot cv 3 x) )
    436 
    437 (define (condition-variable-signal! cvar)
    438   (##sys#check-structure cvar 'condition-variable 'condition-variable-signal!)
    439   (dbg "signalling " cvar)
    440   (let ([ts (##sys#slot cvar 2)])
    441     (unless (null? ts)
    442       (let* ([t0 (##sys#slot ts 0)]
    443              [t0s (##sys#slot t0 3)] )
    444         (##sys#setslot cvar 2 (##sys#slot ts 1))
    445         (when (or (eq? t0s 'blocked) (eq? t0s 'sleeping))
    446           (##sys#thread-basic-unblock! t0) ) ) ) ) )
    447 
    448 (define (condition-variable-broadcast! cvar)
    449   (##sys#check-structure cvar 'condition-variable 'condition-variable-broadcast!)
    450   (dbg "broadcasting " cvar)
     736  (%check-condition-variable cv 'condition-variable-specific-set!)
     737  (%condition-variable-specific-set! cv x) )
     738
     739(define (condition-variable-signal! cv)
     740  (%check-condition-variable cv 'condition-variable-signal!)
     741  (dbg "signalling " cv)
     742  (unless (%condition-variable-waiters-empty? cv)
     743    (let* ([t0 (%condition-variable-waiters-pop! cv)]
     744           [t0s (%thread-state t0)] )
     745      (when (or (eq? 'blocked t0s) (eq? 'sleeping t0s))
     746        (##sys#thread-basic-unblock! t0) ) ) ) )
     747
     748(define (condition-variable-broadcast! cv)
     749  (%check-condition-variable cv 'condition-variable-broadcast!)
     750  (dbg "broadcasting " cv)
    451751  (##sys#for-each
    452752   (lambda (ti)
    453      (let ([tis (##sys#slot ti 3)])
    454        (when (or (eq? tis 'blocked) (eq? tis 'sleeping))
     753     (let ([tis (%thread-state ti)])
     754       (when (or (eq? 'blocked tis) (eq? 'sleeping tis))
    455755         (##sys#thread-basic-unblock! ti) ) ) )
    456    (##sys#slot cvar 2) )
    457   (##sys#setislot cvar 2 '()) )
    458 
    459 
    460 ;;; Change continuation of thread to signal an exception:
    461 
    462 (define (thread-signal! thread exn)
    463   (##sys#check-structure thread 'thread 'thread-signal!)
    464   (if (eq? thread ##sys#current-thread)
    465       (##sys#signal exn)
    466       (let ([old (##sys#slot thread 1)])
    467         (##sys#setslot
    468          thread 1
    469          (lambda ()
    470            (##sys#signal exn)
    471            (old) ) )
    472         (##sys#thread-unblock! thread) ) ) )
     756   (%condition-variable-waiters cv) )
     757  (%condition-variable-waiters-clear! cv) )
    473758
    474759
    475760;;; Don't block in the repl: (by Chris Double)
    476761
    477 (unless (eq? (build-platform) 'msvc)
     762(unless (eq? 'msvc (build-platform))
    478763  (set! ##sys#read-prompt-hook
    479764    (let ([old ##sys#read-prompt-hook]
     
    484769          (##sys#thread-block-for-i/o! ##sys#current-thread 0 #t)
    485770          (thread-yield!)))) ) )
    486 
    487 
    488 ;;; Waiting for I/O on file-descriptor
    489 
    490 (define (thread-wait-for-i/o! fd #!optional (mode #:all))
    491   (##sys#check-exact fd 'thread-wait-for-i/o!)
    492   (##sys#thread-block-for-i/o! ##sys#current-thread fd mode)
    493   (thread-yield!) )
  • chicken/branches/chicken-3/version.scm

    r13411 r13413  
    1 (define-constant +build-version+ "3.5.1")
     1(define-constant +build-version+ "3.5.2")
Note: See TracChangeset for help on using the changeset viewer.