Changeset 34996 in project


Ignore:
Timestamp:
01/08/18 21:28:49 (8 days ago)
Author:
kon
Message:

better , schemey , names

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

Legend:

Unmodified
Added
Removed
  • release/4/thread-utils/trunk/atomic-value.scm

    r34995 r34996  
    77;; - umm, just look
    88;;
    9 ;; - something like mutex-conditions for state-change watchers?
    10 ;;
    119;; - clojure validators and watches
     10;;
     11;;  - something like mutex-conditions for state-change watchers?
    1212
    1313;;;
     
    3434  ;
    3535  atom? check-atom error-atom
     36  atom-wrapped?
    3637  ;
    3738  atom-value
     
    3940  ;
    4041  atom-compare-and-set!
    41   atom-wait-and-apply! atom-wait-and-call!
    4242  ;
    4343  atom-set!
    4444  atom-apply! atom-call!
     45  ;
     46  atom-wait-and-apply! atom-wait-and-call!
    4547  ;
    4648  atom-reset!
     
    9193    mu ) )
    9294
    93 (define (make-<atom>-wrapping mut)
    94   (make-<atom> (make-default-<atom>-wrap mut) ) )
    95 
    96 (define (make-default-<atom>-wrap mut)
     95(define-inline (<atom>-mutex atm)
     96  atm )
     97
     98(define-inline (<atom>? obj)
     99  (and
     100    (mutex? obj)
     101    (eq? '<atom> (mutex-name obj)) ) )
     102
     103(define-inline (check-<atom> loc obj #!optional (argnam 'atom))
     104  (check-structure loc obj 'mutex argnam) )
     105
     106;
     107
     108(define (make-wrapped-<atom> mut)
     109  (make-<atom> (make-default-wrapped-<atom> mut) ) )
     110
     111(define (make-default-wrapped-<atom> mut)
    97112  (let ((val (default-atom-value)))
    98113    ;
     
    107122    proc ) )
    108123
    109 (define-inline (<atom>-mutex atm)
    110   atm )
    111 
    112 (define-inline (<atom>? obj)
    113   (and
    114     (mutex? obj)
    115     (eq? '<atom> (mutex-name obj)) ) )
    116 
    117 (define-inline (check-<atom> loc obj #!optional (argnam 'atom))
    118   (check-structure loc obj 'mutex argnam) )
    119 
    120 ;
    121 
    122 (define (<atom>?! atm . args)
     124(define-inline (<atom>-wrapped? atm)
     125  (procedure? (mutex-specific (<atom>-mutex atm))) )
     126
     127(define (<atom>-unwrap atm . args)
    123128  (let* (
    124129    (mtx (<atom>-mutex atm) )
     
    138143
    139144(define-inline (<atom>-value atm)
    140   (<atom>?! atm) )
     145  (<atom>-unwrap atm) )
    141146
    142147;=> (or #f <atom>)
    143148(define-inline (<atom>-value-set! atm val)
    144   (<atom>?! atm val) )
     149  (<atom>-unwrap atm val) )
    145150
    146151;
     
    238243;NOTE the {{mut}} need only return a value for the atom ,
    239244;side-effects are extra - so validators and watchers are possible
    240 ;via a suitable {{mut}}
     245;via a suitable {{mut}}.
     246;
     247;but the {{mut}} better be quick, disable-interrupts remember.
    241248;
    242249(define: (atom-wrap (mut procedure)) --> <atom>
    243   (make-<atom>-wrapping (check-procedure 'atom-wrap mut)) )
     250  (make-wrapped-<atom> (check-procedure 'atom-wrap mut)) )
    244251
    245252;
     
    254261(define: (error-atom (loc symbol) . (args list))
    255262(apply signal-type-error loc (make-error-type-message 'atom) args) )
     263
     264;
     265(define: (atom-wrapped? (obj *)) --> boolean
     266  (and
     267    (<atom>? obj)
     268    (<atom>-wrapped? obj) ) )
     269
     270;;
     271
     272;
     273(define: (atom-value (atm <atom>)) --> *
     274  (<atom>-value (check-<atom> 'atom-value atm)) )
     275
     276;
     277(define: (atom-value-set! (atm <atom>) (val *))
     278  (<atom>-synch-value-set! (check-<atom> 'atom-value-set! atm) val)
     279  ;
     280  (void) )
     281
     282;;
     283
     284;
     285(define: (atom-compare-and-set! (atm <atom>) (old *) (new *)) -> boolean
     286  (<atom>-compare-and-set! (check-<atom> 'atom-compare-and-set! atm) old new eq?) )
     287
     288;;
     289
     290;
     291(define: (atom-set! (atm <atom>) (val *))
     292  (<atom>-compare-and-set!-stable
     293    (check-<atom> 'atom-swap! atm)
     294    _old
     295    (_new val))
     296  ;
     297  (void) )
     298
     299;
     300(define: (atom-apply! (atm <atom>) (func procedure) (args (list-of *)))
     301  (<atom>-value-apply!-stable
     302    (check-<atom> 'atom-apply! atm)
     303    (check-procedure 'atom-apply! func)
     304    args)
     305  ;
     306  (void) )
     307
     308;
     309(define: (atom-call! (atm <atom>) (func procedure) . (args (list-of *)))
     310  (<atom>-value-apply!-stable
     311    (check-<atom> 'atom-call! atm)
     312    (check-procedure 'atom-call! func)
     313    args)
     314  ;
     315  (void) )
     316
     317;;
     318
     319;
     320(define: (atom-wait-and-apply! (atm <atom>) (old *) (func procedure) (args (list-of *)))
     321  (<atom>-value-apply!-synch
     322    (check-<atom> 'atom-wait-and-apply! atm)
     323    old
     324    (check-procedure 'atom-wait-and-apply! func)
     325    args)
     326  ;
     327  (void) )
     328
     329;
     330(define: (atom-wait-and-call! (atm <atom>) (old *) (func procedure) . (args (list-of *)))
     331  (<atom>-value-apply!-synch
     332    (check-<atom> 'atom-wait-and-call! atm)
     333    old
     334    (check-procedure 'atom-wait-and-call! func)
     335    args)
     336  ;
     337  (void) )
     338
     339;; Clojure-like
     340
     341(define atom-reset! atom-value-set!)
     342(define atom-swap! atom-call!)
    256343
    257344;;
     
    292379|#
    293380
    294 ;;
    295 
    296 ;
    297 (define: (atom-value (atm <atom>)) --> *
    298   (<atom>-value (check-<atom> 'atom-value atm)) )
    299 
    300 ;
    301 (define: (atom-value-set! (atm <atom>) (val *))
    302   (<atom>-synch-value-set! (check-<atom> 'atom-value-set! atm) val)
    303   ;
    304   (void) )
    305 
    306 ;;
    307 
    308 ;
    309 (define: (atom-compare-and-set! (atm <atom>) (old *) (new *)) -> boolean
    310   (<atom>-compare-and-set! (check-<atom> 'atom-compare-and-set! atm) old new eq?) )
    311 
    312 ;;
    313 
    314 ;
    315 (define: (atom-set! (atm <atom>) (val *))
    316   (<atom>-compare-and-set!-stable
    317     (check-<atom> 'atom-swap! atm)
    318     _old
    319     (_new val))
    320   ;
    321   (void) )
    322 
    323 ;
    324 (define: (atom-apply! (atm <atom>) (func procedure) (args (list-of *)))
    325   (<atom>-value-apply!-stable
    326     (check-<atom> 'atom-apply! atm)
    327     (check-procedure 'atom-apply! func)
    328     args)
    329   ;
    330   (void) )
    331 
    332 ;
    333 (define: (atom-call! (atm <atom>) (func procedure) . (args (list-of *)))
    334   (<atom>-value-apply!-stable
    335     (check-<atom> 'atom-call! atm)
    336     (check-procedure 'atom-call! func)
    337     args)
    338   ;
    339   (void) )
    340 
    341 ;;
    342 
    343 ;
    344 (define: (atom-wait-and-apply! (atm <atom>) (old *) (func procedure) (args (list-of *)))
    345   (<atom>-value-apply!-synch
    346     (check-<atom> 'atom-wait-and-apply! atm)
    347     old
    348     (check-procedure 'atom-wait-and-apply! func)
    349     args)
    350   ;
    351   (void) )
    352 
    353 ;
    354 (define: (atom-wait-and-call! (atm <atom>) (old *) (func procedure) . (args (list-of *)))
    355   (<atom>-value-apply!-synch
    356     (check-<atom> 'atom-wait-and-call! atm)
    357     old
    358     (check-procedure 'atom-wait-and-call! func)
    359     args)
    360   ;
    361   (void) )
    362 
    363 ;;
    364 
    365 (define atom-reset! atom-value-set!)
    366 (define atom-swap! atom-call!)
    367 
    368381) ;atomic-value
  • release/4/thread-utils/trunk/tests/atomic-value-test.scm

    r34995 r34996  
    1 ;;;; atom-test.scm -*- Hen -*-
     1;;;; atomic-value-test.scm -*- Hen -*-
    22
    33(use test)
     
    1414
    1515;
    16 (define: (atom-zero) --> <atom>
    17   (atom 0) )
    18 
    19 ;
    2016(define: (atom-zero! (atm <atom>)) -> number
    2117  (atom-set! atm 0) )
     
    2925  (atom-call! atm sub1) )
    3026|#
    31 ;
    32 (define (atom-zero)
    33   (atom 0) )
    34 
    3527;
    3628(define (atom-zero! atm)
     
    9183
    9284(test-group "counter w/ mutator"
    93   (let ((a (atom-wrap add1)))
     85  (let ((a (atom-wrap add1)))                          ;     +1
    9486    (test 1 (begin (atom-zero! a) (atom-value a)))     ;0    +1
    9587    (test 3 (begin (atom-add1! a) (atom-value a)))     ;1 +1 +1
     
    9991;;
    10092
    101 (define-constant *loop-limit* 10000)
     93(define-constant *loop-limit* 100000)
    10294(define-constant *wait-limit* 10)
    10395
    10496(define (random-time)
    105   (fp/ (exact->inexact (random *wait-limit*)) (exact->inexact *ms/sec*)) )
     97  (fp/ (exact->inexact (random *wait-limit*)) (exact->inexact *ms/sec*))
     98  #; ;much slower ;-)
     99  (exact->inexact (/ (random *wait-limit*) *ms/sec*)) )
    106100
    107101(define (random-sleep!)
     
    113107    (string-append "random-activation-atom-add1-thread-" (number->string n))) )
    114108
     109(define (make-random-activation-atom-add1-threads atm lim)
     110  (map
     111    (cut make-random-activation-atom-add1-thread atm <>)
     112    (iota lim)) )
     113
     114(define (run-random-activation-atom-add1-threads atm lim)
     115  (map
     116    thread-start!
     117    (make-random-activation-atom-add1-threads atm lim)) )
     118
     119(test-begin "many threads; please wait")
    115120(test-group
    116121  (string-append
     
    118123    (number->string *loop-limit*) " updaters w/ random waiting <= "
    119124    (number->string *wait-limit*) "ms")
    120 
    121   (let ((counter (atom-zero)))
    122     ;run all the mutators
    123     (for-each thread-join!
    124       (map thread-start!
    125         (map (cut make-random-activation-atom-add1-thread counter <>)
    126           (iota *loop-limit*))))
     125  ;
     126  (let ((counter (atom 0)))
     127    ;run all the mutators & enjoin to primordial
     128    (for-each thread-join! (run-random-activation-atom-add1-threads counter *loop-limit*))
    127129    ;each should have left their mark
    128130    (test *loop-limit* (atom-value counter)) )
    129131)
     132(test-end)
    130133
    131134;;
Note: See TracChangeset for help on using the changeset viewer.