Changeset 37027 in project


Ignore:
Timestamp:
12/24/18 23:17:14 (3 months ago)
Author:
kon
Message:

fix per jw

Location:
release/4/synch/trunk
Files:
3 edited

Legend:

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

    r35332 r37027  
    5050  ;
    5151  synchronized-procedure
     52#|
    5253  ;;
    5354  ;DEPRECATED
     
    8182  define-predicate/synch
    8283  (define-operation/synch check-synch-with-object)
    83   define-operation/%synch)
     84  define-operation/%synch
     85|#
     86  )
    8487
    8588(import
     
    8992    declare
    9093    define-for-syntax optional
    91     void unless warning gensym) )
     94    void unless warning gensym
     95    when) )
    9296(use
    9397  (only srfi-18
     
    103107;;;
    104108
    105 (define-for-syntax (record-mutex-name nam)
    106   (string->symbol (string-append (symbol->string nam) "-" "mutex")) )
     109;;
     110
     111(define-for-syntax (suffix-symbol sym suf)
     112  (string->symbol (string-append (symbol->string sym) "-" suf)) )
    107113
    108114;;; Protected
     
    111117
    112118(define-syntax synch
    113         (syntax-rules ()
    114     ;
    115                 ((_ (?mtx (?lock-arg0 ...) (?unlock-arg0 ...)) ?body ...)
    116         (let ((mtx ?mtx))
    117         (dynamic-wind
    118           (lambda () (mutex-lock! mtx ?lock-arg0 ...))
    119           (lambda () ?body ...)
    120           (lambda () (mutex-unlock! mtx ?unlock-arg0 ...)) ) ) )
    121     ;
    122                 ((_ (?mtx (?lock-arg0 ...)) ?body ...)
    123         (synch (?mtx (?lock-arg0 ...) ()) ?body ...) )
    124     ;
    125                 ((_ ?mtx ?body ...)
    126         (synch (?mtx () ()) ?body ...) ) ) )
     119  (syntax-rules ()
     120    ;
     121    ((synch (?mtx (?lock-arg0 ...) (?unlock-arg0 ...)) ?body ...)
     122      ;eval args ahead of time
     123      (let (
     124        (mtx ?mtx)
     125        (lock-args (list ?lock-arg0 ...))
     126        (unlock-args (list ?unlock-arg0 ...)) )
     127        ;do not continue when cannot get a lock
     128        (when (apply mutex-lock! mtx lock-args)
     129          (dynamic-wind
     130            void
     131            (lambda () ?body ...)
     132            (lambda () (apply mutex-unlock! mtx unlock-args))) ) ) )
     133    ;
     134    ((synch (?mtx (?lock-arg0 ...)) ?body ...)
     135      (synch (?mtx (?lock-arg0 ...) ()) ?body ...) )
     136    ;
     137    ((synch (?mtx) ?body ...)
     138      (synch (?mtx () ()) ?body ...) )
     139    ;
     140    ((synch ?mtx ?body ...)
     141      (synch (?mtx) ?body ...) ) ) )
    127142
    128143;;
     
    131146  (er-macro-transformer
    132147    (lambda (frm rnm cmp)
    133       ;
    134148      (##sys#check-syntax 'synch-with frm '(_ _ variable . #(_ 0)))
    135       ;
    136       (let (
    137         (_dynamic-wind (rnm 'dynamic-wind) )
    138         (_let (rnm 'let) )
    139         (_lambda (rnm 'lambda) )
    140         (_mutex-unlock! (rnm 'mutex-unlock!) )
    141         (_mutex-specific (rnm 'mutex-specific) )
    142         (_mutex-lock! (rnm 'mutex-lock!) )
    143         (mtxvar (rnm (gensym)) ) )
    144         ;
    145         (let (
    146           (?mtx (cadr frm) )
    147           (?var (caddr frm) )
    148           (?body (cdddr frm) ) )
    149           ;
     149      (let (
     150        (_let (rnm 'let))
     151        (_mutex-specific (rnm 'mutex-specific))
     152        (_synch (rnm 'synch))
     153        (_mtx (rnm (gensym 'mtx)))
     154        (_current-synch-abandon? (rnm 'current-synch-abandon?)) )
     155        (let (
     156          (?mtx (cadr frm))
     157          (?var (caddr frm))
     158          (?body (cdddr frm)) )
    150159          (call-with-values
    151160            (lambda ()
    152161              (if (not (pair? ?mtx))
    153162                (values ?mtx '() '())
    154                 (let ((mtx (car ?mtx))
    155                       (lock-args (if (<= 2 (length ?mtx)) (cadr ?mtx) '()))
    156                       (unlock-args (if (= 3 (length ?mtx)) (caddr ?mtx) '())) )
     163                (let (
     164                  (mtx (car ?mtx))
     165                  (lock-args (if (<= 2 (length ?mtx)) (cadr ?mtx) '()))
     166                  (unlock-args (if (= 3 (length ?mtx)) (caddr ?mtx) '())) )
    157167                  (values mtx lock-args unlock-args) ) ) )
    158168            (lambda (?mtx ?lock-args ?unlock-args)
    159               `(,_let ((,mtxvar ,?mtx))
    160                  (,_let ((,?var (,_mutex-specific ,mtxvar)))
    161                    (,_dynamic-wind
    162                      (,_lambda () (,_mutex-lock! ,mtxvar ,@?lock-args))
    163                      (,_lambda () ,@?body)
    164                      (,_lambda () (,_mutex-unlock! ,mtxvar ,@?unlock-args)) ) ) ) ) ) ) ) ) ) )
    165 
    166 (define-for-syntax call-synch-transformer
    167         (syntax-rules ()
    168     ;
    169                 ((_ (?mtx (?lock-arg0 ...) (?unlock-arg0 ...)) ?proc ?arg0 ...)
    170                   (let ((mtx ?mtx))
    171                           (dynamic-wind
    172                                   (lambda () (mutex-lock! mtx ?lock-arg0 ...))
    173                                   (lambda () (?proc ?arg0 ...))
    174                                   (lambda () (mutex-unlock! mtx ?unlock-arg0 ...)) ) ) )
    175     ;
    176                 ((_ (?mtx (?lock-arg0 ...)) ?proc ?arg0 ...)
    177                   (call-synch (?mtx (?lock-arg0 ...) ()) ?proc ?arg0 ...) )
    178     ;
    179                 ((_ ?mtx ?proc ?arg0 ...)
    180                   (call-synch (?mtx () ()) ?proc ?arg0 ...) ) ) )
    181 
    182 (define-syntax call-synch call-synch-transformer)
    183 
    184 (define-for-syntax call-synch-with-transformer
    185         (syntax-rules ()
    186     ;
    187                 ((_ (?mtx (?lock-arg0 ...) (?unlock-arg0 ...)) ?proc ?arg0 ...)
    188                   (let ((mtx ?mtx))
    189                           (dynamic-wind
    190                                   (lambda () (mutex-lock! mtx ?lock-arg0 ...))
    191                                   (lambda () (?proc (mutex-specific mtx) ?arg0 ...))
    192                                   (lambda () (mutex-unlock! mtx ?unlock-arg0 ...)) ) ) )
    193     ;
    194                 ((_ (?mtx (?lock-arg0 ...)) ?proc ?arg0 ...)
    195                   (call-synch-with (?mtx (?lock-arg0 ...) ()) ?proc ?arg0 ...) )
    196     ;
    197                 ((_ ?mtx ?proc ?arg0 ...)
    198                   (call-synch-with (?mtx () ()) ?proc ?arg0 ...) ) ) )
    199 
    200 (define-syntax call-synch-with call-synch-with-transformer)
    201 
    202 (define-for-syntax apply-synch-transformer
    203         (syntax-rules ()
    204           ((_ (?mtx (?lock-arg0 ...) (?unlock-arg0 ...)) ?proc ?arg0 ...)
    205                   (let ((mtx ?mtx))
    206                           (dynamic-wind
    207                                   (lambda () (mutex-lock! mtx ?lock-arg0 ...))
    208                                   (lambda () (apply ?proc ?arg0 ...))
    209                                   (lambda () (mutex-unlock! mtx ?unlock-arg0 ...)) ) ) )
    210           ((_ (?mtx (?lock-arg0 ...)) ?proc ?arg0 ...)
    211                   (apply-synch (?mtx (?lock-arg0 ...) ()) ?proc ?arg0 ...) )
    212     ;
    213                 ((_ ?mtx ?proc ?arg0 ...)
    214                   (apply-synch (?mtx () ()) ?proc ?arg0 ...) ) ) )
    215 
    216 (define-syntax apply-synch apply-synch-transformer)
    217 
    218 (define-for-syntax apply-synch-with-transformer
    219         (syntax-rules ()
    220     ;
    221                 ((_ (?mtx (?lock-arg0 ...) (?unlock-arg0 ...)) ?proc ?arg0 ...)
    222                   (let ((mtx ?mtx))
    223                           (dynamic-wind
    224                                   (lambda () (mutex-lock! mtx ?lock-arg0 ...))
    225                                   (lambda () (apply ?proc (mutex-specific mtx) ?arg0 ...))
    226                                   (lambda () (mutex-unlock! mtx ?unlock-arg0 ...)) ) ) )
    227     ;
    228                 ((_ (?mtx (?lock-arg0 ...)) ?proc ?arg0 ...)
    229                   (apply-synch-with (?mtx (?lock-arg0 ...) ()) ?proc ?arg0 ...) )
    230     ;
    231                 ((_ ?mtx ?proc ?arg0 ...)
    232                   (apply-synch-with (?mtx () ()) ?proc ?arg0 ...) ) ) )
    233 
    234 (define-syntax apply-synch-with apply-synch-with-transformer)
    235 
    236 (define-for-syntax let-synch-with-transformer
    237   (er-macro-transformer
    238     (lambda (frm rnm cmp)
    239       ;
     169              `(,_let ((,_mtx ,?mtx))
     170                (,_let ((,?var (,_mutex-specific ,_mtx)))
     171                  (,_synch (,_mtx ,?lock-args ,?unlock-args) ,@?body) ) ) ) ) ) ) ) ) )
     172
     173(define-syntax call-synch
     174  (syntax-rules ()
     175    ;
     176    ((call-synch (?mtx (?lock-arg0 ...) (?unlock-arg0 ...)) ?proc ?arg0 ...)
     177      (synch (mtx (?lock-arg0 ...) (?unlock-arg0 ...)) (?proc ?arg0 ...)) )
     178    ;
     179    ((call-synch (?mtx (?lock-arg0 ...)) ?proc ?arg0 ...)
     180      (call-synch (?mtx (?lock-arg0 ...) ()) ?proc ?arg0 ...) )
     181    ;
     182    ((call-synch ?mtx ?proc ?arg0 ...)
     183      (call-synch (?mtx () ()) ?proc ?arg0 ...) ) ) )
     184
     185(define-syntax call-synch-with
     186  (syntax-rules ()
     187    ;
     188    ((call-synch-with (?mtx (?lock-arg0 ...) (?unlock-arg0 ...)) ?proc ?arg0 ...)
     189      (synch (mtx (?lock-arg0 ...) (?unlock-arg0 ...)) (?proc (mutex-specific mtx) ?arg0 ...)) )
     190    ;
     191    ((call-synch-with (?mtx (?lock-arg0 ...)) ?proc ?arg0 ...)
     192      (call-synch-with (?mtx (?lock-arg0 ...) ()) ?proc ?arg0 ...) )
     193    ;
     194    ((call-synch-with ?mtx ?proc ?arg0 ...)
     195      (call-synch-with (?mtx () ()) ?proc ?arg0 ...) ) ) )
     196
     197(define-syntax apply-synch
     198  (syntax-rules ()
     199    ;
     200    ((apply-synch (?mtx (?lock-arg0 ...) (?unlock-arg0 ...)) ?proc ?arg0 ...)
     201      (synch (mtx (?lock-arg0 ...) (?unlock-arg0 ...)) (apply ?proc ?arg0 ...)) )
     202    ;
     203    ((apply-synch (?mtx (?lock-arg0 ...)) ?proc ?arg0 ...)
     204      (apply-synch (?mtx (?lock-arg0 ...) ()) ?proc ?arg0 ...) )
     205    ;
     206    ((apply-synch ?mtx ?proc ?arg0 ...)
     207      (apply-synch (?mtx () ()) ?proc ?arg0 ...) ) ) )
     208
     209(define-syntax apply-synch-with
     210  (syntax-rules ()
     211    ;
     212    ((apply-synch-with (?mtx (?lock-arg0 ...) (?unlock-arg0 ...)) ?proc ?arg0 ...)
     213      (synch (mtx (?lock-arg0 ...) (?unlock-arg0 ...)) (apply ?proc (mutex-specific mtx) ?arg0 ...)) )
     214    ;
     215    ((apply-synch-with (?mtx (?lock-arg0 ...)) ?proc ?arg0 ...)
     216      (apply-synch-with (?mtx (?lock-arg0 ...) ()) ?proc ?arg0 ...) )
     217    ;
     218    ((apply-synch-with ?mtx ?proc ?arg0 ...)
     219      (apply-synch-with (?mtx () ()) ?proc ?arg0 ...) ) ) )
     220
     221(define-syntax let-synch-with
     222  (er-macro-transformer
     223    (lambda (frm rnm cmp)
    240224      (##sys#check-syntax 'let-synch-with frm '(_ list . _))
    241       ;
    242       (let ((_synch-with (rnm 'synch-with)))
     225      (let (
     226        (_synch-with (rnm 'synch-with)) )
    243227        (let* (
    244228          (?body
     
    247231            (let loop ((bnds (cadr frm)))
    248232              (if (null? bnds)
    249                 ?body
     233                (begin ?body)
    250234                (let ((?bnd (car bnds)))
    251235                  (##sys#check-syntax 'let-synch-with ?bnd '(variable . _))
    252236                  `((,_synch-with ,(cadr ?bnd) ,(car ?bnd) ,@(loop (cdr bnds)))) ) ) ) ) )
    253           ;
    254237          (car res) ) ) ) ) )
    255238
    256 (define-syntax let-synch-with let-synch-with-transformer)
    257 
    258239(define-syntax set!-synch-with
    259240  (er-macro-transformer
    260241    (lambda (frm rnm cmp)
    261       ;
    262242      (##sys#check-syntax 'set!-synch-with frm '(_ _ variable . #(_ 0)))
    263       ;
    264243      (let (
    265244        (_synch-with (rnm 'synch-with) )
     
    267246        (_mutex-specific-set! (rnm 'mutex-specific-set!) )
    268247        (_begin (rnm 'begin) ) )
    269         ;
    270248        (let (
    271249          (?mtx (cadr frm) )
    272250          (?var (caddr frm) )
    273251          (?body (cdddr frm) ) )
    274           ;
    275252          `(,_synch-with ,?mtx ,?var
    276253             (,_mutex-specific-set! ,?mtx (,_begin ,@?body))
     
    279256;;
    280257
    281 (define-for-syntax synch-lock-transformer
    282         (syntax-rules ()
    283     ;
    284                 ((_ (?mtx (?lock-arg0 ...)) ?body ...)
    285                   (let ((mtx ?mtx) (ok? #f))
    286                                 (mutex-lock! mtx)
    287                                 (dynamic-wind
    288                                   (lambda () (mutex-lock! mtx ?lock-arg0 ...))
    289                                         (lambda () (let ((res (begin ?body ...))) (set! ok? #t) res))
    290                                         (lambda () (unless ok? (mutex-unlock! mtx)))) ) )
    291     ;
    292                 ((_ ?mtx ?body ...)
    293                   (synch-lock (?mtx ()) ?body ...) ) ) )
    294 
    295 (define-syntax synch-lock synch-lock-transformer)
    296 
    297 (define-for-syntax synch-unlock-transformer
    298         (syntax-rules ()
    299     ;
    300                 ((_ (?mtx (?unlock-arg0 ...)) ?body ...)
    301                   (let ((mtx ?mtx))
    302                           (dynamic-wind
    303                                   (lambda ()
    304                                           (unless (thread? (mutex-state mtx))
    305                                                   (warning 'synch-unlock "mutex is not locked - locking")
    306                                                   (mutex-lock! mtx)))
    307                                   (lambda () ?body ...)
    308                                   (lambda () (mutex-unlock! mtx ?unlock-arg0 ...)) ) ) )
    309     ;
    310                 ((_ ?mtx ?body ...)
    311                   (synch-unlock (?mtx ()) ?body ...) ) ) )
    312 
    313 (define-syntax synch-unlock synch-unlock-transformer)
    314 
    315 ;;
    316 
    317 (define-for-syntax object-synch-cut-with-transformer
    318   (er-macro-transformer
    319     (lambda (frm rnm cmp)
    320       ;
     258(define-syntax synch-lock
     259  (syntax-rules ()
     260    ;
     261    ((synch-lock (?mtx (?lock-arg0 ...)) ?body ...)
     262      (let ((mtx ?mtx))
     263        (let ((ok? #f))
     264          (when (mutex-lock! mtx ?lock-arg0 ...)
     265            (dynamic-wind
     266              void
     267              (lambda ()
     268                (let ((res (begin ?body ...)))
     269                  (set! ok? #t)
     270                  res))
     271              (lambda ()
     272                (unless ok?
     273                  (mutex-unlock! mtx)))) ) ) ) )
     274    ;
     275    ((synch-lock ?mtx ?body ...)
     276      (synch-lock (?mtx ()) ?body ...) ) ) )
     277
     278(define-syntax synch-unlock
     279  (syntax-rules ()
     280    ;
     281    ((synch-unlock (?mtx (?unlock-arg0 ...)) ?body ...)
     282      (let ((mtx ?mtx))
     283        (let ((st (mutex-state mtx)))
     284          (if (or (eq 'abandoned st) (eq 'not-abandoned st))
     285            (error 'synch-unlock "mutex unlocked" mtx)
     286            (dynamic-wind
     287              void
     288              (lambda () ?body ...)
     289              (lambda () (mutex-unlock! mtx ?unlock-arg0 ...)) ) ) ) ) )
     290    ;
     291    ((synch-unlock ?mtx ?body ...)
     292      (synch-unlock (?mtx ()) ?body ...) ) ) )
     293
     294;;
     295
     296(define-syntax object-synch-cut-with
     297  (er-macro-transformer
     298    (lambda (frm rnm cmp)
    321299      (##sys#check-syntax 'object-synch-cut-with frm '(_ _ . _))
    322       ;
    323300      (let (
    324301        (_synch-with (rnm 'synch-with))
     
    326303        (var (rnm (gensym)))
    327304        (mtx (cadr frm)) )
    328         ;
    329305        (let body-loop ((unparsed (cddr frm)) (parsed '()))
    330306          (if (null? unparsed)
    331             ;
     307            ;code walked
    332308            `(,_synch-with ,mtx ,var ,@(reverse parsed))
    333             ;
     309            ;walk code
    334310            (let (
    335311              (expr (car unparsed))
    336312              (next (cdr unparsed)) )
    337               ;
    338313              (let expr-loop ((rest expr) (parsed-expr '()))
    339314                (cond
    340                   ;
    341315                  ((null? rest)
    342316                    (body-loop next (cons (reverse parsed-expr) parsed)))
    343                   ;
    344317                  ((pair? rest)
    345318                    (let (
    346319                      (arg (car rest))
    347320                      (next (cdr rest)) )
    348                       ;
    349321                      (if (cmp _>< arg)
    350322                        (expr-loop next (cons var parsed-expr))
    351323                        (expr-loop next (cons arg parsed-expr)) ) ))
    352                   ;
    353324                  ((cmp _>< rest)
    354325                    (body-loop next (cons var parsed)))
    355                   ;
    356326                  (else
    357327                    (body-loop next (cons rest parsed))) ) ) ) ) ) ) ) ) )
    358328
    359 (define-syntax object-synch-cut-with object-synch-cut-with-transformer)
     329;;
     330
     331(define-for-syntax (record-mutex-name sym) (suffix-symbol sym "mutex"))
    360332
    361333;;
     
    408380;;; Unprotected
    409381
    410 (define-syntax %*synch
    411         (syntax-rules ()
    412     ;
    413                 ((_ (?mtx (?lock-arg0 ...) (?unlock-arg0 ...)) ?body ...)
    414                   (let ((mtx ?mtx))
    415         (mutex-lock! mtx ?lock-arg0 ...)
    416                                 (call-with-values
    417                                         (lambda () ?body ...)
    418                                         (lambda ret
    419                                                 (mutex-unlock! mtx ?unlock-arg0 ...)
    420                                                 (apply values ret))) ) )
    421     ;
    422                 ((_ ?mtx ?body ...)
    423                   (%*synch (?mtx () ()) ?body ...) ) ) )
    424 
    425 ;;
    426 
    427 (define-syntax %*synch-with
    428   (er-macro-transformer
    429     (lambda (frm rnm cmp)
    430       (##sys#check-syntax '%*synch-with frm '(_ _ variable . _))
    431       (let ((_call-with-values (rnm 'call-with-values))
    432             (_mutex-specific (rnm 'mutex-specific))
    433             (_mutex-lock! (rnm 'mutex-lock!))
    434             (_mutex-unlock! (rnm 'mutex-unlock!))
    435             (_let (rnm 'let))
    436             (_apply (rnm 'apply))
    437             (_values (rnm 'values))
    438             (_lambda (rnm 'lambda))
    439             (_ret (rnm 'ret))
    440             (mtxvar (rnm (gensym))))
    441         (let ((?mtx (cadr frm))
    442               (?var (caddr frm))
    443               (?body (cdddr frm)))
     382(define-syntax %synch
     383  (syntax-rules ()
     384    ;
     385    ((%synch (?mtx (?lock-arg0 ...) (?unlock-arg0 ...)) ?body ...)
     386      (let ((mtx ?mtx))
     387        (when (mutex-lock! mtx ?lock-arg0 ...)
     388          (call-with-values
     389            (lambda ()
     390              ?body ...)
     391            (lambda ret
     392              (mutex-unlock! mtx ?unlock-arg0 ...)
     393              (apply values ret))) ) ) )
     394    ;
     395    ((%synch ?mtx ?body ...)
     396      (%synch (?mtx () ()) ?body ...) ) ) )
     397
     398;;
     399
     400(define-syntax %synch-with
     401  (er-macro-transformer
     402    (lambda (frm rnm cmp)
     403      (##sys#check-syntax '%synch-with frm '(_ _ variable . _))
     404      (let (
     405        (_call-with-values (rnm 'call-with-values))
     406        (_mutex-specific (rnm 'mutex-specific))
     407        (_mutex-lock! (rnm 'mutex-lock!))
     408        (_mutex-unlock! (rnm 'mutex-unlock!))
     409        (_let (rnm 'let))
     410        (_apply (rnm 'apply))
     411        (_values (rnm 'values))
     412        (_lambda (rnm 'lambda))
     413        (_when (rnm 'when))
     414        (_ret (rnm 'ret))
     415        (mtxvar (rnm (gensym))) )
     416        (let (
     417          (?mtx (cadr frm))
     418          (?var (caddr frm))
     419          (?body (cdddr frm)) )
    444420          (call-with-values
    445421            (lambda ()
    446422              (if (not (pair? ?mtx))
    447423                (values ?mtx '() '())
    448                 (let ((mtx (car ?mtx))
    449                       (lock-args (if (<= 2 (length ?mtx)) (cadr ?mtx) '()))
    450                       (unlock-args (if (= 3 (length ?mtx)) (caddr ?mtx) '())) )
     424                (let (
     425                  (mtx (car ?mtx))
     426                  (lock-args (if (<= 2 (length ?mtx)) (cadr ?mtx) '()))
     427                  (unlock-args (if (= 3 (length ?mtx)) (caddr ?mtx) '())) )
    451428                  (values mtx lock-args unlock-args) ) ) )
    452429            (lambda (?mtx ?lock-args ?unlock-args)
    453430              `(,_let ((,mtxvar ,?mtx))
    454                  (,_let ((,?var (,_mutex-specific ,mtxvar)))
    455                    (,_mutex-lock! ,mtxvar ,@?lock-args)
    456                    (,_call-with-values
    457                      (,_lambda () ,@?body)
    458                      (,_lambda ,_ret
    459                        (,_mutex-unlock! ,mtxvar ,@?unlock-args)
    460                        (,_apply ,_values ,_ret)) ) ) ) ) ) ) ) ) ) )
    461 
    462 ;;
    463 
    464 (define-syntax %synch
    465         (syntax-rules ()
    466                 ((_ ?mtx ?body ...) (%*synch ?mtx ?body ...) ) ) )
    467 
    468 ;;
    469 
    470 (define-syntax %synch-with
    471         (syntax-rules ()
    472                 ((_ ?mtx ?var ?body ...)
    473                   (%*synch-with ?mtx ?var ?body ...) ) ) )
    474 
    475 (define-for-syntax %call-synch-transformer
    476         (syntax-rules ()
    477                 ((_ ?mtx ?proc ?arg0 ...)
    478                   (%*synch ?mtx (?proc ?arg0 ...)) ) ) )
    479 
    480 (define-syntax %call-synch %call-synch-transformer)
    481 
    482 (define-for-syntax %call-synch-with-transformer
    483         (syntax-rules ()
    484                 ((_ ?mtx ?proc ?arg0 ...)
    485                   (%*synch-with ?mtx var (?proc var ?arg0 ...)) ) ) )
    486 
    487 (define-syntax %call-synch-with %call-synch-with-transformer)
    488 
    489 (define-for-syntax %apply-synch-transformer
    490         (syntax-rules ()
    491                 ((_ ?mtx ?proc ?arg0 ...)
    492                   (%*synch ?mtx (apply ?proc ?arg0 ...)) ) ) )
    493 
    494 (define-syntax %apply-synch %apply-synch-transformer)
    495 
    496 (define-for-syntax %apply-synch-with-transformer
    497         (syntax-rules ()
    498                 ((_ ?mtx ?proc ?arg0 ...)
    499                   (%*synch-with ?mtx var (apply ?proc var ?arg0 ...)) ) ) )
    500 
    501 (define-syntax %apply-synch-with %apply-synch-with-transformer)
    502 
    503 (define-for-syntax %let-synch-with-transformer
     431                (,_let ((,?var (,_mutex-specific ,mtxvar)))
     432                  (,_when (,_mutex-lock! ,mtxvar ,@?lock-args)
     433                    (,_call-with-values
     434                      (,_lambda ()
     435                        ,@?body)
     436                      (,_lambda ,_ret
     437                        (,_mutex-unlock! ,mtxvar ,@?unlock-args)
     438                        (,_apply ,_values ,_ret))) ) ) ) ) ) ) ) ) ) )
     439
     440;;
     441
     442(define-syntax %call-synch
     443  (syntax-rules ()
     444    ((%call-synch ?mtx ?proc ?arg0 ...)
     445      (%synch ?mtx (?proc ?arg0 ...)) ) ) )
     446
     447(define-syntax %call-synch-with
     448  (syntax-rules ()
     449    ((%call-synch-with ?mtx ?proc ?arg0 ...)
     450      (%synch-with ?mtx var (?proc var ?arg0 ...)) ) ) )
     451
     452(define-syntax %apply-synch
     453  (syntax-rules ()
     454    ((%apply-synch ?mtx ?proc ?arg0 ...)
     455      (%synch ?mtx (apply ?proc ?arg0 ...)) ) ) )
     456
     457(define-syntax %apply-synch-with
     458  (syntax-rules ()
     459    ((%apply-synch-with ?mtx ?proc ?arg0 ...)
     460      (%synch-with ?mtx var (apply ?proc var ?arg0 ...)) ) ) )
     461
     462(define-syntax %let-synch-with
    504463  (er-macro-transformer
    505464    (lambda (frm rnm cmp)
     
    515474                  `((,_%synch-with ,(cadr bnd) ,(car bnd) ,@(loop (cdr ?bnds)))) ) ) ) ) ) ) ) ) )
    516475
    517 (define-syntax %let-synch-with %let-synch-with-transformer)
    518 
    519476(define-syntax %set!-synch-with
    520477  (er-macro-transformer
    521478    (lambda (frm rnm cmp)
    522       ;
    523479      (##sys#check-syntax 'set!-synch-with frm '(_ _ variable . #(_ 0)))
    524       ;
    525480      (let (
    526481        (_%synch-with (rnm '%synch-with) )
     
    530485        (_begin (rnm 'begin) )
    531486        (mtxvar (rnm (gensym)) ) )
    532         ;
    533487        (let (
    534488          (?mtx (cadr frm) )
    535489          (?var (caddr frm) )
    536490          (?body (cdddr frm) ) )
    537           ;
    538491          `(,_let ((,mtxvar ,?mtx))
    539492             (,_%synch-with ,mtxvar ,?var
     
    543496;;
    544497
    545 (define-for-syntax %synch-lock-transformer
    546         (syntax-rules ()
    547     ;
    548                 ((_ (?mtx (?lock-arg0 ...)) ?body ...)
    549                   (let ((mtx ?mtx) (ok? #f))
    550                                 (mutex-lock! mtx ?lock-arg0 ...)
    551                                 (call-with-values
    552                                         (lambda () (let ((res (begin ?body ...))) (set! ok? #t) res))
    553                                         (lambda ret
    554                                                 (unless ok? (mutex-unlock! mtx))
    555                                                 (apply values ret))) ) )
    556     ;
    557                 ((_ ?mtx ?body ...)
    558                   (%synch-lock (?mtx ()) ?body ...) ) ) )
    559 
    560 (define-syntax %synch-lock %synch-lock-transformer)
    561 
    562 (define-for-syntax %synch-unlock-transformer
    563         (syntax-rules ()
    564     ;
    565                 ((_ (?mtx (?unlock-arg0 ...)) ?body ...)
     498(define-syntax %synch-lock
     499  (syntax-rules ()
     500    ;
     501    ((%synch-lock (?mtx (?lock-arg0 ...)) ?body ...)
     502      (let ((mtx ?mtx) (ok? #f))
     503        (when (mutex-lock! mtx ?lock-arg0 ...)
     504          (call-with-values
     505            (lambda ()
     506              (let ((res (begin ?body ...)))
     507                (set! ok? #t)
     508                res))
     509            (lambda ret
     510              (unless ok? (mutex-unlock! mtx))
     511              (apply values ret))) ) ) )
     512    ;
     513    ((%synch-lock ?mtx ?body ...)
     514      (%synch-lock (?mtx ()) ?body ...) ) ) )
     515
     516(define-syntax %synch-unlock
     517  (syntax-rules ()
     518    ;
     519    ((%synch-unlock (?mtx (?unlock-arg0 ...)) ?body ...)
    566520      (let ((mtx ?mtx))
    567         (unless (thread? (mutex-state mtx))
    568           (warning '%synch-unlock "mutex is not locked - locking")
    569           (mutex-lock! mtx))
    570         (call-with-values
    571           (lambda () ?body ...)
    572           (lambda ret
    573             (mutex-unlock! mtx ?unlock-arg0 ...)
    574             (apply values ret)) ) ) )
    575     ;
    576                 ((_ ?mtx ?body ...)
     521        (let ((st (mutex-state mtx)))
     522          (if (or (eq 'abandoned st) (eq 'not-abandoned st))
     523            (error '%synch-unlock "mutex unlocked" mtx)
     524            (call-with-values
     525              (lambda ()
     526                ?body ...)
     527              (lambda ret
     528                (mutex-unlock! mtx ?unlock-arg0 ...)
     529                (apply values ret)) ) ) ) ) )
     530    ;
     531    ((%synch-unlock ?mtx ?body ...)
    577532      (%synch-unlock (?mtx ()) ?body ...) ) ) )
    578533
    579 (define-syntax %synch-unlock %synch-unlock-transformer)
    580 
    581 ;;
    582 
    583 (define-for-syntax %object-synch-cut-with-transformer
    584   (er-macro-transformer
    585     (lambda (frm rnm cmp)
    586       ;
     534;;
     535
     536(define-syntax %object-synch-cut-with
     537  (er-macro-transformer
     538    (lambda (frm rnm cmp)
    587539      (##sys#check-syntax '%object-synch-cut-with frm '(_ _ . _))
    588       ;
    589540      (let (
    590541        (_%synch-with (rnm '%synch-with))
     
    592543        (var (rnm (gensym)))
    593544        (mtx (cadr frm)) )
    594         ;
    595545        (let body-loop ((unparsed (cddr frm)) (parsed '()))
    596546          (if (null? unparsed)
    597             ;
     547            ;code walked
    598548            `(,_%synch-with ,mtx ,var ,@(reverse parsed))
    599             ;
     549            ;walk code
    600550            (let (
    601551              (expr (car unparsed))
    602552              (next (cdr unparsed)) )
    603               ;
    604553              (let expr-loop ((rest expr) (parsed-expr '()))
    605554                (cond
    606                   ;
    607555                  ((null? rest)
    608556                    (body-loop next (cons (reverse parsed-expr) parsed)))
    609                   ;
    610557                  ((pair? rest)
    611                     (let ((arg (car rest))
    612                           (next (cdr rest)))
     558                    (let (
     559                      (arg (car rest))
     560                      (next (cdr rest)))
    613561                      (if (cmp _>< arg)
    614                           (expr-loop next (cons var parsed-expr))
    615                           (expr-loop next (cons arg parsed-expr)) ) ))
    616                   ;
     562                        (expr-loop next (cons var parsed-expr))
     563                        (expr-loop next (cons arg parsed-expr)) ) ))
    617564                  ((cmp _>< rest)
    618565                    (body-loop next (cons var parsed)))
    619                   ;
    620566                  (else
    621567                    (body-loop next (cons rest parsed))) ) ) ) ) ) ) ) ) )
    622 
    623 (define-syntax %object-synch-cut-with %object-synch-cut-with-transformer)
    624568
    625569;;
     
    710654;FIXME this API sucks
    711655
    712 (define-for-syntax (synch-wrapper-name sym)
    713         (string->symbol (string-append (symbol->string sym) "-" "synch")) )
     656(define-for-syntax (synch-wrapper-name sym) (suffix-symbol sym "synch"))
    714657
    715658(define-syntax define-constructor-synch
    716659  (er-macro-transformer
    717660    (lambda (frm rnm cmp)
    718       ;
    719661      (##sys#check-syntax 'define-constructor-synch frm '(_ symbol . _))
    720       ;
    721662      (let (
    722663        (_define (rnm 'define) )
     
    724665        (_args (rnm (gensym 'args)) )
    725666        (_make-synch-with-object (rnm 'make-synch-with-object) ) )
    726         ;
    727667        (let* (
    728668          (prcnam (cadr frm) )
    729669          (id (if (not (null? (cddr frm))) `('(,(caddr frm))) `('(,prcnam))) )
    730670          (newnam (synch-wrapper-name prcnam) ) )
    731           ;
    732671          `(,_define (,newnam . ,_args)
    733672            (,_make-synch-with-object (,_apply ,prcnam ,_args) ,@id)) ) ) ) ) )
     
    736675  (er-macro-transformer
    737676    (lambda (frm rnm cmp)
    738       ;
    739677      (##sys#check-syntax 'define-predicate-synch frm '(_ symbol))
    740       ;
    741678      (let (
    742679        (_define (rnm 'define))
    743680        (_obj (rnm (gensym 'obj)))
    744681        (_synch-with-object? (rnm 'synch-with-object?)) )
    745         ;
    746682        (let* (
    747683          (prcnam (cadr frm))
    748684          (newnam (synch-wrapper-name prcnam)) )
    749           ;
    750685          `(,_define (,newnam ,_obj)
    751686            (,_synch-with-object? ,_obj ,prcnam)) ) ) ) ) )
     
    755690  (er-macro-transformer
    756691    (lambda (frm rnm cmp)
    757       ;
    758692      (##sys#check-syntax 'define-operation-synch frm '(_ symbol))
    759       ;
    760       (let ((_define (rnm 'define))
    761             (_apply (rnm 'apply))
    762             (_let (rnm 'let))
    763             (_car (rnm 'car))
    764             (_cdr (rnm 'cdr))
    765             (_if (rnm 'if))
    766             (_pair? (rnm 'pair?))
    767             (_synch-with (rnm 'synch-with))
    768             (_check-synch-with-object (rnm 'check-synch-with-object))
    769             (_mutex-specific (rnm 'mutex-specific))
    770             (_mtx+obj (rnm (gensym 'mtx+obj)))
    771             (_args (rnm (gensym 'args)))
    772             (_obj (rnm (gensym 'obj)))
    773             (_mtx (rnm (gensym 'mtx))) )
    774         (let* ((prcnam  (cadr frm))
    775                (newnam (synch-wrapper-name prcnam)) )
    776           `(,_define (,newnam ,_mtx+obj . ,_args)
    777              (,_let ((,_mtx (,_if (,_pair? ,_mtx+obj) (,_car ,_mtx+obj) ,_mtx+obj)))
    778                (,_check-synch-with-object ',newnam ,_mtx 'object-synch)
    779                (,_synch-with ,_mtx+obj ,_obj (,_apply ,prcnam ,_obj ,_args))) ) ) ) ) ) )
     693      (let (
     694        (_define (rnm 'define))
     695        (_apply (rnm 'apply))
     696        (_let (rnm 'let))
     697        (_car (rnm 'car))
     698        (_cdr (rnm 'cdr))
     699        (_if (rnm 'if))
     700        (_pair? (rnm 'pair?))
     701        (_synch-with (rnm 'synch-with))
     702        (_check-synch-with-object (rnm 'check-synch-with-object))
     703        (_mutex-specific (rnm 'mutex-specific))
     704        (_mtx-w-obj (rnm (gensym 'mtx-w-obj)))
     705        (_args (rnm (gensym 'args)))
     706        (_obj (rnm (gensym 'obj)))
     707        (_mtx (rnm (gensym 'mtx)))  )
     708        (let* (
     709          (prcnam  (cadr frm))
     710          (newnam (synch-wrapper-name prcnam)) )
     711          `(,_define (,newnam ,_mtx-w-obj . ,_args)
     712            (,_let ((,_mtx (,_if (,_pair? ,_mtx-w-obj) (,_car ,_mtx-w-obj) ,_mtx-w-obj)))
     713              (,_check-synch-with-object ',newnam ,_mtx 'object-synch)
     714              (,_synch-with ,_mtx-w-obj ,_obj (,_apply ,prcnam ,_obj ,_args))) ) ) ) ) ) )
     715
     716;;
     717
     718(define-for-syntax (%synch-wrapper-name sym) (suffix-symbol sym "%synch"))
    780719
    781720;operand must be the 1st argument
     
    783722  (er-macro-transformer
    784723    (lambda (frm rnm cmp)
    785       ;
    786       (define (%synch-wrapper-name sym)
    787         (string->symbol (string-append (symbol->string sym) "-" "%synch")) )
    788       ;
    789724      (##sys#check-syntax 'define-operation-%synch frm '(_ symbol))
    790       (let ((_define (rnm 'define))
    791             (_apply (rnm 'apply))
    792             (_let (rnm 'let))
    793             (_car (rnm 'car))
    794             (_cdr (rnm 'cdr))
    795             (_if (rnm 'if))
    796             (_pair? (rnm 'pair?))
    797             (_%synch-with (rnm '%synch-with))
    798             (_check-synch-with-object (rnm 'check-synch-with-object))
    799             (_mtx+obj (rnm (gensym 'mtx+obj)))
    800             (_args (rnm (gensym 'args)))
    801             (_obj (rnm (gensym 'obj)))
    802             (_mtx (rnm (gensym 'mtx))) )
     725      (let (
     726        (_define (rnm 'define))
     727        (_apply (rnm 'apply))
     728        (_let (rnm 'let))
     729        (_car (rnm 'car))
     730        (_cdr (rnm 'cdr))
     731        (_if (rnm 'if))
     732        (_pair? (rnm 'pair?))
     733        (_%synch-with (rnm '%synch-with))
     734        (_mtx-w-obj (rnm (gensym 'mtx-w-obj)))
     735        (_args (rnm (gensym 'args)))
     736        (_obj (rnm (gensym 'obj))) )
    803737        (let* (
    804738          (prcnam (cadr frm))
    805739          (newnam (%synch-wrapper-name prcnam)) )
    806           ;
    807           `(,_define (,newnam ,_mtx+obj . ,_args)
    808              (,_let ((,_mtx (,_if (,_pair? ,_mtx+obj) (,_car ,_mtx+obj) ,_mtx+obj)))
    809                (,_check-synch-with-object ',newnam ,_mtx 'object-synch)
    810                                                          (,_%synch-with ,_mtx+obj ,_obj (,_apply ,prcnam ,_obj ,_args)) ) ) ) ) ) ) )
    811 
     740          `(,_define (,newnam ,_mtx-w-obj . ,_args)
     741            (,_%synch-with ,_mtx-w-obj ,_obj (,_apply ,prcnam ,_obj ,_args)) ) ) ) ) ) )
     742
     743#|
    812744;; ;DEPRECATED
    813745
     
    1047979               (,_check-synch-with-object ',newnam ,_mtx 'object/synch)
    1048980                                                         (,_%synch-with ,_mtx+obj ,_obj (,_apply ,prcnam ,_obj ,_args)) ) ) ) ) ) ) )
     981|#
    1049982
    1050983) ;module synch
  • release/4/synch/trunk/synch.setup

    r36936 r37027  
    55(verify-extension-name 'synch)
    66
    7 (setup-shared-extension-module 'synch (extension-version "2.4.0")
     7(setup-shared-extension-module 'synch (extension-version "2.4.1")
    88  #:inline? #t
    99  #:types? #t
     
    1111
    1212#;
    13 (setup-shared-extension-module 'critical-region (extension-version "2.4.0")
     13(setup-shared-extension-module 'critical-region (extension-version "2.4.1")
    1414  #:inline? #t
    1515  #:types? #t
  • release/4/synch/trunk/tests/synch-test.scm

    r36936 r37027  
    1 ;;;; synch test
     1;;;; synch-test.scm  -*- Scheme -*-
     2;;;; Kon Lovett, Jul '18
     3
     4(use test)
     5
     6(test-begin "Synch")
     7
     8;;;
    29
    310(use
    4   test
    511  synch
    612  srfi-18
     
    814
    915;;;
     16
     17(test-begin "record synch")
    1018
    1119(define-record-type <foo>
     
    1927  (test "record-synch" '(1 2)
    2028    (record-synch tfoo <foo> (list (<foo>-x tfoo) (<foo>-y tfoo)))) )
     29
     30(test-end "record synch")
     31
     32;;; Synchronize
     33
     34(test-begin "exception synch")
     35
     36(let ((mx1 (make-mutex 'mx1)))
     37
     38  (define (f x) (abort 'ca1))
     39  ;(define (f x) (signal 'cs1))
     40
     41  (handle-exceptions exn
     42    (begin
     43      ;(test "expected exception" 'ca1 ((lambda () exn)))
     44      (test "mutex unlocked (after exception handled!)" 'not-abandoned (mutex-state mx1)) )
     45    (synch mx1
     46      (f 1) ) )
     47
     48  (mutex-lock! mx1)
     49  (test-assert "mutex locked" (thread? (mutex-state mx1)))
     50  (mutex-unlock! mx1)
     51  (test "mutex unlocked" 'not-abandoned (mutex-state mx1))
     52)
     53
     54(test-end "exception synch")
    2155
    2256;;; Synchronize thread access to an object
     
    3670;;
    3771
    38 (use srfi-69)
     72(use (srfi 69))
    3973
    4074(define (hash-table-count ht)
     
    93127;;;
    94128
     129(test-end "Synch")
     130
    95131(test-exit)
Note: See TracChangeset for help on using the changeset viewer.