Changeset 34994 in project


Ignore:
Timestamp:
01/08/18 18:53:49 (5 months ago)
Author:
kon
Message:

expd

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

Legend:

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

    r34983 r34994  
    2020  (no-bound-checks)
    2121  (no-argc-checks)
     22  ;shouldn't be needed but lock overhead
    2223  (disable-interrupts) )
    2324
     
    3132  ;
    3233  make-atom atom atom-wrap
     34  ;
    3335  atom? check-atom error-atom
    34   ;atom-mutate atom-validate atom-watch
     36  ;
    3537  atom-value
    3638  atom-value-set!
    3739  ;
    3840  atom-compare-and-set!
    39   atom-apply! )
     41  atom-compare-and-set-with-apply! atom-compare-and-set-with-call!
     42  ;
     43  atom-set!
     44  atom-apply! atom-call!
     45  ;
     46  atom-reset!
     47  atom-swap!)
    4048
    4149(import
     
    8896
    8997(define (make-<atom>-wrapping mut)
    90 (print 'make-<atom>-wrapping " " mut)
    91   (make-<atom>
    92     (let ((val (void)))
    93       ;
    94       (define proc
    95         (case-lambda
    96           (()
    97             val )
    98           ((ival)
    99             (set! val (mut ival))
    100             proc ) ) )
    101       ;
    102       proc ) ) )
     98  (make-<atom> (make-default-<atom>-wrap mut) ) )
     99
     100(define (make-default-<atom>-wrap mut)
     101  (let ((val (default-atom-value)))
     102    ;
     103    (define proc
     104      (case-lambda
     105        (()
     106          val )
     107        ((ival)
     108          (set! val (mut ival))
     109          proc ) ) )
     110    ;
     111    proc ) )
    103112
    104113(define-inline (<atom>-mutex atm)
     
    113122  (check-structure loc obj 'mutex argnam) )
    114123
    115 (define-inline (<atom>-wrapped-value atm)
    116   (mutex-specific (<atom>-mutex atm)) )
     124;
     125
     126(define (<atom>?! atm . args)
     127  (let* (
     128    (mtx (<atom>-mutex atm) )
     129    (rawval (mutex-specific mtx) ) )
     130    ;get/set?
     131    (if (null? args)
     132      ;get
     133      (if (procedure? rawval) (rawval) rawval)
     134      ;set
     135      (let* (
     136        (newval (car args) )
     137        (newval (if (procedure? rawval) (rawval newval) newval) ) )
     138        ;
     139        (mutex-specific-set! mtx newval)
     140        ;
     141        newval ) ) ) )
    117142
    118143(define-inline (<atom>-value atm)
    119   (let ((val (<atom>-wrapped-value atm)))
    120     (if (procedure? val) (val) val) ) )
     144  (<atom>?! atm) )
    121145
    122146;=> (or #f <atom>)
    123147(define-inline (<atom>-value-set! atm val)
    124   (let* (
    125     (oldval (<atom>-wrapped-value atm) )
    126     (newval (if (procedure? oldval) (oldval val) val) ) )
    127     ;
    128     (mutex-specific-set! (<atom>-mutex atm) newval) )
    129   ;need true return; chain return
    130   atm )
     148  (<atom>?! atm val) )
    131149
    132150;
     
    147165          (lambda () (<atom>-unlock! _atm))) ) ) ) )
    148166
    149 ;
    150 
    151 (define-inline (<atom>-compare-and-set! atm old new)
     167(define-inline (<atom>-synch-value-set! atm val)
     168  (<atom>-synch atm (<atom>-value-set! atm val)) )
     169
     170;
     171
     172(define-inline (<atom>-compare-and-set! atm old new pred?)
    152173  ;used by the "spin-lock"
    153174  ;(this buys nothing)
    154175  (and
    155     (eq? (<atom>-value atm) old)
     176    (pred? (<atom>-value atm) old)
    156177    (<atom>-synch atm
    157178      (and
    158         (eq? (<atom>-value atm) old)
    159         (->boolean (<atom>-value-set! atm new)) ) ) ) )
    160 
     179        (pred? (<atom>-value atm) old)
     180        (begin
     181          (<atom>-value-set! atm new)
     182          #t ) ) ) ) )
     183
     184;-> <newval>
    161185(define-syntax <atom>-compare-and-set!-synch
    162186  (syntax-rules ()
     187    ;
     188    ((_ ?atm (?_old ?old) (?_new ?new))
     189      (<atom>-compare-and-set!-synch ?atm (?_old ?old) (?_new ?new) eq?) )
     190    ;
     191    ((_ ?atm (?_old ?old) (?_new ?new) ?pred?)
     192      (let ((_atm ?atm) (_pred? ?pred?))
     193        (spin-until: (<atom>-compare-and-set! _atm ?_old ?_new _pred?)
     194          from: (?_old ?old)
     195          while: (?_new ?new)) ) ) ) )
     196
     197;-> <newval>
     198(define-syntax <atom>-compare-and-set!-stable
     199  (syntax-rules ()
     200    ;
    163201    ((_ ?atm ?_old (?_new ?new))
    164       (let ((_atm ?atm))
    165         (spin-until: (<atom>-compare-and-set! _atm ?_old ?_new)
     202      (<atom>-compare-and-set!-stable ?atm ?_old (?_new ?new) eq?) )
     203    ;
     204    ((_ ?atm ?_old (?_new ?new) ?pred?)
     205      (let ((_atm ?atm) (_pred? ?pred?))
     206        (spin-until: (<atom>-compare-and-set! _atm ?_old ?_new _pred?)
    166207          from: (?_old (<atom>-value _atm))
    167208          while: (?_new ?new)) ) ) ) )
    168209
    169 ;
    170 
    171 (define-inline (<atom>-value-set!-synch atm val)
    172   (<atom>-synch atm (<atom>-value-set! atm val))
    173   ;new value
    174   val )
     210(define-inline (<atom>-value-apply!-synch atm old func args)
     211  (<atom>-compare-and-set!-synch atm (_old old) (_new (apply func _old args))) )
     212
     213(define-inline (<atom>-value-apply!-stable atm func args)
     214  (<atom>-compare-and-set!-stable atm _old (_new (apply func _old args))) )
    175215
    176216;;
     
    259299
    260300;
    261 (define: (atom-value-set! (atm <atom>) (val *)) --> *
    262   (<atom>-value-set!-synch (check-<atom> 'atom-value-set! atm) val) )
     301(define: (atom-value-set! (atm <atom>) (val *))
     302  (<atom>-synch-value-set! (check-<atom> 'atom-value-set! atm) val)
     303  ;
     304  (void) )
    263305
    264306;;
     
    266308;
    267309(define: (atom-compare-and-set! (atm <atom>) (old *) (new *)) -> boolean
    268   (<atom>-compare-and-set! (check-<atom> 'atom-compare-and-set! atm) old new) )
    269 
    270 ;
    271 (define: (atom-apply! (atm <atom>) (proc procedure) . (args (list-of *))) -> *
    272   (check-procedure 'atom-apply! proc)
    273   (<atom>-compare-and-set!-synch
     310  (<atom>-compare-and-set! (check-<atom> 'atom-compare-and-set! atm) old new eq?) )
     311
     312;
     313(define: (atom-compare-and-set-with-apply! (atm <atom>) (old *) (func procedure) (args (list-of *)))
     314  (<atom>-value-apply!-synch
     315    (check-<atom> 'atom-compare-and-set-with-apply! atm)
     316    old
     317    (check-procedure 'atom-compare-and-set-with-apply! func)
     318    args) )
     319
     320;
     321(define: (atom-compare-and-set-with-call! (atm <atom>) (old *) (func procedure) . (args (list-of *)))
     322  (<atom>-value-apply!-synch
     323    (check-<atom> 'atom-compare-and-set-with-call! atm)
     324    old
     325    (check-procedure 'atom-compare-and-set-with-call! func)
     326    args) )
     327
     328;;
     329
     330;
     331(define: (atom-set! (atm <atom>) (val *))
     332  (<atom>-compare-and-set!-stable
     333    (check-<atom> 'atom-swap! atm)
     334    _old
     335    (_new val)) )
     336
     337;
     338(define: (atom-apply! (atm <atom>) (func procedure) (args (list-of *)))
     339  (<atom>-value-apply!-stable
    274340    (check-<atom> 'atom-apply! atm)
    275     old
    276     (new (apply proc old args))) )
     341    (check-procedure 'atom-apply! func)
     342    args) )
     343
     344;
     345(define: (atom-call! (atm <atom>) (func procedure) . (args (list-of *)))
     346  (<atom>-value-apply!-stable
     347    (check-<atom> 'atom-call! atm)
     348    (check-procedure 'atom-call! func)
     349    args) )
     350
     351;;
     352
     353(define atom-reset! atom-value-set!)
     354(define atom-swap! atom-call!)
    277355
    278356) ;atomic-value
  • release/4/thread-utils/trunk/tests/atomic-value-test.scm

    r34981 r34994  
    1919;
    2020(define: (atom-zero! (atm <atom>)) -> number
    21   (atom-value-set! atm 0) )
     21  (atom-set! atm 0)
     22  (atom-value atm) )
    2223
    2324;
    2425(define: (atom-add1! (atm <atom>)) -> number
    25   (atom-apply! atm add1) )
     26  (atom-call! atm add1)
     27  (atom-value atm) )
    2628
    2729;
    2830(define: (atom-sub1! (atm <atom>)) -> number
    29   (atom-apply! atm sub1) )
     31  (atom-call! atm sub1)
     32  (atom-value atm) )
    3033|#
    3134;
     
    3538;
    3639(define (atom-zero! atm)
    37   (atom-value-set! atm 0) )
     40  (atom-set! atm 0)
     41  #;(atom-value atm) )
    3842
    3943;
    4044(define (atom-add1! atm)
    41   (atom-apply! atm add1) )
     45  (atom-call! atm add1)
     46  #;(atom-value atm) )
    4247
    4348;
    4449(define (atom-sub1! atm)
    45   (atom-apply! atm sub1) )
     50  (atom-call! atm sub1)
     51  #;(atom-value atm) )
    4652
    4753;;;
     
    7177(test-group "list mutate"
    7278  (let ((foo (atom (list))))
    73     (atom-apply! foo xcons 3)
    74     (atom-apply! foo xcons 2)
    75     (atom-apply! foo xcons 1)
     79    (atom-compare-and-set-with-call! foo (atom-value foo) xcons 3)
     80    (atom-compare-and-set-with-call! foo (atom-value foo) xcons 2)
     81    (atom-compare-and-set-with-call! foo (atom-value foo) xcons 1)
    7682    (test '(1 2 3) (atom-value foo)) )
    7783)
     
    8490    (test 1 (atom-add1! a))
    8591    (test 0 (atom-sub1! a)) )
     92)
     93
     94;;
     95
     96;
     97
     98(test-group "counter w/ mutator"
     99  (let ((a (atom-wrap add1)))
     100    (test 1 (atom-zero! a))     ;0    +1
     101    (test 3 (atom-add1! a))     ;1 +1 +1
     102    (test 3 (atom-sub1! a)) )   ;3 -1 +1
    86103)
    87104
Note: See TracChangeset for help on using the changeset viewer.