Changeset 35094 in project


Ignore:
Timestamp:
01/31/18 01:24:49 (7 months ago)
Author:
kon
Message:

still obtuse

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

Legend:

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

    r35093 r35094  
    1818  apply-synch
    1919  apply-synch-with
    20   let-synch
    21   set!-synch
     20  let-synch-with
     21  set!-synch-with
    2222  synch-lock
    2323  synch-unlock
     
    3333  %apply-synch
    3434  %apply-synch-with
    35   %let-synch
    36   %set!-synch
     35  %let-synch-with
     36  %set!-synch-with
    3737  %synch-lock
    3838  %synch-unlock
     
    4242  %record-synch-unlock
    4343  ;;
    44   make-object-synch
    45   object?-synch
     44  make-synch-with-object
     45  synch-with-object?
    4646  define-constructor-synch
    4747  define-predicate-synch
    48   (define-operation-synch check-mutex+object)
     48  (define-operation-synch check-synch-with-object)
    4949  define-operation-%synch
    50   ;;DEPRECATED
     50  ;;
     51  ;DEPRECATED
    5152  call/synch
    5253  call-with/synch
     
    7778  define-constructor/synch
    7879  define-predicate/synch
    79   (define-operation/synch check-mutex+object)
     80  (define-operation/synch check-synch-with-object)
    8081  define-operation/%synch)
    8182
     
    126127  (er-macro-transformer
    127128    (lambda (frm rnm cmp)
     129      ;
    128130      (##sys#check-syntax 'synch-with frm '(_ _ variable . #(_ 0)))
    129       (let ((_dynamic-wind (rnm 'dynamic-wind))
    130             (_let (rnm 'let))
    131             (_lambda (rnm 'lambda))
    132             (_mutex-unlock! (rnm 'mutex-unlock!))
    133             (_mutex-specific (rnm 'mutex-specific))
    134             (_mutex-lock! (rnm 'mutex-lock!))
    135             (mtxvar (rnm (gensym))))
    136         (let ((?mtx (cadr frm)) (?var (caddr frm)) (?body (cdddr frm)) )
     131      ;
     132      (let (
     133        (_dynamic-wind (rnm 'dynamic-wind) )
     134        (_let (rnm 'let) )
     135        (_lambda (rnm 'lambda) )
     136        (_mutex-unlock! (rnm 'mutex-unlock!) )
     137        (_mutex-specific (rnm 'mutex-specific) )
     138        (_mutex-lock! (rnm 'mutex-lock!) )
     139        (mtxvar (rnm (gensym)) ) )
     140        ;
     141        (let (
     142          (?mtx (cadr frm) )
     143          (?var (caddr frm) )
     144          (?body (cdddr frm) ) )
     145          ;
    137146          (call-with-values
    138147            (lambda ()
     
    168177
    169178(define-syntax call-synch call-synch-transformer)
    170 ;DEPRECATED
    171 (define-syntax call/synch call-synch-transformer)
    172179
    173180(define-for-syntax call-synch-with-transformer
     
    188195
    189196(define-syntax call-synch-with call-synch-with-transformer)
    190 ;DEPRECATED
    191 (define-syntax call-with/synch call-synch-with-transformer)
    192197
    193198(define-for-syntax apply-synch-transformer
     
    206211
    207212(define-syntax apply-synch apply-synch-transformer)
    208 ;DEPRECATED
    209 (define-syntax apply/synch apply-synch-transformer)
    210213
    211214(define-for-syntax apply-synch-with-transformer
     
    226229
    227230(define-syntax apply-synch-with apply-synch-with-transformer)
    228 ;DEPRECATED
    229 (define-syntax apply-with/synch apply-synch-with-transformer)
    230 
    231 (define-for-syntax let-synch-transformer
    232   (er-macro-transformer
    233     (lambda (frm rnm cmp)
    234       (##sys#check-syntax 'let-synch frm '(_ list . _))
     231
     232(define-for-syntax let-synch-with-transformer
     233  (er-macro-transformer
     234    (lambda (frm rnm cmp)
     235      ;
     236      (##sys#check-syntax 'let-synch-with frm '(_ list . _))
     237      ;
    235238      (let ((_synch-with (rnm 'synch-with)))
    236         (let* ((?body (cddr frm))
    237                (res
    238                 (let loop ((bnds (cadr frm)))
    239                   (if (null? bnds)
    240                     ?body
    241                     (let ((?bnd (car bnds)))
    242                       (##sys#check-syntax 'let-synch ?bnd '(variable . _))
    243                       `((,_synch-with ,(cadr ?bnd) ,(car ?bnd) ,@(loop (cdr bnds)))) ) ) ) ) )
     239        (let* (
     240          (?body
     241            (cddr frm) )
     242          (res
     243            (let loop ((bnds (cadr frm)))
     244              (if (null? bnds)
     245                ?body
     246                (let ((?bnd (car bnds)))
     247                  (##sys#check-syntax 'let-synch-with ?bnd '(variable . _))
     248                  `((,_synch-with ,(cadr ?bnd) ,(car ?bnd) ,@(loop (cdr bnds)))) ) ) ) ) )
     249          ;
    244250          (car res) ) ) ) ) )
    245251
    246 (define-syntax let-synch let-synch-transformer)
    247 ;DEPRECATED
    248 (define-syntax let/synch let-synch-transformer)
    249 
    250 (define-for-syntax set!-synch-transformer
    251   (er-macro-transformer
    252     (lambda (frm rnm cmp)
    253       (##sys#check-syntax 'set!-synch frm '(_ pair . _))
    254       (let ((_synch-with (rnm 'synch-with))
    255             (_mutex-specific (rnm 'mutex-specific))
    256             (_mutex-specific-set! (rnm 'mutex-specific-set!))
    257             (_begin (rnm 'begin)))
    258         (let ((?bnd (cadr frm))
    259               (?body (cddr frm)))
    260           (let ((?var (car ?bnd))
    261                 (?mtx (cadr ?bnd)))
    262             `(,_synch-with ,?mtx ,?var
    263                (,_mutex-specific-set! ,?mtx (,_begin ,@?body))
    264                (,_mutex-specific ,?mtx) ) ) ) ) ) ) )
    265 
    266 (define-syntax set!-synch set!-synch-transformer)
    267 ;DEPRECATED
    268 (define-syntax set!/synch set!-synch-transformer)
     252(define-syntax let-synch-with let-synch-with-transformer)
     253
     254(define-syntax set!-synch-with
     255  (er-macro-transformer
     256    (lambda (frm rnm cmp)
     257      ;
     258      (##sys#check-syntax 'set!-synch-with frm '(_ _ variable . #(_ 0)))
     259      ;
     260      (let (
     261        (_synch-with (rnm 'synch-with) )
     262        (_mutex-specific (rnm 'mutex-specific) )
     263        (_mutex-specific-set! (rnm 'mutex-specific-set!) )
     264        (_begin (rnm 'begin) ) )
     265        ;
     266        (let (
     267          (?mtx (cadr frm) )
     268          (?var (caddr frm) )
     269          (?body (cdddr frm) ) )
     270          ;
     271          `(,_synch-with ,?mtx ,?var
     272             (,_mutex-specific-set! ,?mtx (,_begin ,@?body))
     273             (,_mutex-specific ,?mtx) ) ) ) ) ) )
    269274
    270275;;
     
    285290
    286291(define-syntax synch-lock synch-lock-transformer)
    287 ;DEPRECATED
    288 (define-syntax synch/lock synch-lock-transformer)
    289292
    290293(define-for-syntax synch-unlock-transformer
     
    305308
    306309(define-syntax synch-unlock synch-unlock-transformer)
    307 ;DEPRECATED
    308 (define-syntax synch/unlock synch-unlock-transformer)
    309310
    310311;;
     
    313314  (er-macro-transformer
    314315    (lambda (frm rnm cmp)
     316      ;
    315317      (##sys#check-syntax 'object-synch-cut-with frm '(_ _ . _))
    316       (let ((_synch-with (rnm 'synch-with))
    317             (_>< (rnm '><))
    318             (var (rnm (gensym)))
    319             (mtx (cadr frm)))
     318      ;
     319      (let (
     320        (_synch-with (rnm 'synch-with))
     321        (_>< (rnm '><))
     322        (var (rnm (gensym)))
     323        (mtx (cadr frm)) )
     324        ;
    320325        (let body-loop ((unparsed (cddr frm)) (parsed '()))
    321           (if (not (null? unparsed))
    322             (let ((expr (car unparsed))
    323                   (next (cdr unparsed)))
    324               (let expr-loop ((rest expr) (parsedexpr '()))
     326          (if (null? unparsed)
     327            ;
     328            `(,_synch-with ,mtx ,var ,@(reverse parsed))
     329            ;
     330            (let (
     331              (expr (car unparsed))
     332              (next (cdr unparsed)) )
     333              ;
     334              (let expr-loop ((rest expr) (parsed-expr '()))
    325335                (cond
     336                  ;
    326337                  ((null? rest)
    327                     (body-loop next (cons (reverse parsedexpr) parsed)))
     338                    (body-loop next (cons (reverse parsed-expr) parsed)))
     339                  ;
    328340                  ((pair? rest)
    329                     (let ((arg (car rest))
    330                           (next (cdr rest)))
     341                    (let (
     342                      (arg (car rest))
     343                      (next (cdr rest)) )
     344                      ;
    331345                      (if (cmp _>< arg)
    332                         (expr-loop next (cons var parsedexpr))
    333                         (expr-loop next (cons arg parsedexpr)) ) ))
     346                        (expr-loop next (cons var parsed-expr))
     347                        (expr-loop next (cons arg parsed-expr)) ) ))
     348                  ;
    334349                  ((cmp _>< rest)
    335350                    (body-loop next (cons var parsed)))
     351                  ;
    336352                  (else
    337                     (body-loop next (cons rest parsed))) ) ) )
    338             `(,_synch-with ,mtx ,var ,@(reverse parsed)) ) ) ) ) ) )
     353                    (body-loop next (cons rest parsed))) ) ) ) ) ) ) ) ) )
    339354
    340355(define-syntax object-synch-cut-with object-synch-cut-with-transformer)
    341 ;DEPRECATED
    342 (define-syntax object/synch object-synch-cut-with-transformer)
    343 
    344 ;;
    345 
    346 (define-for-syntax record-synch-transformer
    347   (er-macro-transformer
    348     (lambda (frm rnm cmp)
    349       (##sys#check-syntax 'record-synch frm '(_ symbol _ . _))
     356
     357;;
     358
     359(define-syntax record-synch
     360  (er-macro-transformer
     361    (lambda (frm rnm cmp)
     362      ;
     363      (##sys#check-syntax 'record-synch frm '(_ _ symbol . _))
     364      ;
    350365      (let ((_synch (rnm 'synch)))
    351         (let ((?sym (cadr frm))
    352               (?rec (caddr frm))
    353               (?body (cdddr frm)))
     366        (let (
     367          (?rec (cadr frm) )
     368          (?sym (caddr frm) )
     369          (?body (cdddr frm) ) )
     370          ;
    354371          `(,_synch (,(record-mutex-name ?sym) ,?rec) ,@?body) ) ) ) ) )
    355372
    356 (define-syntax record-synch record-synch-transformer)
    357 ;DEPRECATED
    358 (define-syntax record/synch record-synch-transformer)
    359 
    360 (define-for-syntax record-synch-lock-transformer
    361   (er-macro-transformer
    362     (lambda (frm rnm cmp)
    363       (##sys#check-syntax 'record-synch-lock frm '(_ symbol _ . _))
     373(define-syntax record-synch-lock
     374  (er-macro-transformer
     375    (lambda (frm rnm cmp)
     376      ;
     377      (##sys#check-syntax 'record-synch-lock frm '(_ _ symbol . _))
     378      ;
    364379      (let ((_synch-lock (rnm 'synch-lock)))
    365         (let ((?sym (cadr frm))
    366               (?rec (caddr frm))
    367               (?body (cdddr frm)))
     380        (let (
     381          (?rec (cadr frm) )
     382          (?sym (caddr frm) )
     383          (?body (cdddr frm) ) )
     384          ;
    368385          `(,_synch-lock (,(record-mutex-name ?sym) ,?rec) ,@?body) ) ) ) ) )
    369386
    370 (define-syntax record-synch-lock record-synch-lock-transformer)
    371 ;DEPRECATED
    372 (define-syntax record-synch/lock record-synch-lock-transformer)
    373 
    374 (define-for-syntax record-synch-unlock-transformer
    375   (er-macro-transformer
    376     (lambda (frm rnm cmp)
    377       (##sys#check-syntax 'record-synch-unlock frm '(_ symbol _ . _))
     387(define-syntax record-synch-unlock
     388  (er-macro-transformer
     389    (lambda (frm rnm cmp)
     390      ;
     391      (##sys#check-syntax 'record-synch-unlock frm '(_ _ symbol . _))
     392      ;
    378393      (let ((_synch-unlock (rnm 'synch-unlock)))
    379         (let ((?sym (cadr frm))
    380               (?rec (caddr frm))
    381               (?body (cdddr frm)))
     394        (let (
     395          (?rec (cadr frm) )
     396          (?sym (caddr frm) )
     397          (?body (cdddr frm) ) )
     398          ;
    382399          `(,_synch-unlock (,(record-mutex-name ?sym) ,?rec) ,@?body) ) ) ) ) )
    383 
    384 (define-syntax record-synch-unlock record-synch-unlock-transformer)
    385 ;DEPRECATED
    386 (define-syntax record-synch/unlock record-synch-unlock-transformer)
    387400
    388401;;; Unprotected
     
    459472
    460473(define-syntax %call-synch %call-synch-transformer)
    461 ;DEPRECATED
    462 (define-syntax %call/synch %call-synch-transformer)
    463474
    464475(define-for-syntax %call-synch-with-transformer
     
    468479
    469480(define-syntax %call-synch-with %call-synch-with-transformer)
    470 ;DEPRECATED
    471 (define-syntax %call-with/synch %call-synch-with-transformer)
    472481
    473482(define-for-syntax %apply-synch-transformer
     
    477486
    478487(define-syntax %apply-synch %apply-synch-transformer)
    479 ;DEPRECATED
    480 (define-syntax %apply/synch %apply-synch-transformer)
    481488
    482489(define-for-syntax %apply-synch-with-transformer
     
    486493
    487494(define-syntax %apply-synch-with %apply-synch-with-transformer)
    488 ;DEPRECATED
    489 (define-syntax %apply-with/synch %apply-synch-with-transformer)
    490 
    491 (define-for-syntax %let-synch-transformer
    492   (er-macro-transformer
    493     (lambda (frm rnm cmp)
    494       (##sys#check-syntax '%let-synch frm '(_ list . _))
     495
     496(define-for-syntax %let-synch-with-transformer
     497  (er-macro-transformer
     498    (lambda (frm rnm cmp)
     499      (##sys#check-syntax '%let-synch-with frm '(_ list . _))
    495500      (let ((_%synch-with (rnm '%synch-with)))
    496501        (let ((?body (cddr frm)))
     
    500505                ?body
    501506                (let ((bnd (car ?bnds)))
    502                   (##sys#check-syntax '%let-synch bnd '(variable _))
     507                  (##sys#check-syntax '%let-synch-with bnd '(variable _))
    503508                  `((,_%synch-with ,(cadr bnd) ,(car bnd) ,@(loop (cdr ?bnds)))) ) ) ) ) ) ) ) ) )
    504509
    505 (define-syntax %let-synch %let-synch-transformer)
    506 ;DEPRECATED
    507 (define-syntax %let/synch %let-synch-transformer)
    508 
    509 (define-for-syntax %set!-synch-transformer
    510   (er-macro-transformer
    511     (lambda (frm rnm cmp)
    512       (##sys#check-syntax '%set!-synch frm '(_ pair . _))
     510(define-syntax %let-synch-with %let-synch-with-transformer)
     511
     512(define-syntax %set!-synch-with
     513  (er-macro-transformer
     514    (lambda (frm rnm cmp)
     515      ;
     516      (##sys#check-syntax 'set!-synch-with frm '(_ _ variable . #(_ 0)))
     517      ;
     518      (let (
     519        (_%synch-with (rnm '%synch-with) )
     520        (_mutex-specific (rnm 'mutex-specific) )
     521        (_mutex-specific-set! (rnm 'mutex-specific-set!) )
     522        (_let (rnm 'let) )
     523        (_begin (rnm 'begin) )
     524        (mtxvar (rnm (gensym)) ) )
     525        ;
     526        (let (
     527          (?mtx (cadr frm) )
     528          (?var (caddr frm) )
     529          (?body (cdddr frm) ) )
     530          ;
     531          `(,_let ((,mtxvar ,?mtx))
     532             (,_%synch-with ,mtxvar ,?var
     533               (,_mutex-specific-set! ,mtxvar (,_begin ,@?body))
     534               (,_mutex-specific ,mtxvar) ) ) ) ) ) ) )
     535
     536;;
     537
     538(define-for-syntax %synch-lock-transformer
     539        (syntax-rules ()
     540    ;
     541                ((_ (?mtx (?lock-arg0 ...)) ?body ...)
     542                  (let ((mtx ?mtx) (ok? #f))
     543                                (mutex-lock! mtx ?lock-arg0 ...)
     544                                (call-with-values
     545                                        (lambda () (let ((res (begin ?body ...))) (set! ok? #t) res))
     546                                        (lambda ret
     547                                                (unless ok? (mutex-unlock! mtx))
     548                                                (apply values ret))) ) )
     549    ;
     550                ((_ ?mtx ?body ...)
     551                  (%synch-lock (?mtx ()) ?body ...) ) ) )
     552
     553(define-syntax %synch-lock %synch-lock-transformer)
     554
     555(define-for-syntax %synch-unlock-transformer
     556        (syntax-rules ()
     557    ;
     558                ((_ (?mtx (?unlock-arg0 ...)) ?body ...)
     559      (let ((mtx ?mtx))
     560        (unless (thread? (mutex-state mtx))
     561          (warning '%synch-unlock "mutex is not locked - locking")
     562          (mutex-lock! mtx))
     563        (call-with-values
     564          (lambda () ?body ...)
     565          (lambda ret
     566            (mutex-unlock! mtx ?unlock-arg0 ...)
     567            (apply values ret)) ) ) )
     568    ;
     569                ((_ ?mtx ?body ...)
     570      (%synch-unlock (?mtx ()) ?body ...) ) ) )
     571
     572(define-syntax %synch-unlock %synch-unlock-transformer)
     573
     574;;
     575
     576(define-for-syntax %object-synch-cut-with-transformer
     577  (er-macro-transformer
     578    (lambda (frm rnm cmp)
     579      ;
     580      (##sys#check-syntax '%object-synch-cut-with frm '(_ _ . _))
     581      ;
     582      (let (
     583        (_%synch-with (rnm '%synch-with))
     584        (_>< (rnm '><))
     585        (var (rnm (gensym)))
     586        (mtx (cadr frm)) )
     587        ;
     588        (let body-loop ((unparsed (cddr frm)) (parsed '()))
     589          (if (null? unparsed)
     590            ;
     591            `(,_%synch-with ,mtx ,var ,@(reverse parsed))
     592            ;
     593            (let (
     594              (expr (car unparsed))
     595              (next (cdr unparsed)) )
     596              ;
     597              (let expr-loop ((rest expr) (parsed-expr '()))
     598                (cond
     599                  ;
     600                  ((null? rest)
     601                    (body-loop next (cons (reverse parsed-expr) parsed)))
     602                  ;
     603                  ((pair? rest)
     604                    (let ((arg (car rest))
     605                          (next (cdr rest)))
     606                      (if (cmp _>< arg)
     607                          (expr-loop next (cons var parsed-expr))
     608                          (expr-loop next (cons arg parsed-expr)) ) ))
     609                  ;
     610                  ((cmp _>< rest)
     611                    (body-loop next (cons var parsed)))
     612                  ;
     613                  (else
     614                    (body-loop next (cons rest parsed))) ) ) ) ) ) ) ) ) )
     615
     616(define-syntax %object-synch-cut-with %object-synch-cut-with-transformer)
     617
     618;;
     619
     620(define-syntax %record-synch
     621  (er-macro-transformer
     622    (lambda (frm rnm cmp)
     623      ;
     624      (##sys#check-syntax '%record-synch frm '(_ _ symbol . _))
     625      ;
     626      (let ((_%synch (rnm '%synch)))
     627        (let (
     628          (?rec (cadr frm) )
     629          (?sym (caddr frm) )
     630          (?body (cdddr frm) ) )
     631          ;
     632          `(,_%synch (,(record-mutex-name ?sym) ,?rec) ,@?body) ) ) ) ) )
     633
     634(define-syntax %record-synch-lock
     635  (er-macro-transformer
     636    (lambda (frm rnm cmp)
     637      ;
     638      (##sys#check-syntax '%record-synch-lock frm '(_ _ symbol . _))
     639      ;
     640      (let ((_%synch-lock (rnm '%synch-lock)))
     641        (let (
     642          (?rec (cadr frm) )
     643          (?sym (caddr frm) )
     644          (?body (cdddr frm) ) )
     645          ;
     646          `(,_%synch-lock (,(record-mutex-name ?sym) ,?rec) ,@?body) ) ) ) ) )
     647
     648(define-syntax %record-synch-unlock
     649  (er-macro-transformer
     650    (lambda (frm rnm cmp)
     651      ;
     652      (##sys#check-syntax '%record-synch-unlock frm '(_ _ symbol . _))
     653      ;
     654      (let ((_%synch-unlock (rnm '%synch-unlock)))
     655        (let (
     656          (?rec (cadr frm) )
     657          (?sym (caddr frm) )
     658          (?body (cdddr frm) ) )
     659          ;
     660          `(,_%synch-unlock (,(record-mutex-name ?sym) ,?rec) ,@?body) ) ) ) ) )
     661
     662;;; Synch Object
     663
     664;;
     665
     666(define (mutex-with-object? obj)
     667        (and
     668          (mutex? obj)
     669    (not (eq? (void) (mutex-specific obj))) ) )
     670
     671;;
     672
     673(define (make-synch-with-object obj #!optional (name '(object-synch-)))
     674  (let* (
     675    (name (if (pair? name) (gensym (car name)) name) )
     676    (mutex (make-mutex name) ) )
     677    ;
     678    (mutex-specific-set! mutex obj)
     679    mutex ) )
     680
     681(define (synch-with-object? obj #!optional pred)
     682  (and
     683    (mutex-with-object? obj)
     684    (or
     685      (not pred)
     686      (pred (mutex-specific obj)) ) ) )
     687
     688(define-check+error-type synch-with-object)
     689
     690;;
     691
     692;FIXME this API sucks
     693
     694(define-for-syntax (synch-wrapper-name sym)
     695        (string->symbol (string-append (symbol->string sym) "-" "synch")) )
     696
     697(define-syntax define-constructor-synch
     698  (er-macro-transformer
     699    (lambda (frm rnm cmp)
     700      ;
     701      (##sys#check-syntax 'define-constructor-synch frm '(_ symbol . _))
     702      ;
     703      (let (
     704        (_define (rnm 'define) )
     705        (_apply (rnm 'apply) )
     706        (_args (rnm (gensym 'args)) )
     707        (_make-synch-with-object (rnm 'make-synch-with-object) ) )
     708        ;
     709        (let* (
     710          (prcnam (cadr frm) )
     711          (id (if (not (null? (cddr frm))) `('(,(caddr frm))) `('(,prcnam))) )
     712          (newnam (synch-wrapper-name prcnam) ) )
     713          ;
     714          `(,_define (,newnam . ,_args)
     715            (,_make-synch-with-object (,_apply ,prcnam ,_args) ,@id)) ) ) ) ) )
     716
     717(define-syntax define-predicate-synch
     718  (er-macro-transformer
     719    (lambda (frm rnm cmp)
     720      ;
     721      (##sys#check-syntax 'define-predicate-synch frm '(_ symbol))
     722      ;
     723      (let (
     724        (_define (rnm 'define))
     725        (_obj (rnm (gensym 'obj)))
     726        (_synch-with-object? (rnm 'synch-with-object?)) )
     727        ;
     728        (let* (
     729          (prcnam (cadr frm))
     730          (newnam (synch-wrapper-name prcnam)) )
     731          ;
     732          `(,_define (,newnam ,_obj)
     733            (,_synch-with-object? ,_obj ,prcnam)) ) ) ) ) )
     734
     735;operand must be the 1st argument
     736(define-syntax define-operation-synch
     737  (er-macro-transformer
     738    (lambda (frm rnm cmp)
     739      ;
     740      (##sys#check-syntax 'define-operation-synch frm '(_ symbol))
     741      ;
     742      (let ((_define (rnm 'define))
     743            (_apply (rnm 'apply))
     744            (_let (rnm 'let))
     745            (_car (rnm 'car))
     746            (_cdr (rnm 'cdr))
     747            (_if (rnm 'if))
     748            (_pair? (rnm 'pair?))
     749            (_synch-with (rnm 'synch-with))
     750            (_check-synch-with-object (rnm 'check-synch-with-object))
     751            (_mutex-specific (rnm 'mutex-specific))
     752            (_mtx+obj (rnm (gensym 'mtx+obj)))
     753            (_args (rnm (gensym 'args)))
     754            (_obj (rnm (gensym 'obj)))
     755            (_mtx (rnm (gensym 'mtx))) )
     756        (let* ((prcnam  (cadr frm))
     757               (newnam (synch-wrapper-name prcnam)) )
     758          `(,_define (,newnam ,_mtx+obj . ,_args)
     759             (,_let ((,_mtx (,_if (,_pair? ,_mtx+obj) (,_car ,_mtx+obj) ,_mtx+obj)))
     760               (,_check-synch-with-object ',newnam ,_mtx 'object-synch)
     761               (,_synch-with ,_mtx+obj ,_obj (,_apply ,prcnam ,_obj ,_args))) ) ) ) ) ) )
     762
     763;operand must be the 1st argument
     764(define-syntax define-operation-%synch
     765  (er-macro-transformer
     766    (lambda (frm rnm cmp)
     767      ;
     768      (define (%synch-wrapper-name sym)
     769        (string->symbol (string-append (symbol->string sym) "-" "%synch")) )
     770      ;
     771      (##sys#check-syntax 'define-operation-%synch frm '(_ symbol))
     772      (let ((_define (rnm 'define))
     773            (_apply (rnm 'apply))
     774            (_let (rnm 'let))
     775            (_car (rnm 'car))
     776            (_cdr (rnm 'cdr))
     777            (_if (rnm 'if))
     778            (_pair? (rnm 'pair?))
     779            (_%synch-with (rnm '%synch-with))
     780            (_check-synch-with-object (rnm 'check-synch-with-object))
     781            (_mtx+obj (rnm (gensym 'mtx+obj)))
     782            (_args (rnm (gensym 'args)))
     783            (_obj (rnm (gensym 'obj)))
     784            (_mtx (rnm (gensym 'mtx))) )
     785        (let* ((prcnam (cadr frm))
     786               (newnam (%synch-wrapper-name prcnam)) )
     787          `(,_define (,newnam ,_mtx+obj . ,_args)
     788             (,_let ((,_mtx (,_if (,_pair? ,_mtx+obj) (,_car ,_mtx+obj) ,_mtx+obj)))
     789               (,_check-synch-with-object ',newnam ,_mtx 'object-synch)
     790                                                         (,_%synch-with ,_mtx+obj ,_obj (,_apply ,prcnam ,_obj ,_args)) ) ) ) ) ) ) )
     791
     792;; ;DEPRECATED
     793
     794(define-syntax call/synch call-synch-transformer)
     795(define-syntax call-with/synch call-synch-with-transformer)
     796(define-syntax apply/synch apply-synch-transformer)
     797(define-syntax apply-with/synch apply-synch-with-transformer)
     798(define-syntax let/synch let-synch-with-transformer)
     799
     800(define-syntax set!/synch
     801  (er-macro-transformer
     802    (lambda (frm rnm cmp)
     803      (##sys#check-syntax 'set!/synch frm '(_ pair . _))
     804      (let ((_synch-with (rnm 'synch-with))
     805            (_mutex-specific (rnm 'mutex-specific))
     806            (_mutex-specific-set! (rnm 'mutex-specific-set!))
     807            (_begin (rnm 'begin)))
     808        (let ((?bnd (cadr frm))
     809              (?body (cddr frm)))
     810          (let ((?var (car ?bnd))
     811                (?mtx (cadr ?bnd)))
     812            `(,_synch-with ,?mtx ,?var
     813               (,_mutex-specific-set! ,?mtx (,_begin ,@?body))
     814               (,_mutex-specific ,?mtx) ) ) ) ) ) ) )
     815
     816(define-syntax synch/lock synch-lock-transformer)
     817(define-syntax synch/unlock synch-unlock-transformer)
     818(define-syntax object/synch object-synch-cut-with-transformer)
     819
     820(define-syntax record/synch
     821  (er-macro-transformer
     822    (lambda (frm rnm cmp)
     823      (##sys#check-syntax 'record/synch frm '(_ symbol _ . _))
     824      (let ((_synch (rnm 'synch)))
     825        (let ((?sym (cadr frm))
     826              (?rec (caddr frm))
     827              (?body (cdddr frm)))
     828          `(,_synch (,(record-mutex-name ?sym) ,?rec) ,@?body) ) ) ) ) )
     829
     830(define-syntax record-synch/lock
     831  (er-macro-transformer
     832    (lambda (frm rnm cmp)
     833      (##sys#check-syntax 'record-synch/lock frm '(_ symbol _ . _))
     834      (let ((_synch/lock (rnm 'synch/lock)))
     835        (let ((?sym (cadr frm))
     836              (?rec (caddr frm))
     837              (?body (cdddr frm)))
     838          `(,_synch/lock (,(record-mutex-name ?sym) ,?rec) ,@?body) ) ) ) ) )
     839
     840(define-syntax record-synch/unlock
     841  (er-macro-transformer
     842    (lambda (frm rnm cmp)
     843      (##sys#check-syntax 'record-synch/unlock frm '(_ symbol _ . _))
     844      (let ((_synch/unlock (rnm 'synch/unlock)))
     845        (let ((?sym (cadr frm))
     846              (?rec (caddr frm))
     847              (?body (cdddr frm)))
     848          `(,_synch/unlock (,(record-mutex-name ?sym) ,?rec) ,@?body) ) ) ) ) )
     849
     850(define-syntax %call/synch %call-synch-transformer)
     851(define-syntax %call-with/synch %call-synch-with-transformer)
     852(define-syntax %apply/synch %apply-synch-transformer)
     853(define-syntax %apply-with/synch %apply-synch-with-transformer)
     854(define-syntax %let/synch %let-synch-with-transformer)
     855
     856(define-syntax %set!/synch
     857  (er-macro-transformer
     858    (lambda (frm rnm cmp)
     859      (##sys#check-syntax '%set!/synch frm '(_ pair . _))
    513860      (let ((_%synch-with (rnm '%synch-with))
    514861            (_mutex-specific (rnm 'mutex-specific))
     
    526873                 (,_mutex-specific ,mtxvar) ) ) ) ) ) ) ) )
    527874
    528 (define-syntax %set!-synch %set!-synch-transformer)
    529 ;DEPRECATED
    530 (define-syntax %set!/synch %set!-synch-transformer)
    531 
    532 ;;
    533 
    534 (define-for-syntax %synch-lock-transformer
    535         (syntax-rules ()
    536     ;
    537                 ((_ (?mtx (?lock-arg0 ...)) ?body ...)
    538                   (let ((mtx ?mtx) (ok? #f))
    539                                 (mutex-lock! mtx ?lock-arg0 ...)
    540                                 (call-with-values
    541                                         (lambda () (let ((res (begin ?body ...))) (set! ok? #t) res))
    542                                         (lambda ret
    543                                                 (unless ok? (mutex-unlock! mtx))
    544                                                 (apply values ret))) ) )
    545     ;
    546                 ((_ ?mtx ?body ...)
    547                   (%synch-lock (?mtx ()) ?body ...) ) ) )
    548 
    549 (define-syntax %synch-lock %synch-lock-transformer)
    550 ;DEPRECATED
    551875(define-syntax %synch/lock %synch-lock-transformer)
    552 
    553 (define-for-syntax %synch-unlock-transformer
    554         (syntax-rules ()
    555     ;
    556                 ((_ (?mtx (?unlock-arg0 ...)) ?body ...)
    557       (let ((mtx ?mtx))
    558         (unless (thread? (mutex-state mtx))
    559           (warning '%synch-unlock "mutex is not locked - locking")
    560           (mutex-lock! mtx))
    561         (call-with-values
    562           (lambda () ?body ...)
    563           (lambda ret
    564             (mutex-unlock! mtx ?unlock-arg0 ...)
    565             (apply values ret)) ) ) )
    566     ;
    567                 ((_ ?mtx ?body ...)
    568       (%synch-unlock (?mtx ()) ?body ...) ) ) )
    569 
    570 (define-syntax %synch-unlock %synch-unlock-transformer)
    571 ;DEPRECATED
    572876(define-syntax %synch/unlock %synch-unlock-transformer)
    573 
    574 ;;
    575 
    576 (define-for-syntax %object-synch-cut-with-transformer
    577   (er-macro-transformer
    578     (lambda (frm rnm cmp)
    579       (##sys#check-syntax '%object-synch-cut-with frm '(_ _ . _))
    580       (let ((_%synch-with (rnm '%synch-with))
    581             (_>< (rnm '><))
    582             (var (rnm (gensym)))
    583             (mtx (cadr frm)))
    584         (let body-loop ((unparsed (cddr frm)) (parsed '()))
    585           (if (not (null? unparsed))
    586             (let ((expr (car unparsed))
    587                   (next (cdr unparsed)))
    588               (let expr-loop ((rest expr) (parsedexpr '()))
    589                 (cond
    590                   ((null? rest)
    591                     (body-loop next (cons (reverse parsedexpr) parsed)))
    592                   ((pair? rest)
    593                     (let ((arg (car rest))
    594                           (next (cdr rest)))
    595                       (if (cmp _>< arg)
    596                           (expr-loop next (cons var parsedexpr))
    597                           (expr-loop next (cons arg parsedexpr)) ) ))
    598                   ((cmp _>< rest)
    599                     (body-loop next (cons var parsed)))
    600                   (else
    601                     (body-loop next (cons rest parsed))) ) ) )
    602             `(,_%synch-with ,mtx ,var ,@(reverse parsed)) ) ) ) ) ) )
    603 
    604 (define-syntax %object-synch-cut-with %object-synch-cut-with-transformer)
    605 ;DEPRECATED
    606877(define-syntax %object/synch %object-synch-cut-with-transformer)
    607878
    608 ;;
    609 
    610 (define-for-syntax %record-synch-transformer
    611   (er-macro-transformer
    612     (lambda (frm rnm cmp)
    613       (##sys#check-syntax '%record-synch frm '(_ symbol _ . _))
     879(define-syntax %record/synch
     880  (er-macro-transformer
     881    (lambda (frm rnm cmp)
     882      (##sys#check-syntax '%record/synch frm '(_ symbol _ . _))
    614883      (let ((_%synch (rnm '%synch)))
    615884        (let ((?sym (cadr frm))
     
    618887          `(,_%synch (,(record-mutex-name ?sym) ,?rec) ,@?body) ) ) ) ) )
    619888
    620 (define-syntax %record-synch %record-synch-transformer)
    621 ;DEPRECATED
    622 (define-syntax %record/synch %record-synch-transformer)
    623 
    624 (define-for-syntax %record-synch-lock-transformer
     889(define-syntax %record-synch/lock
    625890  (er-macro-transformer
    626891  (lambda (frm rnm cmp)
    627     (##sys#check-syntax '%record-synch-lock frm '(_ symbol _ . _))
    628     (let ((_%synch-lock (rnm '%synch-lock)))
     892    (##sys#check-syntax '%record-synch/lock frm '(_ symbol _ . _))
     893    (let ((_%synch/lock (rnm '%synch/lock)))
    629894      (let ((?sym (cadr frm))
    630895            (?rec (caddr frm))
    631896            (?body (cdddr frm)))
    632         `(,_%synch-lock (,(record-mutex-name ?sym) ,?rec) ,@?body) ) ) ) ) )
    633 
    634 (define-syntax %record-synch-lock %record-synch-lock-transformer)
    635 ;DEPRECATED
    636 (define-syntax %record-synch/lock %record-synch-lock-transformer)
    637 
    638 (define-for-syntax %record-synch-unlock-transformer
    639   (er-macro-transformer
    640     (lambda (frm rnm cmp)
    641       (##sys#check-syntax '%record-synch-unlock frm '(_ symbol _ . _))
    642       (let ((_%synch-unlock (rnm '%synch-unlock)))
     897        `(,_%synch/lock (,(record-mutex-name ?sym) ,?rec) ,@?body) ) ) ) ) )
     898
     899(define-syntax %record-synch/unlock
     900  (er-macro-transformer
     901    (lambda (frm rnm cmp)
     902      (##sys#check-syntax '%record-synch/unlock frm '(_ symbol _ . _))
     903      (let ((_%synch/unlock (rnm '%synch/unlock)))
    643904        (let ((?sym (cadr frm))
    644905              (?rec (caddr frm))
    645906              (?body (cdddr frm)))
    646           `(,_%synch-unlock (,(record-mutex-name ?sym) ,?rec) ,@?body) ) ) ) ) )
    647 
    648 (define-syntax %record-synch-unlock %object-synch-cut-with-transformer)
    649 ;DEPRECATED
    650 (define-syntax %record-synch/unlock %record-synch-unlock-transformer)
    651 
    652 ;;; Synch Object
    653 
    654 (define (any? _)
    655   #t )
    656 
    657 (define (mutex+object? obj)
    658         (and
    659           (mutex? obj)
    660     (not (eq? (void) (mutex-specific obj))) ) )
    661 
    662 (define-check+error-type mutex+object)
    663 
    664 ;;
    665 
    666 (define (make-object-synch obj #!optional (name '(object-synch-)))
    667   (let ((mutex (make-mutex (if (pair? name) (gensym (car name)) name))))
    668     (mutex-specific-set! mutex obj)
    669     mutex ) )
    670 
    671 (define (object?-synch obj #!optional (pred any?))
    672   (and
    673     (mutex+object? obj)
    674     (pred (mutex-specific obj))) )
    675 
    676 (define-for-syntax (synch-wrapper-name sym)
    677         (string->symbol (string-append (symbol->string sym) "-" "synch")) )
    678 
    679 (define-syntax define-constructor-synch
    680   (er-macro-transformer
    681     (lambda (frm rnm cmp)
    682       (##sys#check-syntax 'define-constructor-synch frm '(_ symbol . _))
    683       (let ((_define (rnm 'define))
    684             (_apply (rnm 'apply))
    685             (_args (rnm (gensym 'args)))
    686             (_make-object-synch (rnm 'make-object-synch)) )
    687         (let* ((prcnam (cadr frm))
    688                (id (if (not (null? (cddr frm))) `('(,(caddr frm))) '()))
    689                (newnam (synch-wrapper-name prcnam)) )
    690           `(,_define (,newnam . ,_args)
    691              (,_make-object-synch (,_apply ,prcnam ,_args) ,@id)) ) ) ) ) )
    692 
    693 (define-syntax define-predicate-synch
    694   (er-macro-transformer
    695     (lambda (frm rnm cmp)
    696       (##sys#check-syntax 'define-predicate-synch frm '(_ symbol))
    697       (let ((_define (rnm 'define))
    698             (_obj (rnm (gensym 'obj)))
    699             (_object?-synch (rnm 'object?-synch)) )
    700         (let* ((prcnam (cadr frm))
    701                (newnam (synch-wrapper-name prcnam)) )
    702           `(,_define (,newnam ,_obj) (,_object?-synch ,_obj ,prcnam)) ) ) ) ) )
    703 
    704 ;operand must be the 1st argument
    705 (define-syntax define-operation-synch
    706   (er-macro-transformer
    707     (lambda (frm rnm cmp)
    708       (##sys#check-syntax 'define-operation-synch frm '(_ symbol))
    709       (let ((_define (rnm 'define))
    710             (_apply (rnm 'apply))
    711             (_let (rnm 'let))
    712             (_car (rnm 'car))
    713             (_cdr (rnm 'cdr))
    714             (_if (rnm 'if))
    715             (_pair? (rnm 'pair?))
    716             (_synch-with (rnm 'synch-with))
    717             (_check-mutex+object (rnm 'check-mutex+object))
    718             (_mutex-specific (rnm 'mutex-specific))
    719             (_mtx+obj (rnm (gensym 'mtx+obj)))
    720             (_args (rnm (gensym 'args)))
    721             (_obj (rnm (gensym 'obj)))
    722             (_mtx (rnm (gensym 'mtx))) )
    723         (let* ((prcnam  (cadr frm))
    724                (newnam (synch-wrapper-name prcnam)) )
    725           `(,_define (,newnam ,_mtx+obj . ,_args)
    726              (,_let ((,_mtx (,_if (,_pair? ,_mtx+obj) (,_car ,_mtx+obj) ,_mtx+obj)))
    727                (,_check-mutex+object ',newnam ,_mtx 'object-synch)
    728                (,_synch-with ,_mtx+obj ,_obj (,_apply ,prcnam ,_obj ,_args))) ) ) ) ) ) )
    729 
    730 ;operand must be the 1st argument
    731 (define-syntax define-operation-%synch
    732   (er-macro-transformer
    733     (lambda (frm rnm cmp)
    734       ;
    735       (define (%synch-wrapper-name sym)
    736         (string->symbol (string-append (symbol->string sym) "-" "%synch")) )
    737       ;
    738       (##sys#check-syntax 'define-operation-%synch frm '(_ symbol))
    739       (let ((_define (rnm 'define))
    740             (_apply (rnm 'apply))
    741             (_let (rnm 'let))
    742             (_car (rnm 'car))
    743             (_cdr (rnm 'cdr))
    744             (_if (rnm 'if))
    745             (_pair? (rnm 'pair?))
    746             (_%synch-with (rnm '%synch-with))
    747             (_check-mutex+object (rnm 'check-mutex+object))
    748             (_mtx+obj (rnm (gensym 'mtx+obj)))
    749             (_args (rnm (gensym 'args)))
    750             (_obj (rnm (gensym 'obj)))
    751             (_mtx (rnm (gensym 'mtx))) )
    752         (let* ((prcnam (cadr frm))
    753                (newnam (%synch-wrapper-name prcnam)) )
    754           `(,_define (,newnam ,_mtx+obj . ,_args)
    755              (,_let ((,_mtx (,_if (,_pair? ,_mtx+obj) (,_car ,_mtx+obj) ,_mtx+obj)))
    756                (,_check-mutex+object ',newnam ,_mtx 'object-synch)
    757                                                          (,_%synch-with ,_mtx+obj ,_obj (,_apply ,prcnam ,_obj ,_args)) ) ) ) ) ) ) )
    758 
    759 ;; ;DEPRECATED
    760 
    761 (define make-object/synch make-object-synch)
    762 
    763 (define object?/synch object?-synch)
     907          `(,_%synch/unlock (,(record-mutex-name ?sym) ,?rec) ,@?body) ) ) ) ) )
     908
     909(define make-object/synch make-synch-with-object)
     910(define object?/synch synch-with-object?)
     911
     912;
    764913
    765914(define-for-syntax (synch/wrapper-name sym)
     
    804953            (_pair? (rnm 'pair?))
    805954            (_synch-with (rnm 'synch-with))
    806             (_check-mutex+object (rnm 'check-mutex+object))
     955            (_check-synch-with-object (rnm 'check-synch-with-object))
    807956            (_mutex-specific (rnm 'mutex-specific))
    808957            (_mtx+obj (rnm (gensym 'mtx+obj)))
     
    814963          `(,_define (,newnam ,_mtx+obj . ,_args)
    815964             (,_let ((,_mtx (,_if (,_pair? ,_mtx+obj) (,_car ,_mtx+obj) ,_mtx+obj)))
    816                (,_check-mutex+object ',newnam ,_mtx 'object/synch)
     965               (,_check-synch-with-object ',newnam ,_mtx 'object/synch)
    817966               (,_synch-with ,_mtx+obj ,_obj (,_apply ,prcnam ,_obj ,_args))) ) ) ) ) ) )
    818967
     
    834983            (_pair? (rnm 'pair?))
    835984            (_%synch-with (rnm '%synch-with))
    836             (_check-mutex+object (rnm 'check-mutex+object))
     985            (_check-synch-with-object (rnm 'check-synch-with-object))
    837986            (_mtx+obj (rnm (gensym 'mtx+obj)))
    838987            (_args (rnm (gensym 'args)))
     
    843992          `(,_define (,newnam ,_mtx+obj . ,_args)
    844993             (,_let ((,_mtx (,_if (,_pair? ,_mtx+obj) (,_car ,_mtx+obj) ,_mtx+obj)))
    845                (,_check-mutex+object ',newnam ,_mtx 'object/synch)
     994               (,_check-synch-with-object ',newnam ,_mtx 'object/synch)
    846995                                                         (,_%synch-with ,_mtx+obj ,_obj (,_apply ,prcnam ,_obj ,_args)) ) ) ) ) ) ) )
    847996
  • release/4/synch/trunk/tests/synch-test.scm

    r35091 r35094  
    11;;;; synch test
    22
    3 (use synch srfi-18 srfi-69 miscmacros)
     3(use
     4  test
     5  synch
     6  srfi-18
     7  miscmacros)
     8
     9;;;
     10
     11(define-record-type <foo>
     12  (make-<foo> x y mtx)
     13  <foo>?
     14  (x <foo>-x)
     15  (y <foo>-y)
     16  (mtx <foo>-mutex))
     17
     18(let ((tfoo (make-<foo> 1 2 (make-mutex))))
     19  (test "record-synch" '(1 2)
     20    (record-synch tfoo <foo> (list (<foo>-x tfoo) (<foo>-y tfoo)))) )
     21
     22;;; Synchronize thread access to an object
     23
     24(test-begin "hash-table synch")
    425
    526;;
     
    1334          '?ident) ) ) ) )
    1435
    15 ;;;
     36;;
    1637
    17 (define-record-type <foo>
    18   (make-<foo> x y mtx)
    19   <foo>?
    20   (x <foo>-x)
    21   (y <foo>-y)
    22   (mtx <foo>-mutex))
    23 
    24 (define tfoo (make-<foo> 1 2 (make-mutex)))
    25 (print "*** prints 1 2 ***")
    26 (record-synch <foo> tfoo (print (<foo>-x tfoo) " " (<foo>-y tfoo)))
    27 (newline)
    28 
    29 ;;; Synchronize thread access to an object
    30 
    31 ;;
     38(use srfi-69)
    3239
    3340(define (hash-table-count ht)
     
    3744;;
    3845
    39 (define-constructor-synch make-hash-table hash-table-synch:)
     46(define-constructor-synch make-hash-table)
    4047(define-predicate-synch hash-table?)
    4148(define-operation-synch hash-table-count)
     
    4855(define-constant READER-THREAD-LIMIT 20)
    4956
    50 (define-constant THREAD-SLEEP-MS 0 #;2000)
     57(define-constant THREAD-SLEEP-MS 0)
     58(define-constant READ-FACTOR 1)
     59(define-constant WRITE-FACTOR 1)
    5160
    5261;; Greedy Reader
     
    5766        (print "test hash-table count = " n " so quit"))
    5867    (print "test hash-table count = " n)
    59     (thread-sleep! THREAD-SLEEP-MS) ) )
     68    (thread-sleep! (fx* READ-FACTOR THREAD-SLEEP-MS)) ) )
    6069
    6170;; Cooperative Writer
     
    6574    (hash-table-set!-synch +tht+ it (number->string it))
    6675    (hash-table-set!-synch +tht+ (* it 11) (number->string it))
    67     (thread-sleep! THREAD-SLEEP-MS)
     76    (thread-sleep! (fx* WRITE-FACTOR THREAD-SLEEP-MS))
    6877    (thread-yield!) ) )
    69 
    70 ;;
    7178
    7279(thread-start! writer-thread)
     
    7582(thread-join! writer-thread)
    7683(thread-join! reader-thread)
     84
     85(test-end "hash-table synch")
     86
     87;;
     88
Note: See TracChangeset for help on using the changeset viewer.