Changeset 34563 in project


Ignore:
Timestamp:
09/17/17 07:49:41 (3 months ago)
Author:
kon
Message:

add thread property access functions

Location:
release/4/thread-utils/trunk
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • release/4/thread-utils/trunk/tests/run.scm

    r30539 r34563  
    2121)
    2222
     23;;
     24
     25(test-group "thread-... access"
     26  (let (
     27      (thgs (list
     28        thread-thunk
     29        thread-result-list
     30        thread-block-timeout
     31        thread-state-buffer
     32        ;thread-end-exception
     33        thread-owned-mutexes
     34        thread-block-object
     35        thread-recipients
     36        thread-dynamic-winds
     37        thread-standard-input
     38        thread-standard-output
     39        thread-standard-error
     40        thread-default-exception-handler
     41        thread-current-parameter-vector
     42        thread-block-object-of-recipient?) )
     43      (th
     44        (make-thread (lambda () (void))) ) )
     45    (for-each
     46      (lambda (x)
     47        (test-assert (not (eq? (void) (x th)))) )
     48      thgs)
     49    (test-assert (thread-end-exception th))
     50  )
     51)
     52
    2353;FIXME needs MORE tests
    2454
  • release/4/thread-utils/trunk/thread-utils.scm

    r34416 r34563  
    11;;;; thread-utils.scm
    22;;;; Kon Lovett, Oct '09
     3;;;; Kon Lovett, Sep '17
    34
    45;; Issues
    56
    6 ; Chicken Generic Arithmetic!
     7;- Chicken Generic Arithmetic!
    78
    89(module thread-utils
     
    2021  ;
    2122  thread-state=?
     23  ;
    2224  thread-created?
    2325  thread-ready?
     
    3436  thread-blocked?/timeout
    3537  ;
    36   thread-unblock!)
     38  thread-unblock!
     39  ;
     40  thread-thunk
     41  thread-result-list
     42  #;thread-state
     43  thread-block-timeout
     44  thread-state-buffer
     45  #;thread-name
     46  thread-end-exception
     47  thread-owned-mutexes
     48  #;thread-quantum
     49  #;thread-specific
     50  thread-block-object
     51  thread-recipients
     52  thread-dynamic-winds
     53  thread-standard-input
     54  thread-standard-output
     55  thread-standard-error
     56  thread-default-exception-handler
     57  thread-current-parameter-vector
     58  ;
     59  thread-block-object-of-recipient?
     60  ;
     61  *thread-thunk
     62  *thread-result-list
     63  *thread-state
     64  *thread-block-timeout
     65  *thread-state-buffer
     66  *thread-name
     67  *thread-end-exception
     68  *thread-owned-mutexes
     69  *thread-quantum
     70  *thread-specific
     71  *thread-block-object
     72  *thread-recipients )
    3773
    3874(import scheme)
    3975
    40 (import chicken
     76(import chicken)
     77
     78(import (only srfi-1 any))
     79(require-library srfi-1)
     80
     81(import
    4182  (only srfi-18
    4283    thread-state thread? current-thread
     
    4485    mutex?
    4586    time? seconds->time time->seconds current-time) )
     87(require-library srfi-18)
    4688
    4789(import (only type-checks define-check+error-type))
     
    5294(define (thread-warning-message th)
    5395  (let ((o (open-output-string)))
    54                 (display "Warning (" o)
    55                 (display th o)
    56                 (display "): " o)
    57                 (get-output-string o) ) )
     96    (display "Warning (" o)
     97    (display th o)
     98    (display "): " o)
     99    (get-output-string o) ) )
    58100
    59101(define (print-exception-error exn #!optional (th (current-thread)) (out (current-error-port)))
     
    62104
    63105(define (print-exception-warning exn #!optional (th (current-thread)) (out (current-error-port)))
    64   (when (enable-warnings) (print-exception-error exn th out)) )
     106  (when (enable-warnings)
     107    (print-exception-error exn th out)) )
    65108
    66109;; Thread Timeout Object (actually any SRFI 12 timeout)
    67110
    68 (define (thread-timeout? obj) (or (not obj) (number? obj) (time? obj)))
     111(define (thread-timeout? obj)
     112        (or (not obj) (number? obj) (time? obj)) )
    69113
    70114(define-check+error-type thread-timeout)
     
    78122      off )
    79123    ((number? off)
    80       (let ((base
    81               (cond
    82                 ((number? base)
    83                   base )
    84                 ((not base)
    85                   (time->seconds (current-time)) )
    86                 ((time? base)
    87                   (time->seconds base) )
    88                 (else
    89                   (error-thread-timeout 'make-thread-timeout base 'base) ) ) ) )
    90           (seconds->time (+ off base)) ) )
     124      (let (
     125          (base
     126            (cond
     127              ((number? base)
     128                base )
     129              ((not base)
     130                (time->seconds (current-time)) )
     131              ((time? base)
     132                (time->seconds base) )
     133              (else
     134                (error-thread-timeout 'make-thread-timeout base 'base) ) ) ) )
     135        (seconds->time (+ off base)) ) )
    91136    (else
    92137      (error-thread-timeout 'make-thread-timeout off 'offset) ) ) )
     
    94139;;; Unchecked slot access
    95140
    96 (define (*thread-block-timeout th) (##sys#slot th 4))
    97 (define (*thread-block-object th) (##sys#slot th 11))
    98 (define (*thread-recipients th) (##sys#slot th 12))
    99 
    100 ;;
    101 
    102 #; ;accurate and precise but more work
    103 (define (block-object-of-recipient? th)
     141(define (*thread-thunk th)
     142        (##sys#slot th 1) )
     143
     144(define (*thread-result-list th)
     145        (##sys#slot th 2) )
     146
     147(define (*thread-state th)
     148        (##sys#slot th 3) )
     149
     150(define (*thread-block-timeout th)
     151        (##sys#slot th 4) )
     152
     153(define (*thread-state-buffer th)
     154        (##sys#slot th 5) )
     155
     156(define (*thread-name th)
     157        (##sys#slot th 6) )
     158
     159(define (*thread-end-exception th)
     160        (##sys#slot th 7) )
     161
     162(define (*thread-owned-mutexes th)
     163        (##sys#slot th 8) )
     164
     165(define (*thread-quantum th)
     166        (##sys#slot th 9) )
     167
     168(define (*thread-specific th)
     169        (##sys#slot th 10) )
     170
     171(define (*thread-block-object th)
     172        (##sys#slot th 11) )
     173
     174(define (*thread-recipients th)
     175        (##sys#slot th 12) )
     176
     177(define (*unblocked-by-timeout? th)
     178        (##sys#slot th 13) )
     179
     180;;
     181
     182(define (*state-buffer-dynamic-winds sb)
     183        (vector-ref sb 0) )
     184
     185(define (*state-buffer-standard-input sb)
     186        (vector-ref sb 1) )
     187
     188(define (*state-buffer-standard-output sb)
     189        (vector-ref sb 2) )
     190
     191(define (*state-buffer-standard-error sb)
     192        (vector-ref sb 3) )
     193
     194(define (*state-buffer-default-exception-handler sb)
     195        (vector-ref sb 4) )
     196
     197(define (*state-buffer-current-parameter-vector sb)
     198        (vector-ref sb 5) )
     199
     200;;
     201
     202(define (thread-block-object-of-recipient? th)
    104203  (any
    105204    (lambda (rth) (eq? (*thread-block-object rth) th))
     
    114213;;
    115214
     215(: thread-state=? ((struct thread) * --> boolean))
    116216(define (thread-state=? th tk)
    117217        (eq? tk (thread-state th)) )
    118218
     219(: thread-created? ((struct thread) --> boolean))
    119220(define (thread-created? th)
    120221        (thread-state=? th 'created) )
    121222
     223(: thread-ready? ((struct thread) --> boolean))
    122224(define (thread-ready? th)
    123225        (thread-state=? th 'ready) )
    124226
     227(: thread-running? ((struct thread) --> boolean))
    125228(define (thread-running? th)
    126229        (thread-state=? th 'running) )
    127230
     231(: thread-blocked? ((struct thread) --> boolean))
    128232(define (thread-blocked? th)
    129233        (thread-state=? th 'blocked) )
    130234
     235(: thread-suspended? ((struct thread) --> boolean))
    131236(define (thread-suspended? th)
    132237        (thread-state=? th 'suspended) )
    133238
     239(: thread-sleeping? ((struct thread) --> boolean))
    134240(define (thread-sleeping? th)
    135241        (thread-state=? th 'sleeping) )
    136242
     243(: thread-terminated? ((struct thread) --> boolean))
    137244(define (thread-terminated? th)
    138245        (thread-state=? th 'terminated) )
    139246
     247(: thread-dead? ((struct thread) --> boolean))
    140248(define (thread-dead? th)
    141249        (thread-state=? th 'dead) )
    142250
     251(: thread-obstructed? ((struct thread) --> boolean))
    143252(define (thread-obstructed? th)
    144253        (or (thread-blocked? th) (thread-sleeping? th)) )
     
    146255;;
    147256
     257(: thread-blocked?/object ((struct thread) --> *))
    148258(define (*thread-blocked?/object th)
    149259  (and
     
    151261    (*thread-block-object th)) )
    152262
     263(: thread-blocked?/termination ((struct thread) --> boolean))
    153264(define (thread-blocked?/termination th)
    154265  (and
    155266    (thread-blocked? th)
    156     ;FIXME accurate but imprecise
    157     (*thread-recipients th)
     267    ;????? ;FIXME accurate but imprecise
     268    (null? (*thread-recipients th))
    158269    #t ) )
    159270
     271(: thread-blocked?/timeout ((struct thread) --> boolean))
    160272(define (thread-blocked?/timeout th)
    161273  (and
     
    165277    #t ) )
    166278
     279(: thread-blocked?/io ((struct thread) --> boolean))
    167280(define (thread-blocked?/io th)
    168281  (and-let* ((obj (*thread-blocked?/object th)))
     
    177290;;
    178291
     292(: thread-unblock! ((struct thread) -> void))
    179293(define (thread-unblock! th)
    180294  (when (thread-blocked?/timeout th)
     
    189303      ((*thread-block-object th)  ) ) ) )
    190304
     305;;
     306
     307(: thread-thunk ((struct thread) --> procedure))
     308(define (thread-thunk th)
     309        (check-thread 'thread-thunk th)
     310        (*thread-thunk th) )
     311
     312(: thread-result-list ((struct thread) --> (or boolean list)))
     313(define (thread-result-list th)
     314        (check-thread 'thread-result-list th)
     315        (*thread-result-list th) )
     316
     317#;
     318(: thread-state ((struct thread) --> *))
     319#;
     320(define (thread-state th)
     321        (check-thread 'thread-state th)
     322        (*thread-state th) )
     323
     324(: thread-block-timeout ((struct thread) --> (or boolean float)))
     325(define (thread-block-timeout th)
     326        (check-thread 'thread-block-timeout th)
     327        (*thread-block-timeout th) )
     328
     329(: thread-state-buffer ((struct thread) --> vector))
     330(define (thread-state-buffer th)
     331        (check-thread 'thread-state-buffer th)
     332        (*thread-state-buffer th) )
     333
     334#;
     335(: thread-name ((struct thread) --> *))
     336#;
     337(define (thread-name th)
     338        (check-thread 'thread-name th)
     339        (*thread-name th) )
     340
     341(: thread-end-exception ((struct thread) --> *))
     342(define (thread-end-exception th)
     343        (check-thread 'thread-end-exception th)
     344        (*thread-end-exception th) )
     345
     346(: thread-owned-mutexes ((struct thread) --> list))
     347(define (thread-owned-mutexes th)
     348        (check-thread 'thread-owned-mutexes th)
     349        (*thread-owned-mutexes th) )
     350
     351#;
     352(: thread-quantum ((struct thread) --> *))
     353#;
     354(define (thread-quantum th)
     355        (check-thread 'thread-quantum th)
     356        (*thread-quantum th) )
     357
     358#;
     359(: thread-specific ((struct thread) --> *))
     360#;
     361(define (thread-specific th)
     362        (check-thread 'thread-specific th)
     363        (*thread-specific th) )
     364
     365(: thread-block-object ((struct thread) --> *))
     366(define (thread-block-object th)
     367        (check-thread 'thread-block-object th)
     368        (*thread-block-object th) )
     369
     370(: thread-recipients ((struct thread) --> list))
     371(define (thread-recipients th)
     372        (check-thread 'thread-recipients th)
     373        (*thread-recipients th) )
     374
     375(: unblocked-by-timeout? ((struct thread) --> boolean))
     376(define (unblocked-by-timeout? th)
     377        (check-thread 'unblocked-by-timeout? th)
     378        (*unblocked-by-timeout? th) )
     379
     380;;
     381
     382(: thread-dynamic-winds (thread --> list))
     383(define (thread-dynamic-winds th)
     384        (check-thread 'thread-dynamic-winds th)
     385        (*state-buffer-dynamic-winds (*thread-state-buffer th)) )
     386
     387(: thread-standard-input (thread --> port))
     388(define (thread-standard-input th)
     389        (check-thread 'thread-standard-input th)
     390        (*state-buffer-standard-input (*thread-state-buffer th)) )
     391
     392(: thread-standard-output (thread --> port))
     393(define (thread-standard-output th)
     394        (check-thread 'thread-standard-output th)
     395        (*state-buffer-standard-output (*thread-state-buffer th)) )
     396
     397(: thread-standard-error (thread --> port))
     398(define (thread-standard-error th)
     399        (check-thread 'thread-standard-error th)
     400        (*state-buffer-standard-error (*thread-state-buffer th)) )
     401
     402(: thread-default-exception-handler (thread --> procedure))
     403(define (thread-default-exception-handler th)
     404        (check-thread 'thread-default-exception-handler th)
     405        (*state-buffer-default-exception-handler (*thread-state-buffer th)) )
     406
     407(: thread-current-parameter-vector (thread --> vector))
     408(define (thread-current-parameter-vector th)
     409        (check-thread 'thread-current-parameter-vector th)
     410        (*state-buffer-current-parameter-vector (*thread-state-buffer th)) )
     411
    191412) ;module thread-utils
  • release/4/thread-utils/trunk/thread-utils.setup

    r34416 r34563  
    55(verify-extension-name "thread-utils")
    66
    7 (setup-shared-extension-module 'thread-utils (extension-version "1.0.4")
     7(setup-shared-extension-module 'thread-utils (extension-version "1.1.0")
    88  #:inline? #t
    99  #:types? #t
     
    1313    -no-procedure-checks) )
    1414
    15 (setup-shared-extension-module 'thread-reaper (extension-version "1.0.4")
     15(setup-shared-extension-module 'thread-reaper (extension-version "1.1.0")
    1616  #:inline? #t
    1717  #:types? #t
Note: See TracChangeset for help on using the changeset viewer.