Changeset 16025 in project


Ignore:
Timestamp:
09/22/09 04:01:15 (10 years ago)
Author:
Kon Lovett
Message:

Fixes for lock/unlock support and new synch-object module.

Location:
release/4/synch/trunk
Files:
1 added
4 edited

Legend:

Unmodified
Added
Removed
  • release/4/synch/trunk/synch.meta

    r13830 r16025  
    77 (doc-from-wiki)
    88 (synopsis "Synchronization Forms")
    9  (needs setup-helper)
     9 (needs setup-helper check-errors)
    1010 (files
    1111  "synch.scm"
     12  "synch-object.scm"
    1213  "synch.setup"
    1314  "tests") )
  • release/4/synch/trunk/synch.scm

    r15954 r16025  
    22;;;; Kon Lovett, Mar '06
    33
     4;; Issues
     5;;
     6;; - syntax checking is minimal so expansion errors are cryptic
     7
    48(module synch (;export
    5   ;;
    6   make-object/synch
    7   object?/synch
    89  ;;
    910  synch
     
    4041          (only chicken define-for-syntax optional
    4142                        void unless warning gensym dynamic-wind)
    42           (only data-structures conc constantly)
    43           (only srfi-18 thread? make-mutex mutex? mutex-specific mutex-specific-set!
     43          (only data-structures conc)
     44          (only srfi-18 thread? mutex-specific mutex-specific-set!
    4445                        mutex-lock! mutex-unlock! mutex-state) )
    4546
     
    4849;;;
    4950
    50 (define-for-syntax (recmuxnam nam)
    51   (string->symbol (conc nam #\- 'mutex)) )
    52 
    53 ;;;
    54 
    55 (define (make-object/synch obj #!optional (name '(synchobj)))
    56   (let ((mutex (make-mutex (if (pair? name) (gensym (car name)) name))))
    57     (mutex-specific-set! mutex obj)
    58     mutex ) )
    59 
    60 (define object?/synch
    61   (let ((tpred (constantly #t)))
    62     (lambda (obj #!optional (pred tpred))
    63       (and (mutex? obj)
    64            (let ((ms (mutex-specific obj)))
    65              (and (not (eq? (void) ms))
    66                   (pred ms)) ) ) ) ) )
     51(define-for-syntax (recmuxnam nam) (string->symbol (conc nam #\- 'mutex)))
    6752
    6853;;; Protected
     
    7055(define-syntax synch
    7156        (syntax-rules ()
    72                 ((_ ?mtx ?body ...)
     57                ((_ (?mtx (?lock-arg0 ...) (?unlock-arg0 ...)) ?body ...)
    7358        (let ((mtx ?mtx))
    7459        (dynamic-wind
    75           (lambda () (mutex-lock! mtx))
     60          (lambda () (mutex-lock! mtx ?lock-arg0 ...))
    7661          (lambda () ?body ...)
    77           (lambda () (mutex-unlock! mtx)) ) ) ) ) )
     62          (lambda () (mutex-unlock! mtx ?unlock-arg0 ...)) ) ) )
     63                ((_ (?mtx (?lock-arg0 ...)) ?body ...)
     64        (synch (?mtx (?lock-arg0 ...) ()) ?body ...) )
     65                ((_ ?mtx ?body ...)
     66        (synch (?mtx () ()) ?body ...) ) ) )
    7867
    7968(define-syntax synch-with
    80   (lambda (form r c)
    81     (##sys#check-syntax 'synch-with form '(_ _ variable . #(_ 0)))
    82     (let (($dynamic-wind (r 'dynamic-wind))
    83           ($let (r 'let))
    84           ($lambda (r 'lambda))
    85           ($mutex-unlock! (r 'mutex-unlock!))
    86           ($mutex-specific (r 'mutex-specific))
    87           ($mutex-lock! (r 'mutex-lock!))
    88           (mtxvar (r (gensym))))
    89       (let ((?mtx (cadr form)) (?var (caddr form)) (?body (cdddr form)))
    90                     `(,$let ((,mtxvar ,?mtx))
    91            (,$let ((,?var (,$mutex-specific ,mtxvar)))
    92              (,$dynamic-wind
    93                (,$lambda () (,$mutex-lock! ,mtxvar))
    94                                              (,$lambda () ,@?body)
    95                                              (,$lambda () (,$mutex-unlock! ,mtxvar)) ) ) ) ) ) ) )
     69  (lambda (frm rnm cmp)
     70    (##sys#check-syntax 'synch-with frm '(_ _ variable . #(_ 0)))
     71    (let ((_dynamic-wind (rnm 'dynamic-wind))
     72          (_let (rnm 'let))
     73          (_lambda (rnm 'lambda))
     74          (_mutex-unlock! (rnm 'mutex-unlock!))
     75          (_mutex-specific (rnm 'mutex-specific))
     76          (_mutex-lock! (rnm 'mutex-lock!))
     77          (mtxvar (rnm (gensym))))
     78      (let ((?mtx (cadr frm)) (?var (caddr frm)) (?body (cdddr frm)) )
     79        (call-with-values
     80          (lambda ()
     81            (if (not (pair? ?mtx)) (values ?mtx '() '())
     82                (let ((mtx (car ?mtx))
     83                      (lock-args (if (<= 2 (length ?mtx)) (cadr ?mtx) '()))
     84                      (unlock-args (if (= 3 (length ?mtx)) (caddr ?mtx) '())) )
     85                  (values mtx lock-args unlock-args) ) ) )
     86          (lambda (?mtx ?lock-args ?unlock-args)
     87            `(,_let ((,mtxvar ,?mtx))
     88               (,_let ((,?var (,_mutex-specific ,mtxvar)))
     89                 (,_dynamic-wind
     90                   (,_lambda () (,_mutex-lock! ,mtxvar ,@?lock-args))
     91                   (,_lambda () ,@?body)
     92                   (,_lambda () (,_mutex-unlock! ,mtxvar ,@?unlock-args)) ) ) ) ) ) ) ) ) )
    9693
    9794(define-syntax call/synch
    9895        (syntax-rules ()
     96                ((_ (?mtx (?lock-arg0 ...) (?unlock-arg0 ...)) ?proc ?arg0 ...)
     97                  (let ((mtx ?mtx))
     98                          (dynamic-wind
     99                                  (lambda () (mutex-lock! mtx ?lock-arg0 ...))
     100                                  (lambda () (?proc ?arg0 ...))
     101                                  (lambda () (mutex-unlock! mtx ?unlock-arg0 ...)) ) ) )
     102                ((_ (?mtx (?lock-arg0 ...)) ?proc ?arg0 ...)
     103                  (call/synch (?mtx (?lock-arg0 ...) ()) ?proc ?arg0 ...) )
    99104                ((_ ?mtx ?proc ?arg0 ...)
     105                  (call/synch (?mtx () ()) ?proc ?arg0 ...) ) ) )
     106
     107(define-syntax call-with/synch
     108        (syntax-rules ()
     109                ((_ (?mtx (?lock-arg0 ...) (?unlock-arg0 ...)) ?proc ?arg0 ...)
    100110                  (let ((mtx ?mtx))
    101111                          (dynamic-wind
    102                                   (lambda () (mutex-lock! mtx))
    103                                   (lambda () (?proc ?arg0 ...))
    104                                   (lambda () (mutex-unlock! mtx)) ) ) ) ) )
    105 
    106 (define-syntax call-with/synch
    107         (syntax-rules ()
     112                                  (lambda () (mutex-lock! mtx ?lock-arg0 ...))
     113                                  (lambda () (?proc (mutex-specific mtx) ?arg0 ...))
     114                                  (lambda () (mutex-unlock! mtx ?unlock-arg0 ...)) ) ) )
     115                ((_ (?mtx (?lock-arg0 ...)) ?proc ?arg0 ...)
     116                  (call-with/synch (?mtx (?lock-arg0 ...) ()) ?proc ?arg0 ...) )
    108117                ((_ ?mtx ?proc ?arg0 ...)
     118                  (call-with/synch (?mtx () ()) ?proc ?arg0 ...) ) ) )
     119
     120(define-syntax apply/synch
     121        (syntax-rules ()
     122          ((_ (?mtx (?lock-arg0 ...) (?unlock-arg0 ...)) ?proc ?arg0 ...)
    109123                  (let ((mtx ?mtx))
    110124                          (dynamic-wind
    111                                   (lambda () (mutex-lock! mtx))
    112                                   (lambda () (?proc (mutex-specific mtx) ?arg0 ...))
    113                                   (lambda () (mutex-unlock! mtx)) ) ) ) ) )
    114 
    115 (define-syntax apply/synch
    116         (syntax-rules ()
     125                                  (lambda () (mutex-lock! mtx ?lock-arg0 ...))
     126                                  (lambda () (apply ?proc ?arg0 ...))
     127                                  (lambda () (mutex-unlock! mtx ?unlock-arg0 ...)) ) ) )
     128          ((_ (?mtx (?lock-arg0 ...)) ?proc ?arg0 ...)
     129                  (apply/synch (?mtx (?lock-arg0 ...) ()) ?proc ?arg0 ...) )
    117130                ((_ ?mtx ?proc ?arg0 ...)
     131                  (apply/synch (?mtx () ()) ?proc ?arg0 ...) ) ) )
     132
     133(define-syntax apply-with/synch
     134        (syntax-rules ()
     135                ((_ (?mtx (?lock-arg0 ...) (?unlock-arg0 ...)) ?proc ?arg0 ...)
    118136                  (let ((mtx ?mtx))
    119137                          (dynamic-wind
    120                                   (lambda () (mutex-lock! mtx))
    121                                   (lambda () (apply ?proc ?arg0 ...))
    122                                   (lambda () (mutex-unlock! mtx)) ) ) ) ) )
    123 
    124 (define-syntax apply-with/synch
    125         (syntax-rules ()
     138                                  (lambda () (mutex-lock! mtx ?lock-arg0 ...))
     139                                  (lambda () (apply ?proc (mutex-specific mtx) ?arg0 ...))
     140                                  (lambda () (mutex-unlock! mtx ?unlock-arg0 ...)) ) ) )
     141                ((_ (?mtx (?lock-arg0 ...)) ?proc ?arg0 ...)
     142                  (apply-with/synch (?mtx (?lock-arg0 ...) ()) ?proc ?arg0 ...) )
    126143                ((_ ?mtx ?proc ?arg0 ...)
    127                   (let ((mtx ?mtx))
    128                           (dynamic-wind
    129                                   (lambda () (mutex-lock! mtx))
    130                                   (lambda () (apply ?proc (mutex-specific mtx) ?arg0 ...))
    131                                   (lambda () (mutex-unlock! mtx)) ) ) ) ) )
     144                  (apply-with/synch (?mtx () ()) ?proc ?arg0 ...) ) ) )
    132145
    133146(define-syntax let/synch
    134   (lambda (form r c)
    135     (##sys#check-syntax 'let/synch form '(_ list . _))
    136     (let (($synch-with (r 'synch-with)))
    137       (let ((?body (cddr form)))
    138         (car
    139           (let loop ((?bnds (cadr form)))
    140             (if (not (null? ?bnds))
    141                 (let ((bnd (car ?bnds)))
    142                   (##sys#check-syntax 'let/synch bnd '(variable _))
    143                   `((,$synch-with ,(cadr bnd) ,(car bnd) ,@(loop (cdr ?bnds)))) )
    144                 ?body ) ) ) ) ) ) )
     147  (lambda (frm rnm cmp)
     148    (##sys#check-syntax 'let/synch frm '(_ list . _))
     149    (let ((_synch-with (rnm 'synch-with)))
     150      (let* ((?body (cddr frm))
     151             (res (let loop ((bnds (cadr frm)))
     152                    (if (null? bnds) ?body
     153                        (let ((?bnd (car bnds)))
     154                          (##sys#check-syntax 'let/synch ?bnd '(variable . _))
     155                          `((,_synch-with ,(cadr ?bnd) ,(car ?bnd) ,@(loop (cdr bnds)))) ) ) ) ) )
     156        (car res) ) ) ) )
    145157
    146158(define-syntax set!/synch
    147   (lambda (form r c)
    148     (##sys#check-syntax 'set!/synch form '(_ pair . _))
    149     (let (($synch-with (r 'synch-with))
    150           ($mutex-specific (r 'mutex-specific))
    151           ($mutex-specific-set! (r 'mutex-specific-set!))
    152           ($begin (r 'begin)))
    153       (let ((?bnd (cadr form)) (?body (cddr form)))
     159  (lambda (frm rnm cmp)
     160    (##sys#check-syntax 'set!/synch frm '(_ pair . _))
     161    (let ((_synch-with (rnm 'synch-with))
     162          (_mutex-specific (rnm 'mutex-specific))
     163          (_mutex-specific-set! (rnm 'mutex-specific-set!))
     164          (_begin (rnm 'begin)))
     165      (let ((?bnd (cadr frm)) (?body (cddr frm)))
    154166        (let ((?var (car ?bnd)) (?mtx (cadr ?bnd)))
    155           `(,$synch-with ,?mtx ,?var
    156              (,$mutex-specific-set! ,?mtx (,$begin ,@?body))
    157              (,$mutex-specific ,?mtx) ) ) ) ) ) )
     167          `(,_synch-with ,?mtx ,?var
     168             (,_mutex-specific-set! ,?mtx (,_begin ,@?body))
     169             (,_mutex-specific ,?mtx) ) ) ) ) ) )
    158170
    159171(define-syntax synch/lock
    160172        (syntax-rules ()
    161                 ((_ ?mtx ?body ...)
     173                ((_ (?mtx (?lock-arg0 ...)) ?body ...)
    162174                  (let ((mtx ?mtx) (ok? #f))
    163175                                (mutex-lock! mtx)
    164176                                (dynamic-wind
    165                                   (lambda () (mutex-lock! mtx))
     177                                  (lambda () (mutex-lock! mtx ?lock-arg0 ...))
    166178                                        (lambda () (let ((res (begin ?body ...))) (set! ok? #t) res))
    167                                         (lambda () (unless ok? (mutex-unlock! mtx)))) ) ) ) )
     179                                        (lambda () (unless ok? (mutex-unlock! mtx)))) ) )
     180                ((_ ?mtx ?body ...)
     181                  (synch/lock (?mtx ()) ?body ...) ) ) )
    168182
    169183(define-syntax synch/unlock
    170184        (syntax-rules ()
    171                 ((_ ?mtx ?body ...)
     185                ((_ (?mtx (?unlock-arg0 ...)) ?body ...)
    172186                  (let ((mtx ?mtx))
    173187                          (dynamic-wind
     
    177191                                                  (mutex-lock! mtx)))
    178192                                  (lambda () ?body ...)
    179                                   (lambda () (mutex-unlock! mtx)) ) ) ) ) )
     193                                  (lambda () (mutex-unlock! mtx ?unlock-arg0 ...)) ) ) )
     194                ((_ ?mtx ?body ...)
     195                  (synch/unlock (?mtx ()) ?body ...) ) ) )
    180196
    181197(define-syntax object/synch
    182   (lambda (form r c)
    183     (##sys#check-syntax 'object/synch form '(_ _ . _))
    184     (let (($synch-with (r 'synch-with))
    185           ($>< (r '><))
    186           (var (r (gensym)))
    187           (mtx (cadr form)))
    188       (let body-loop ((unparsed (cddr form)) (parsed '()))
     198  (lambda (frm rnm cmp)
     199    (##sys#check-syntax 'object/synch frm '(_ _ . _))
     200    (let ((_synch-with (rnm 'synch-with))
     201          (_>< (rnm '><))
     202          (var (rnm (gensym)))
     203          (mtx (cadr frm)))
     204      (let body-loop ((unparsed (cddr frm)) (parsed '()))
    189205        (if (not (null? unparsed))
    190206            (let ((expr (car unparsed))
     
    196212                        (let ((arg (car rest))
    197213                              (next (cdr rest)))
    198                           (if (c $>< arg)
     214                          (if (cmp _>< arg)
    199215                              (expr-loop next (cons var parsedexpr))
    200216                              (expr-loop next (cons arg parsedexpr)) ) ))
    201                       ((c $>< rest)
     217                      ((cmp _>< rest)
    202218                        (body-loop next (cons var parsed)))
    203219                      (else
    204220                        (body-loop next (cons rest parsed))) ) ) )
    205             `(,$synch-with ,mtx ,var ,@(reverse parsed)) ) ) ) ) )
     221            `(,_synch-with ,mtx ,var ,@(reverse parsed)) ) ) ) ) )
    206222
    207223(define-syntax record/synch
    208   (lambda (form r c)
    209     (##sys#check-syntax 'record/synch form '(_ symbol _ . _))
    210     (let (($synch (r 'synch)))
    211       (let ((?sym (cadr form)) (?rec (caddr form)) (?body (cdddr form)))
    212         `(,$synch (,(recmuxnam ?sym) ,?rec) ,@?body) ) ) ) )
     224  (lambda (frm rnm cmp)
     225    (##sys#check-syntax 'record/synch frm '(_ symbol _ . _))
     226    (let ((_synch (rnm 'synch)))
     227      (let ((?sym (cadr frm)) (?rec (caddr frm)) (?body (cdddr frm)))
     228        `(,_synch (,(recmuxnam ?sym) ,?rec) ,@?body) ) ) ) )
    213229
    214230(define-syntax record-synch/lock
    215   (lambda (form r c)
    216     (##sys#check-syntax 'record-synch/lock form '(_ symbol _ . _))
    217     (let (($synch/lock (r 'synch/lock)))
    218       (let ((?sym (cadr form)) (?rec (caddr form)) (?body (cdddr form)))
    219         `(,$synch/lock (,(recmuxnam ?sym) ,?rec) ,@?body) ) ) ) )
     231  (lambda (frm rnm cmp)
     232    (##sys#check-syntax 'record-synch/lock frm '(_ symbol _ . _))
     233    (let ((_synch/lock (rnm 'synch/lock)))
     234      (let ((?sym (cadr frm)) (?rec (caddr frm)) (?body (cdddr frm)))
     235        `(,_synch/lock (,(recmuxnam ?sym) ,?rec) ,@?body) ) ) ) )
    220236
    221237(define-syntax record-synch/unlock
    222   (lambda (form r c)
    223     (##sys#check-syntax 'record-synch/unlock form '(_ symbol _ . _))
    224     (let (($synch/unlock (r 'synch/unlock)))
    225       (let ((?sym (cadr form)) (?rec (caddr form)) (?body (cdddr form)))
    226         `(,$synch/unlock (,(recmuxnam ?sym) ,?rec) ,@?body) ) ) ) )
     238  (lambda (frm rnm cmp)
     239    (##sys#check-syntax 'record-synch/unlock frm '(_ symbol _ . _))
     240    (let ((_synch/unlock (rnm 'synch/unlock)))
     241      (let ((?sym (cadr frm)) (?rec (caddr frm)) (?body (cdddr frm)))
     242        `(,_synch/unlock (,(recmuxnam ?sym) ,?rec) ,@?body) ) ) ) )
    227243
    228244;;; Unprotected
    229245
    230 (define-syntax %synch-mutex*
    231         (syntax-rules ()
    232                 ((_ ?mtx ?body ...)
    233                   (let ((mtx ?mtx))
    234         (mutex-lock! mtx)
     246(define-syntax %*synch
     247        (syntax-rules ()
     248                ((_ (?mtx (?lock-arg0 ...) (?unlock-arg0 ...)) ?body ...)
     249                  (let ((mtx ?mtx))
     250        (mutex-lock! mtx ?lock-arg0 ...)
    235251                                (call-with-values
    236252                                        (lambda () ?body ...)
    237253                                        (lambda ret
    238                                                 (mutex-unlock! mtx)
    239                                                 (apply values ret))) ) ) ) )
    240 
    241 (define-syntax %synch-mutex-with*
    242   (lambda (form r c)
    243     (##sys#check-syntax '%synch-mutex-with* form '(_ _ variable . _))
    244     (let (($call-with-values (r 'call-with-values))
    245           ($mutex-specific (r 'mutex-specific))
    246           ($mutex-lock! (r 'mutex-lock!))
    247           ($mutex-unlock! (r 'mutex-unlock!))
    248           ($let (r 'let))
    249           ($apply (r 'apply))
    250           ($values (r 'values))
    251           ($lambda (r 'lambda))
    252           ($ret (r 'ret))
    253           (mtxvar (r (gensym))))
    254       (let ((?mtx (cadr form)) (?var (caddr form)) (?body (cdddr form)))
    255         `(,$let ((,mtxvar ,?mtx))
    256            (,$let ((,?var (,$mutex-specific ,mtxvar)))
    257              (,$mutex-lock! ,mtxvar)
    258              (,$call-with-values
    259                (,$lambda () ,@?body)
    260                (,$lambda ,$ret
    261                  (,$mutex-unlock! ,mtxvar)
    262                  (,$apply ,$values ,$ret)) ) ) ) ) ) ) )
     254                                                (mutex-unlock! mtx ?unlock-arg0 ...)
     255                                                (apply values ret))) ) )
     256                ((_ ?mtx ?body ...)
     257                  (%*synch (?mtx () ()) ?body ...) ) ) )
     258
     259(define-syntax %*synch-with
     260  (lambda (frm rnm cmp)
     261    (##sys#check-syntax '%*synch-with frm '(_ _ variable . _))
     262    (let ((_call-with-values (rnm 'call-with-values))
     263          (_mutex-specific (rnm 'mutex-specific))
     264          (_mutex-lock! (rnm 'mutex-lock!))
     265          (_mutex-unlock! (rnm 'mutex-unlock!))
     266          (_let (rnm 'let))
     267          (_apply (rnm 'apply))
     268          (_values (rnm 'values))
     269          (_lambda (rnm 'lambda))
     270          (_ret (rnm 'ret))
     271          (mtxvar (rnm (gensym))))
     272      (let ((?mtx (cadr frm)) (?var (caddr frm)) (?body (cdddr frm)))
     273        (call-with-values
     274          (lambda ()
     275            (if (not (pair? ?mtx)) (values ?mtx '() '())
     276                (let ((mtx (car ?mtx))
     277                      (lock-args (if (<= 2 (length ?mtx)) (cadr ?mtx) '()))
     278                      (unlock-args (if (= 3 (length ?mtx)) (caddr ?mtx) '())) )
     279                  (values mtx lock-args unlock-args) ) ) )
     280          (lambda (?mtx ?lock-args ?unlock-args)
     281            `(,_let ((,mtxvar ,?mtx))
     282               (,_let ((,?var (,_mutex-specific ,mtxvar)))
     283                 (,_mutex-lock! ,mtxvar ,@?lock-args)
     284                 (,_call-with-values
     285                   (,_lambda () ,@?body)
     286                   (,_lambda ,_ret
     287                     (,_mutex-unlock! ,mtxvar ,@?unlock-args)
     288                     (,_apply ,_values ,_ret)) ) ) ) ) ) ) ) ) )
    263289
    264290(define-syntax %synch
    265291        (syntax-rules ()
    266                 ((_ ?mtx ?body ...) (%synch-mutex* ?mtx ?body ...) ) ) )
     292                ((_ ?mtx ?body ...) (%*synch ?mtx ?body ...) ) ) )
    267293
    268294(define-syntax %synch-with
    269295        (syntax-rules ()
    270                 ((_ ?mtx ?var ?body ...) (%synch-mutex-with* ?mtx ?var ?body ...) ) ) )
     296                ((_ ?mtx ?var ?body ...) (%*synch-with ?mtx ?var ?body ...) ) ) )
    271297
    272298(define-syntax %call/synch
    273299        (syntax-rules ()
    274                 ((_ ?mtx ?proc ?arg0 ...) (%synch-mutex* ?mtx (?proc ?arg0 ...)) ) ) )
     300                ((_ ?mtx ?proc ?arg0 ...) (%*synch ?mtx (?proc ?arg0 ...)) ) ) )
    275301
    276302(define-syntax %call-with/synch
    277303        (syntax-rules ()
    278                 ((_ ?mtx ?proc ?arg0 ...) (%synch-mutex-with* ?mtx var (?proc var ?arg0 ...)) ) ) )
     304                ((_ ?mtx ?proc ?arg0 ...) (%*synch-with ?mtx var (?proc var ?arg0 ...)) ) ) )
    279305
    280306(define-syntax %apply/synch
    281307        (syntax-rules ()
    282                 ((_ ?mtx ?proc ?arg0 ...) (%synch-mutex* ?mtx (apply ?proc ?arg0 ...)) ) ) )
     308                ((_ ?mtx ?proc ?arg0 ...) (%*synch ?mtx (apply ?proc ?arg0 ...)) ) ) )
    283309
    284310(define-syntax %apply-with/synch
    285311        (syntax-rules ()
    286                 ((_ ?mtx ?proc ?arg0 ...) (%synch-mutex-with* ?mtx var (apply ?proc var ?arg0 ...)) ) ) )
     312                ((_ ?mtx ?proc ?arg0 ...) (%*synch-with ?mtx var (apply ?proc var ?arg0 ...)) ) ) )
    287313
    288314(define-syntax %let/synch
    289   (lambda (form r c)
    290     (##sys#check-syntax '%let/synch form '(_ list . _))
    291     (let (($%synch-with (r '%synch-with)))
    292       (let ((?body (cddr form)))
     315  (lambda (frm rnm cmp)
     316    (##sys#check-syntax '%let/synch frm '(_ list . _))
     317    (let ((_%synch-with (rnm '%synch-with)))
     318      (let ((?body (cddr frm)))
    293319        (car
    294           (let loop ((?bnds (cadr form)))
     320          (let loop ((?bnds (cadr frm)))
    295321            (if (not (null? ?bnds))
    296322                (let ((bnd (car ?bnds)))
    297323                  (##sys#check-syntax '%let/synch bnd '(variable _))
    298                   `((,$%synch-with ,(cadr bnd) ,(car bnd) ,@(loop (cdr ?bnds)))) )
     324                  `((,_%synch-with ,(cadr bnd) ,(car bnd) ,@(loop (cdr ?bnds)))) )
    299325                ?body ) ) ) ) ) ) )
    300326
    301327(define-syntax %set!/synch
    302   (lambda (form r c)
    303     (##sys#check-syntax '%set!/synch form '(_ pair . _))
    304     (let (($%synch-with (r '%synch-with))
    305           ($mutex-specific (r 'mutex-specific))
    306           ($mutex-specific-set! (r 'mutex-specific-set!))
    307           ($let (r 'let))
    308           ($begin (r 'begin))
    309           (mtxvar (r (gensym))))
    310       (let ((?bnd (cadr form)) (?body (cddr form)))
     328  (lambda (frm rnm cmp)
     329    (##sys#check-syntax '%set!/synch frm '(_ pair . _))
     330    (let ((_%synch-with (rnm '%synch-with))
     331          (_mutex-specific (rnm 'mutex-specific))
     332          (_mutex-specific-set! (rnm 'mutex-specific-set!))
     333          (_let (rnm 'let))
     334          (_begin (rnm 'begin))
     335          (mtxvar (rnm (gensym))))
     336      (let ((?bnd (cadr frm)) (?body (cddr frm)))
    311337        (let ((?var (car ?bnd)) (?mtx (cadr ?bnd)))
    312           `(,$let ((,mtxvar ,?mtx))
    313              (,$%synch-with ,mtxvar ,?var
    314                (,$mutex-specific-set! ,mtxvar (,$begin ,@?body))
    315                (,$mutex-specific ,mtxvar) ) ) ) ) ) ) )
     338          `(,_let ((,mtxvar ,?mtx))
     339             (,_%synch-with ,mtxvar ,?var
     340               (,_mutex-specific-set! ,mtxvar (,_begin ,@?body))
     341               (,_mutex-specific ,mtxvar) ) ) ) ) ) ) )
    316342
    317343(define-syntax %synch/lock
    318344        (syntax-rules ()
    319                 ((_ ?mtx ?body ...)
     345                ((_ (?mtx (?lock-arg0 ...)) ?body ...)
    320346                  (let ((mtx ?mtx) (ok? #f))
    321                                 (mutex-lock! mtx)
     347                                (mutex-lock! mtx ?lock-arg0 ...)
    322348                                (call-with-values
    323349                                        (lambda () (let ((res (begin ?body ...))) (set! ok? #t) res))
    324350                                        (lambda ret
    325351                                                (unless ok? (mutex-unlock! mtx))
    326                                                 (apply values ret))) ) ) ) )
     352                                                (apply values ret))) ) )
     353                ((_ ?mtx ?body ...)
     354                  (%synch/lock (?mtx ()) ?body ...) ) ) )
    327355
    328356(define-syntax %synch/unlock
    329357        (syntax-rules ()
    330                 ((_ ?mtx ?body ...)
     358                ((_ (?mtx (?unlock-arg0 ...)) ?body ...)
    331359      (let ((mtx ?mtx))
    332360        (unless (thread? (mutex-state mtx))
     
    336364          (lambda () ?body ...)
    337365          (lambda ret
    338             (mutex-unlock! mtx)
    339             (apply values ret)) ) ) ) ) )
     366            (mutex-unlock! mtx ?unlock-arg0 ...)
     367            (apply values ret)) ) ) )
     368                ((_ ?mtx ?body ...)
     369      (%synch/unlock (?mtx ()) ?body ...) ) ) )
    340370
    341371(define-syntax %object/synch
    342   (lambda (form r c)
    343     (##sys#check-syntax '%object/synch form '(_ _ . _))
    344     (let (($%synch-with (r '%synch-with))
    345           ($>< (r '><))
    346           (var (r (gensym)))
    347           (mtx (cadr form)))
    348       (let body-loop ((unparsed (cddr form)) (parsed '()))
     372  (lambda (frm rnm cmp)
     373    (##sys#check-syntax '%object/synch frm '(_ _ . _))
     374    (let ((_%synch-with (rnm '%synch-with))
     375          (_>< (rnm '><))
     376          (var (rnm (gensym)))
     377          (mtx (cadr frm)))
     378      (let body-loop ((unparsed (cddr frm)) (parsed '()))
    349379        (if (not (null? unparsed))
    350380            (let ((expr (car unparsed))
     
    356386                        (let ((arg (car rest))
    357387                              (next (cdr rest)))
    358                           (if (c $>< arg)
     388                          (if (cmp _>< arg)
    359389                              (expr-loop next (cons var parsedexpr))
    360390                              (expr-loop next (cons arg parsedexpr)) ) ))
    361                       ((c $>< rest)
     391                      ((cmp _>< rest)
    362392                        (body-loop next (cons var parsed)))
    363393                      (else
    364394                        (body-loop next (cons rest parsed))) ) ) )
    365             `(,$%synch-with ,mtx ,var ,@(reverse parsed)) ) ) ) ) )
     395            `(,_%synch-with ,mtx ,var ,@(reverse parsed)) ) ) ) ) )
    366396
    367397(define-syntax %record/synch
    368   (lambda (form r c)
    369     (##sys#check-syntax '%record/synch form '(_ symbol _ . _))
    370     (let (($%synch (r '%synch)))
    371       (let ((?sym (cadr form)) (?rec (caddr form)) (?body (cdddr form)))
    372         `(,$%synch (,(recmuxnam ?sym) ,?rec) ?body ...) ) ) ) )
     398  (lambda (frm rnm cmp)
     399    (##sys#check-syntax '%record/synch frm '(_ symbol _ . _))
     400    (let ((_%synch (rnm '%synch)))
     401      (let ((?sym (cadr frm)) (?rec (caddr frm)) (?body (cdddr frm)))
     402        `(,_%synch (,(recmuxnam ?sym) ,?rec) ?body ...) ) ) ) )
    373403
    374404(define-syntax %record-synch/lock
    375   (lambda (form r c)
    376     (##sys#check-syntax '%record-synch/lock form '(_ symbol _ . _))
    377     (let (($%synch/lock (r '%synch/lock)))
    378       (let ((?sym (cadr form)) (?rec (caddr form)) (?body (cdddr form)))
    379         `(,$%synch/lock (,(recmuxnam ?sym) ,?rec) ,@?body) ) ) ) )
     405  (lambda (frm rnm cmp)
     406    (##sys#check-syntax '%record-synch/lock frm '(_ symbol _ . _))
     407    (let ((_%synch/lock (rnm '%synch/lock)))
     408      (let ((?sym (cadr frm)) (?rec (caddr frm)) (?body (cdddr frm)))
     409        `(,_%synch/lock (,(recmuxnam ?sym) ,?rec) ,@?body) ) ) ) )
    380410
    381411(define-syntax %record-synch/unlock
    382   (lambda (form r c)
    383     (##sys#check-syntax '%record-synch/unlock form '(_ symbol _ . _))
    384     (let (($%synch/unlock (r '%synch/unlock)))
    385       (let ((?sym (cadr form)) (?rec (caddr form)) (?body (cdddr form)))
    386         `(,$%synch/unlock (,(recmuxnam ?sym) ,?rec) ,@?body) ) ) ) )
     412  (lambda (frm rnm cmp)
     413    (##sys#check-syntax '%record-synch/unlock frm '(_ symbol _ . _))
     414    (let ((_%synch/unlock (rnm '%synch/unlock)))
     415      (let ((?sym (cadr frm)) (?rec (caddr frm)) (?body (cdddr frm)))
     416        `(,_%synch/unlock (,(recmuxnam ?sym) ,?rec) ,@?body) ) ) ) )
    387417
    388418) ;module synch
  • release/4/synch/trunk/synch.setup

    r15954 r16025  
    55(verify-extension-name 'synch)
    66
    7 (setup-shared-extension-module (extension-name) (extension-version "2.0.0")
     7(setup-shared-extension-module 'synch (extension-version "2.0.0"))
     8
     9(setup-shared-extension-module 'synch-object (extension-version "2.0.0")
    810  #:compile-options '(-fixnum-arithmetic
    911                      -optimize-level 3
  • release/4/synch/trunk/tests/run.scm

    r15954 r16025  
    1 (use srfi-18 synch)
     1(use srfi-18 srfi-69 synch synch-object miscmacros)
    22
    33(define-record-type foo
     
    99 
    1010(define tfoo (make-foo 1 2 (make-mutex)))
     11(print "*** prints 1 2 ***")
    1112(record/synch foo tfoo (print (foo-x tfoo) " " (foo-y tfoo)))
     13(newline)
     14
     15;;
     16
     17(define (hash-table-count ht)
     18  (##sys#check-structure ht 'hash-table 'hash-table-count)
     19  (hash-table-fold ht (lambda (k v a) (fx+ a 1)) 0) )
     20
     21;;;
     22
     23(define-constructor/synch make-hash-table hash-table/synch:)
     24(define-predicate/synch hash-table?)
     25(define-operation/synch hash-table-count)
     26(define-operation/synch hash-table-set!)
     27
     28;;
     29
     30(define +tht+ (make-hash-table/synch = number-hash))
     31
     32;; Greedy reader
     33
     34(define (reader)
     35  (do ((n (hash-table-count/synch +tht+) (hash-table-count/synch +tht+)))
     36      ((fx= 20 n) (print "test hash-table count = " n " so quit"))
     37    (print "test hash-table count = " n) ) )
     38(define reader-thread (make-thread reader 'reader))
     39(thread-start! reader-thread)
     40
     41;; Cooperative writer
     42
     43(define (writer)
     44  (repeat* 10
     45    (hash-table-set!/synch +tht+ it (number->string it))
     46    (hash-table-set!/synch +tht+ (* it 11) (number->string it))
     47    (thread-yield!) ) )
     48(define writer-thread (make-thread writer 'writer))
     49(thread-start! writer-thread)
     50
     51;;
     52
     53(thread-join! writer-thread)
     54(thread-join! reader-thread)
Note: See TracChangeset for help on using the changeset viewer.