Changeset 34981 in project


Ignore:
Timestamp:
01/03/18 18:52:32 (12 months ago)
Author:
kon
Message:

fix spin

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

Legend:

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

    r34963 r34981  
    3737  ;
    3838  atom-compare-and-set!
    39   atom-mutate! )
     39  atom-apply! )
    4040
    4141(import
     
    4848  (only miscmacros define-parameter)
    4949  (only moremacros ->boolean)
    50   (only type-checks check-structure check-procedure)
     50  (only type-checks check-structure check-procedure check-symbol)
    5151  (only type-errors signal-type-error make-error-type-message)
    5252  typed-define)
     
    5757
    5858;spin-lock
    59 (define-syntax spin-until
     59(define-syntax spin-until:
    6060  (syntax-rules (from: while:)
    61     ((_  (?done? ...) from: (?_old ?old) while: (?_new ?new))
     61    ((_  ?pred? from: (?_old ?old) while: (?_new ?new))
    6262      (let loop ()
    6363        (let* (
     
    6565          (?_new ?new) )
    6666          ;
    67           (if (begin ?done? ...)
    68             ?_new
    69             (loop) ) ) ) ) ) )
    70 
    71 #;
    72 ;spin-lock
    73 (define-syntax spin-until
    74   (syntax-rules ()
    75     ((_ (?_old ?old) (?_new ?new) ?done? ...)
    76       (let loop ()
    77         (let* (
    78           (?_old ?old)
    79           (?_new ?new) )
    80           ;
    81           (if (begin ?done? ...)
     67          (if ?pred?
    8268            ?_new
    8369            (loop) ) ) ) ) ) )
     
    10187    mu ) )
    10288
     89(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 ) ) )
     103
    103104(define-inline (<atom>? obj)
    104105  (and
     
    113114
    114115(define-inline (<atom>-value atm)
    115   (let ((func (mutex-specific atm)))
    116     (func) ) )
     116  (let ((val (mutex-specific atm)))
     117    (if (procedure? val) (val) val) ) )
    117118
    118119;=> (or #f <atom>)
    119120(define-inline (<atom>-value-set! atm val)
    120   (let ((func (mutex-specific atm)))
    121     (mutex-specific-set! atm (func val)) )
    122   ;need true return
     121  (let* (
     122    (oldval (mutex-specific atm) )
     123    (newval (if (procedure? oldval) (oldval val) val) ) )
     124    ;
     125    (mutex-specific-set! atm newval) )
     126  ;need true return; chain return
    123127  atm )
    124128
     
    144148(define-inline (<atom>-compare-and-set! atm old new)
    145149  ;used by the "spin-lock"
     150  ;(this buys nothing)
    146151  (and
    147152    (eq? (<atom>-value atm) old)
     
    155160    ((_ ?atm ?_old (?_new ?new))
    156161      (let ((_atm ?atm))
    157         (spin-until
    158           (<atom>-compare-and-set! _atm ?_old ?_new)
    159           from: (?_old (<atom>-value _atm)) while: (?_new ?new))
    160           #;
    161         (spin-until
    162           (?_old (<atom>-value _atm))
    163             ;&
    164           (?_new ?new)
    165             ;sync
    166           (<atom>-compare-and-set! _atm ?_old ?_new)) ) ) ) )
     162        (spin-until: (<atom>-compare-and-set! _atm ?_old ?_new)
     163          from: (?_old (<atom>-value _atm))
     164          while: (?_new ?new)) ) ) ) )
    167165
    168166;
     
    190188
    191189;
    192 (define: (atom (oval *)) --> <atom>
    193   (<atom>-value-set! (atom-wrap identity) oval) )
     190(define: (atom (val *)) --> <atom>
     191  (if (procedure? val)
     192    (<atom>-value-set! (make-<atom>-wrapping identity) val)
     193    (make-<atom> val) ) )
    194194
    195195;NOTE the {{mut}} need only return a value for the atom ,
    196 ;side-effects are extra - so validators and watches are possible
     196;side-effects are extra - so validators and watchers are possible
    197197;via a suitable {{mut}}
    198 ; - (atom-mutator atom <func/1>)
    199 ; - (atom-validator atom <func/1>)
    200 ; - (atom-watcher atom <func/1>)
     198;- (atom-mutator atom <func/1>)
     199;- (atom-validator atom <func/1>)
     200;- (atom-watcher atom <func/1>)
    201201;
    202202(define: (atom-wrap (mut procedure)) --> <atom>
    203   (check-procedure 'atom-wrap mut)
    204   (make-<atom>
    205     (let ((val (void)))
    206       ;
    207       (define proc
    208         (case-lambda
    209           (() val)
    210           ((ival)
    211             (set! val (mut ival))
    212             proc ) ) )
    213       ;
    214       proc ) ) )
     203  (make-<atom>-wrapping (check-procedure 'atom-wrap mut)) )
    215204
    216205;
     
    226215(apply signal-type-error loc (make-error-type-message 'atom) args) )
    227216
    228 #| ;http://blog.fogus.me/2011/09/23/clojurescript-watchers-and-validators/
    229 ;;
     217;;
     218
     219#|
     220;http://blog.fogus.me/2011/09/23/clojurescript-watchers-and-validators/
    230221
    231222(define: (atom-mutate (atm <atom>) (mutator (* -> *))) --> <atom>
     
    239230  atm )
    240231
    241 (define: (atom-watch (atm <atom>) (watcher (*))) --> <atom>
     232(define: (atom-watch (atm <atom>) (watcher (* -> void))) --> <atom>
    242233  (check-<atom> 'atom-watch atm)
    243234  ;then magic occurs
     
    245236|#
    246237
     238#|
     239(define: (atom-advise (mode symbol) (atm <atom>) (advisor procedure) . (args (list symbol))) --> symbol
     240  (check-symbol 'atom-advise mode)
     241  (check-<atom> 'atom-advise atm)
     242  (check-procedure 'atom-advise advisor)
     243  (let* (
     244    (id (optional args #f)) )
     245    (id (or id (gensym 'atom-advise)) )
     246    ;
     247    ;create wrap proc & then 'advise it (advice egg)
     248    id ) )
     249(define: (atom-unadvise (mode symbol) (atm <atom>) (id symbol))
     250  (void) )
     251|#
     252
    247253;;
    248254
     
    262268
    263269;
    264 (define: (atom-mutate! (atm <atom>) (proc procedure) . (args (list-of *))) -> *
     270(define: (atom-apply! (atm <atom>) (proc procedure) . (args (list-of *))) -> *
     271  (check-procedure 'atom-apply! proc)
    265272  (<atom>-compare-and-set!-synch
    266     (check-<atom> 'atom-mutate! atm)
     273    (check-<atom> 'atom-apply! atm)
    267274    old
    268     (new (apply (check-procedure 'atom-mutate! proc) old args))) )
     275    (new (apply proc old args))) )
    269276
    270277) ;atomic-value
  • release/4/thread-utils/trunk/tests/atomic-value-test.scm

    r34914 r34981  
    2323;
    2424(define: (atom-add1! (atm <atom>)) -> number
    25   (atom-mutate! atm add1) )
     25  (atom-apply! atm add1) )
    2626
    2727;
    2828(define: (atom-sub1! (atm <atom>)) -> number
    29   (atom-mutate! atm sub1) )
     29  (atom-apply! atm sub1) )
    3030|#
    3131;
     
    3939;
    4040(define (atom-add1! atm)
    41   (atom-mutate! atm add1) )
     41  (atom-apply! atm add1) )
    4242
    4343;
    4444(define (atom-sub1! atm)
    45   (atom-mutate! atm sub1) )
     45  (atom-apply! atm sub1) )
    4646
    4747;;;
     
    7171(test-group "list mutate"
    7272  (let ((foo (atom (list))))
    73     (atom-mutate! foo xcons 3)
    74     (atom-mutate! foo xcons 2)
    75     (atom-mutate! foo xcons 1)
     73    (atom-apply! foo xcons 3)
     74    (atom-apply! foo xcons 2)
     75    (atom-apply! foo xcons 1)
    7676    (test '(1 2 3) (atom-value foo)) )
    7777)
Note: See TracChangeset for help on using the changeset viewer.