Changeset 13411 in project


Ignore:
Timestamp:
02/26/09 02:38:58 (11 years ago)
Author:
Ivan Raikov
Message:

Reverted srfi-18.scm to that of Chicken 3.4.0

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

Legend:

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

    r13259 r13411  
     13.5.1
     2
     3- Reverted srfi-18 to that Chicken 3.4.0
     4
    153.5.0
    26
  • chicken/branches/chicken-3/README

    r13259 r13411  
    33  (c)2000-2008 Felix L. Winkelmann
    44
    5   version 3.5.0
     5  version 3.5.1
    66
    77
  • chicken/branches/chicken-3/buildversion

    r13259 r13411  
    1 3.5.0
     13.5.1
  • chicken/branches/chicken-3/manual/The User's Manual

    r13259 r13411  
    33== The User's Manual
    44
    5 This is the user's manual for the Chicken Scheme compiler, version 3.5.0
     5This is the user's manual for the Chicken Scheme compiler, version 3.5.1
    66
    77; [[Getting started]] : What is CHICKEN and how do I use it?
  • chicken/branches/chicken-3/srfi-18.scm

    r13178 r13411  
    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#timeout->limit ##sys#sleep-current-thread) )
     34 (hide ##sys#compute-time-limit) )
    3535
    3636(cond-expand
     
    4141    (no-procedure-checks-for-usual-bindings)
    4242    (bound-to-procedure
    43      condition? condition-predicate signal
    4443     ##sys#thread-yield!
    4544     condition-property-accessor ##sys#tty-port? ##sys#thread-block-for-i/o thread-yield! ##sys#thread-unblock!
     
    4948     ##sys#schedule ##sys#make-thread
    5049     ##sys#check-number ##sys#error ##sys#signal-hook ##sys#signal
    51      ##sys#current-exception-handler ##sys#check-structure ##sys#structure? ##sys#make-mutex
    52      ##sys#delq ##sys#timeout->limit ##sys#fudge) ) ] )
     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) ) ] )
    5352
    5453(cond-expand
     
    6463    (define-macro (##sys#check-exact . _) '(##core#undefined))
    6564    (define-macro (##sys#check-port . _) '(##core#undefined))
    66     (define-macro (##sys#check-number . _) '(##core#undefined)) ) ]
     65    (define-macro (##sys#check-number . _) '(##core#undefined))
     66    (define-macro (##sys#check-byte-vector . _) '(##core#undefined)) ) ]
    6767 [else
    6868  (declare (emit-exports "srfi-18.exports"))] )
     
    7575
    7676
    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 wx) )
    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) )
     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)] ) ) ) ) )
    38286
    38387
    38488;;; Time objects:
    38589
    386 #>
     90(declare
     91  (foreign-declare #<<EOF
    38792static C_TLS long C_ms;
    38893#define C_get_seconds   C_seconds(&C_ms)
    389 <#
    390 
     94EOF
     95) )
     96
     97(define-foreign-variable C_get_seconds double)
    39198(define-foreign-variable C_startup_time_seconds double)
    392 (define-foreign-variable C_get_seconds double)
    39399(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   (* (##sys#flonum-fraction (##sys#exact->inexact 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) ] ) ) ) ) )
    422100
    423101(define (current-time)
    424102  (let* ([s C_get_seconds]
    425          [ms C_ms])
    426     (%make-time (+ (%milliseconds-since-startup s) ms) s ms) ) )
     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) ) )
     110
     111(define srfi-18:current-time current-time)
    427112
    428113(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) ) )
     114  (##sys#check-structure tm 'time 'time->seconds)
     115  (+ (##sys#slot tm 2) (/ (##sys#slot tm 3) 1000)) )
    436116
    437117(define (time->milliseconds tm)
    438   (%check-time tm 'time->milliseconds)
    439   (+ (%milliseconds-since-startup (%time-seconds tm)) (%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)) ) )
    440128
    441129(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
    449 
    450 (define srfi-18:current-time current-time)
     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
    451136(define srfi-18:time? time?)
    452137
     
    454139;;; Exception handling:
    455140
    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))
     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) )
    467161
    468162
    469163;;; Threads:
    470164
    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       (%make-thread
    477        name
    478        (lambda ()
    479          (##sys#call-with-values
    480           thunk
    481           (lambda results
    482             (%thread-results-set! thread results)
    483             (##sys#thread-kill! thread 'dead)
    484             (##sys#schedule))))))) )
    485 
    486 (define (thread? x) (%thread x))
    487 
     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))
    488186(define (current-thread) ##sys#current-thread)
    489187
    490188(define (thread-state thread)
    491   (%check-thread thread 'thread-state)
    492   (%thread-state thread) )
     189  (##sys#check-structure thread 'thread 'thread-state)
     190  (##sys#slot thread 3) )
    493191
    494192(define (thread-specific thread)
    495   (%check-thread thread 'thread-specific)
    496   (%thread-specific thread) )
     193  (##sys#check-structure thread 'thread 'thread-specific)
     194  (##sys#slot thread 10) )
    497195
    498196(define (thread-specific-set! thread x)
    499   (%check-thread thread 'thread-specific-set!)
    500   (%thread-specific-set! thread x) )
     197  (##sys#check-structure thread 'thread 'thread-specific-set!)
     198  (##sys#setslot thread 10 x) )
    501199
    502200(define (thread-quantum thread)
    503   (%check-thread thread 'thread-quantum)
    504   (%thread-quantum thread) )
     201  (##sys#check-structure thread 'thread 'thread-quantum)
     202  (##sys#slot thread 9) )
    505203
    506204(define (thread-quantum-set! thread q)
    507   (%check-thread thread 'thread-quantum-set!)
     205  (##sys#check-structure thread 'thread 'thread-quantum-set!)
    508206  (##sys#check-exact q 'thread-quantum-set!)
    509   (%thread-quantum-set! thread (fxmax q 10)) )
     207  (##sys#setislot thread 9 (fxmax q 10)) )
    510208
    511209(define (thread-name x)
    512   (%check-thread x 'thread-name)
    513   (%thread-name x) )
     210  (##sys#check-structure x 'thread 'thread-name)
     211  (##sys#slot x 6) )
    514212
    515213(define thread-start!
     
    518216      (if (procedure? thread)
    519217          (set! thread (make-thread thread))
    520           (%check-thread thread 'thread-start!) )
    521       (unless (eq? 'created (%thread-state thread))
    522         (##sys#error 'thread-start! "thread already started" thread) )
    523       (%thread-state-set! thread 'ready)
    524       (##sys#add-to-ready-queue thread)
    525       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) ) )
    526224
    527225(define thread-yield! ##sys#thread-yield!) ;In library.scm
    528226
    529 (define (thread-join! thread #!optional timeout timeout-val)
    530   (%check-thread thread 'thread-join!)
    531   (let ([limit (and timeout (##sys#timeout->limit timeout 'thread-join!))])
     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)
    532271    (##sys#call-with-current-continuation
    533272     (lambda (return)
    534        (let ([ct ##sys#current-thread])
    535          (when limit (##sys#thread-block-for-timeout! ct limit))
    536          (%thread-thunk-set! ct
    537           (lambda ()
    538             (case (%thread-state thread)
    539               [(dead)
    540                (apply return (%thread-results thread))]
    541               [(terminated)
    542                (return
    543                 (signal
    544                  (make-property-condition 'uncaught-exception 'reason (%thread-reason thread)))) ]
    545               [else
    546                (return
    547                 (or timeout-val
    548                     (signal (make-property-condition 'join-timeout-exception)))) ] ) ) )
    549          (##sys#thread-block-for-termination! ct thread)
    550          (##sys#schedule) ) ) ) ) )
    551 
    552 (define (thread-terminate! thread)
    553   (%check-thread thread 'thread-terminate!)
    554   (when (eq? ##sys#primordial-thread thread) ((##sys#exit-handler)) )
    555   (%thread-results-set! thread (list (void)))
    556   (%thread-reason-set! thread (make-property-condition 'terminated-thread-exception))
    557   (##sys#thread-kill! thread 'terminated)
    558   (when (eq? ##sys#current-thread thread) (##sys#schedule)) )
    559 
    560 (define (thread-suspend! thread)
    561   (%check-thread thread 'thread-suspend!)
    562   (%thread-state-set! thread 'suspended)
    563   (when (eq? ##sys#current-thread thread)
     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)
    564284    (##sys#call-with-current-continuation
    565285     (lambda (return)
    566        (%thread-thunk-set! thread (lambda () (return (void))))
    567        (##sys#schedule) ) ) ) )
    568 
    569 (define (thread-resume! thread)
    570   (%check-thread thread 'thread-resume!)
    571   (when (eq? 'suspended (%thread-state thread))
    572     (%thread-state-set! thread 'ready)
    573     (##sys#add-to-ready-queue thread) ) )
    574 
    575 (define (##sys#sleep-current-thread limit)
    576   (##sys#call-with-current-continuation
    577    (lambda (return)
    578      (let ([ct ##sys#current-thread])
    579        (%thread-thunk-set! ct (lambda () (return (void))))
    580        (##sys#thread-block-for-timeout! ct limit)
    581        (##sys#schedule) ) ) ) )
    582 
    583 (define (thread-sleep! timeout)
    584   (##sys#sleep-current-thread (##sys#timeout->limit timeout 'thread-sleep!)) )
    585 
    586 
    587 ;;; Change continuation of thread to signal an exception:
    588 
    589 (define (thread-signal! thread exn)
    590   (%check-thread thread 'thread-signal!)
    591   (if (eq? ##sys#current-thread thread)
    592       (signal exn)
    593       (let ([old (%thread-thunk thread)])
    594         (%thread-thunk-set! thread (lambda () (signal exn) (old)))
    595         (##sys#thread-unblock! thread) ) ) )
    596 
    597 
    598 ;;; Waiting for I/O on file-descriptor
    599 
    600 (define (thread-wait-for-i/o! fd #!optional (mode #:all))
    601   (##sys#check-exact fd 'thread-wait-for-i/o!)
    602   (##sys#thread-block-for-i/o! ##sys#current-thread fd mode)
    603   (thread-yield!) )
     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!) )
    604292
    605293
    606294;;; Mutexes:
    607295
    608 (define make-mutex)
    609 (let ([gensym gensym])
    610   (set! make-mutex
    611     (lambda (#!optional (id (gensym 'mutex)))
    612       (%make-mutex id) ) ) )
    613 
    614 (define (mutex? x) (%mutex x))
    615 
    616 (define (mutex-name mutex)
    617   (%check-mutex mutex 'mutex-specific)
    618   (%mutex-name mutex) )
     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) )
    619308
    620309(define (mutex-specific mutex)
    621   (%check-mutex mutex 'mutex-specific)
    622   (%mutex-specific mutex) )
     310  (##sys#check-structure mutex 'mutex 'mutex-specific)
     311  (##sys#slot mutex 6) )
    623312
    624313(define (mutex-specific-set! mutex x)
    625   (%check-mutex mutex 'mutex-specific-set!)
    626   (%mutex-specific-set! mutex x) )
     314  (##sys#check-structure mutex 'mutex 'mutex-specific-set!)
     315  (##sys#setslot mutex 6 x) )
    627316
    628317(define (mutex-state mutex)
    629   (%check-mutex mutex 'mutex-state)
    630   (cond [(%mutex-locked? mutex)    (or (%mutex-thread mutex) 'not-owned)]
    631         [(%mutex-abandoned? mutex) 'abandoned]
    632         [else                      'not-abandoned] ) )
    633 
    634 (define (mutex-lock! mutex #!optional timeout (thread (void)))
    635   (%check-mutex mutex 'mutex-lock!)
    636   (let* ([limit (and timeout (##sys#timeout->limit timeout 'mutex-lock!))]
    637          [threadsup (not (eq? (void) thread))]
    638          [thread (and threadsup thread)]
    639          [abd (%mutex-abandoned? mutex)] )
    640     (when thread (%check-thread thread 'mutex-lock!))
    641     (##sys#call-with-current-continuation
    642      (lambda (return)
    643        (let ([ct ##sys#current-thread])
    644          (define (switch)
    645            (%mutex-waiters-add! mutex ct)
    646            (##sys#schedule) )
    647          (define (check)
    648            (when abd
    649              (return (signal (make-property-condition 'abandoned-mutex-exception))) ) )
    650          (dbg ct ": locking " mutex)
    651          (cond [(not (%mutex-locked? mutex))
    652                 (if (and threadsup (not thread))
    653                     (begin
    654                       (%mutex-thread-clear! mutex)
    655                       (%mutex-locked-set! mutex #t) )
    656                     (let* ([th (or thread ct)]
    657                            [ts (%thread-state th)] )
    658                       (if (or (eq?'terminated ts) (eq? 'dead ts))
    659                           (%mutex-abandoned-set! mutex #t)
    660                           (begin
    661                             (%mutex-locked-set! mutex #t)
    662                             (%thread-mutexes-add! th mutex)
    663                             (%mutex-thread-set! mutex th) ) ) ) )
    664                 (check)
    665                 (return #t) ]
    666                [limit
    667                 (check)
    668                 (%thread-thunk-set! ct
    669                  (lambda ()
    670                    (%mutex-waiters-delete! mutex ct)
    671                    (%thread-mutexes-add! ##sys#current-thread mutex)
    672                    (%mutex-thread-set! mutex thread)
    673                    #f))
    674                 (##sys#thread-block-for-timeout! ct limit)
    675                 (switch) ]
    676                [else
    677                 (%thread-state-set! ct 'sleeping)
    678                 (%thread-thunk-set! ct (lambda () (return #t)))
    679                 (switch) ] ) ) ) ) ) )
    680 
    681 (define (mutex-unlock! mutex #!optional cv timeout)
    682   (%check-mutex mutex 'mutex-unlock!)
    683   (let ([ct ##sys#current-thread])
    684     (dbg ct ": unlocking " mutex)
    685     (##sys#call-with-current-continuation
    686      (lambda (return)
    687        (let ([limit (and timeout (##sys#timeout->limit timeout 'mutex-unlock!))]
    688              [result #t] )
    689          (%mutex-abandoned-set! mutex #f)
    690          (%mutex-locked-set! mutex #f)
    691          (%thread-mutexes-delete! ct mutex)
    692          (%thread-thunk-set! ct (lambda () (return result)))
    693          (when cv
    694            (%check-condition-variable cv 'mutex-unlock!)
    695            (%condition-variable-waiters-add! cv ct)
    696            (cond [limit
    697                   (%thread-thunk-set! ct
    698                    (lambda ()
    699                      (%condition-variable-waiters-delete! cv ct)
    700                      (return #f)))
    701                   (##sys#thread-block-for-timeout! ct limit) ]
    702                  [else
    703                   (%thread-state-set! ct 'sleeping) ] ) )
    704          (unless (%mutex-waiters-empty? mutex)
    705            (let* ([wt (%mutex-waiters-pop! mutex)]
    706                   [wts (%thread-state wt)] )
    707              (%mutex-locked-set! mutex #t)
    708              (when (or (eq? 'blocked wts) (eq? 'sleeping wts))
    709                (%mutex-thread-set! mutex wt)
    710                (%thread-mutexes-add! wt mutex)
    711                (when (eq? 'sleeping wts) (##sys#add-to-ready-queue wt) ) ) ) )
    712          (##sys#schedule) ) ) ) ) )
     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) ) ) ) ) ) )
    713411
    714412
    715413;;; Condition variables:
    716414
    717 (define make-condition-variable)
    718 (let ([gensym gensym])
    719   (set! make-condition-variable
    720     (lambda (#!optional (name (gensym 'condition-variable)))
    721       (%make-condition-variable name))) )
    722 
    723 (define (condition-variable? x) (%condition-variable? x) )
    724 
    725 (define (condition-variable-name cv)
    726   (%check-condition-variable cv 'condition-variable-name)
    727   (%condition-variable-name cv) )
     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) )
    728428
    729429(define (condition-variable-specific cv)
    730   (%check-condition-variable cv 'condition-variable-specific)
    731   (%condition-variable-specific cv) )
     430  (##sys#check-structure cv 'condition-variable 'condition-variable-specific)
     431  (##sys#slot cv 3) )
    732432
    733433(define (condition-variable-specific-set! cv x)
    734   (%check-condition-variable cv 'condition-variable-specific-set!)
    735   (%condition-variable-specific-set! cv x) )
    736 
    737 (define (condition-variable-signal! cv)
    738   (%check-condition-variable cv 'condition-variable-signal!)
    739   (dbg "signalling " cv)
    740   (unless (%condition-variable-waiters-empty? cv)
    741     (let* ([t0 (%condition-variable-waiters-pop! cv)]
    742            [t0s (%thread-state t0)] )
    743       (when (or (eq? 'blocked t0s) (eq? 'sleeping t0s))
    744         (##sys#thread-basic-unblock! t0) ) ) ) )
    745 
    746 (define (condition-variable-broadcast! cv)
    747   (%check-condition-variable cv 'condition-variable-broadcast!)
    748   (dbg "broadcasting " cv)
     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)
    749451  (##sys#for-each
    750452   (lambda (ti)
    751      (let ([tis (%thread-state ti)])
    752        (when (or (eq? 'blocked tis) (eq? 'sleeping tis))
     453     (let ([tis (##sys#slot ti 3)])
     454       (when (or (eq? tis 'blocked) (eq? tis 'sleeping))
    753455         (##sys#thread-basic-unblock! ti) ) ) )
    754    (%condition-variable-waiters cv) )
    755   (%condition-variable-waiters-clear! cv) )
     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) ) ) )
    756473
    757474
    758475;;; Don't block in the repl: (by Chris Double)
    759476
    760 (unless (eq? 'msvc (build-platform))
     477(unless (eq? (build-platform) 'msvc)
    761478  (set! ##sys#read-prompt-hook
    762479    (let ([old ##sys#read-prompt-hook]
     
    767484          (##sys#thread-block-for-i/o! ##sys#current-thread 0 #t)
    768485          (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

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