Changeset 34998 in project


Ignore:
Timestamp:
01/09/18 18:13:36 (11 months ago)
Author:
kon
Message:

rational wrapping , mutate/validate/watch (perv)

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

Legend:

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

    r34996 r34998  
    3131  default-atom-value
    3232  ;
    33   make-atom atom atom-wrap
     33  make-atom atom
    3434  ;
    3535  atom? check-atom error-atom
    36   atom-wrapped?
     36  ;
     37  atom-wrap atom-wrapped?
     38  ;
     39  atom-mutate atom-validate atom-watch
    3740  ;
    3841  atom-value
     
    5255(use
    5356  srfi-18
    54   (only data-structures identity)
     57  (only data-structures constantly)
    5558  (only miscmacros define-parameter)
    5659  (only type-checks check-structure check-procedure check-symbol)
     
    6265;;
    6366
     67(define ((argument n) . args)
     68  (list-ref args n) )
     69
    6470;spin-lock
    6571(define-syntax spin-until:
    66   (syntax-rules (from: while:)
    67     ((_  ?pred? from: (?_old ?old) while: (?_new ?new))
     72  (syntax-rules (from: to:)
     73    ((_ ?done? from: (?_old ?old) to: (?_new ?new))
    6874      (let loop ()
    6975        (let* (
     
    7177          (?_new ?new) )
    7278          ;
    73           (if ?pred?
     79          (if ?done?
    7480            ?_new
    7581            (loop) ) ) ) ) ) )
     
    8894;
    8995
    90 (define-inline (make-<atom> va)
     96(define (make-<atom> va)
    9197  (let ((mu (make-mutex '<atom>)))
    9298    (mutex-specific-set! mu va)
     
    104110  (check-structure loc obj 'mutex argnam) )
    105111
    106 ;
    107 
    108 (define (make-wrapped-<atom> mut)
    109   (make-<atom> (make-default-wrapped-<atom> mut) ) )
    110 
    111 (define (make-default-wrapped-<atom> mut)
    112   (let ((val (default-atom-value)))
    113     ;
    114     (define proc
     112(define (make-wrapped-<atom> next)
     113  (make-<atom> (make-<atom>-wrapper next) ) )
     114
     115(define (make-<atom>-wrapper next #!optional (initial (default-atom-value)))
     116  (let (
     117    (+value+ initial) )
     118    ;
     119    (define boxprc
    115120      (case-lambda
    116121        (()
    117           val )
     122          +value+ )
    118123        ((ival)
    119           (set! val (mut ival))
    120           proc ) ) )
    121     ;
    122     proc ) )
     124          (set! +value+ (next +value+ ival))
     125          boxprc )
     126        ((mode wrap)
     127          (let (
     128            (next-next
     129              (case mode
     130                ((before #:before)
     131                  (lambda (o n) (next o (wrap o n))) )
     132                ((after #:after)
     133                  (lambda (o n) (wrap o (next o n))) )
     134                ((around #:around)
     135                  (lambda (o n) (wrap o (next o (wrap o n)))) ) ) ) )
     136            (set! next next-next) )
     137          boxprc ) ) )
     138    ;
     139    boxprc ) )
    123140
    124141(define-inline (<atom>-wrapped? atm)
    125142  (procedure? (mutex-specific (<atom>-mutex atm))) )
     143
     144;
    126145
    127146(define (<atom>-unwrap atm . args)
     
    151170;
    152171
     172(define (make-<atom>* val)
     173  (if (procedure? val)
     174    (make-wrapped-<atom> (constantly val))
     175    (make-<atom> val) ) )
     176
     177(define (<atom>-wrap atm mode wrap)
     178  (let* (
     179    (mtx (<atom>-mutex atm) )
     180    (rawval (mutex-specific mtx) ) )
     181    ;wrapped ? then do it , otherwise from scratch
     182    (if (procedure? rawval)
     183      (rawval mode wrap)
     184      (mutex-specific-set! mtx (make-<atom>-wrapper wrap rawval)) ) )
     185  atm )
     186
     187;
     188
    153189(define-inline (<atom>-lock! atm)
    154190  (mutex-lock! (<atom>-mutex atm)) )
     
    196232        (spin-until: (<atom>-compare-and-set! _atm ?_old ?_new _pred?)
    197233          from: (?_old ?old)
    198           while: (?_new ?new)) ) ) ) )
     234          to: (?_new ?new)) ) ) ) )
    199235
    200236(define-inline (<atom>-value-apply!-synch atm old func args)
     
    214250        (spin-until: (<atom>-compare-and-set! _atm ?_old ?_new _pred?)
    215251          from: (?_old (<atom>-value _atm))
    216           while: (?_new ?new)) ) ) ) )
     252          to: (?_new ?new)) ) ) ) )
    217253
    218254(define-inline (<atom>-value-apply!-stable atm func args)
     
    237273;
    238274(define: (atom (val *)) --> <atom>
    239   (if (procedure? val)
    240     (<atom>-value-set! (atom-wrap identity) val)
    241     (make-<atom> val) ) )
    242 
    243 ;NOTE the {{mut}} need only return a value for the atom ,
    244 ;side-effects are extra - so validators and watchers are possible
    245 ;via a suitable {{mut}}.
    246 ;
    247 ;but the {{mut}} better be quick, disable-interrupts remember.
    248 ;
    249 (define: (atom-wrap (mut procedure)) --> <atom>
    250   (make-wrapped-<atom> (check-procedure 'atom-wrap mut)) )
     275  (make-<atom>* val) )
    251276
    252277;
     
    261286(define: (error-atom (loc symbol) . (args list))
    262287(apply signal-type-error loc (make-error-type-message 'atom) args) )
     288
     289;NOTE the {{next}} need only return a value for the atom ,
     290;side-effects are extra - so validators & watchers are possible
     291;via a suitable {{next}}.
     292;
     293;but the {{next}} better be quick, disable-interrupts remember.
     294;
     295(define: (atom-wrap . (args (list (or boolean (* * --> *))))) --> <atom>
     296  (let ((next (optional args (argument 1))))
     297    (make-wrapped-<atom> (check-procedure 'atom-wrap next 'next)) ) )
    263298
    264299;
     
    270305;;
    271306
     307;(* --> *)
     308(define: (atom-mutate (atm <atom>) (mutt procedure)) --> <atom>
     309  (check-procedure 'atom-mutate mutt 'mutate)
     310  (check-<atom> 'atom-mutate atm)
     311  (<atom>-synch atm (<atom>-wrap atm #:after (lambda (_ n) (mutt n)))) )
     312
     313;(* --> boolean)
     314(define: (atom-validate (atm <atom>) (vald? procedure)) --> <atom>
     315  (check-procedure 'atom-validate vald? 'valid?)
     316  (check-<atom> 'atom-validate atm)
     317  (<atom>-synch atm (<atom>-wrap atm #:after (lambda (o n) (if (vald? n) n o)))) )
     318
     319;(* * --> *)
     320(define: (atom-watch (atm <atom>) (mode symbol) (wtch procedure)) --> <atom>
     321  (check-<atom> 'atom-apply! atm)
     322  (check-symbol 'atom-watch mode 'mode)
     323  (check-procedure 'atom-watch wtch 'watch)
     324  (<atom>-synch atm (<atom>-wrap atm mode wtch)) )
     325
     326;;
     327
    272328;
    273329(define: (atom-value (atm <atom>)) --> *
     
    291347(define: (atom-set! (atm <atom>) (val *))
    292348  (<atom>-compare-and-set!-stable
    293     (check-<atom> 'atom-swap! atm)
     349    (check-<atom> 'atom-set! atm)
    294350    _old
    295351    (_new val))
     
    342398(define atom-swap! atom-call!)
    343399
    344 ;;
    345 
    346 #|
    347 ;http://blog.fogus.me/2011/09/23/clojurescript-watchers-and-validators/
    348 
    349 (define: (atom-mutate (atm <atom>) (mutator (* -> *))) --> <atom>
    350   (check-<atom> 'atom-mutate atm)
    351   ;then magic occurs
    352   atm )
    353 
    354 (define: (atom-validate (atm <atom>) (validator (* -> boolean))) --> <atom>
    355   (check-<atom> 'atom-validate atm)
    356   ;then magic occurs
    357   atm )
    358 
    359 (define: (atom-watch (atm <atom>) (watcher (* -> void))) --> <atom>
    360   (check-<atom> 'atom-watch atm)
    361   ;then magic occurs
    362   atm )
    363 |#
    364 
    365 #|
    366 (define: (atom-advise (mode symbol) (atm <atom>) (advisor procedure) . (args (list symbol))) --> symbol
    367   (check-symbol 'atom-advise mode)
    368   (check-<atom> 'atom-advise atm)
    369   (check-procedure 'atom-advise advisor)
    370   (let* (
    371     (id (optional args #f)) )
    372     (id (or id (gensym 'atom-advise)) )
    373     ;
    374     ;locate/create wrap proc & then 'advise it (advice egg)
    375     id ) )
    376 
    377 (define: (atom-unadvise (mode symbol) (atm <atom>) (id symbol))
    378   (void) )
    379 |#
    380 
    381400) ;atomic-value
  • release/4/thread-utils/trunk/tests/atomic-value-test.scm

    r34996 r34998  
    8383
    8484(test-group "counter w/ mutator"
    85   (let ((a (atom-wrap add1)))                          ;     +1
    86     (test 1 (begin (atom-zero! a) (atom-value a)))     ;0    +1
    87     (test 3 (begin (atom-add1! a) (atom-value a)))     ;1 +1 +1
    88     (test 3 (begin (atom-sub1! a) (atom-value a))) )   ;3 -1 +1
     85  (let ((a (atom-mutate (atom 0) add1)))                ;     +1
     86    (test 1 (begin (atom-zero! a) (atom-value a)))      ;0    +1
     87    (test 3 (begin (atom-add1! a) (atom-value a)))      ;1 +1 +1
     88    (test 3 (begin (atom-sub1! a) (atom-value a))) )    ;3 -1 +1
    8989)
    9090
Note: See TracChangeset for help on using the changeset viewer.